1 |
C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_slice_loc.F,v 1.10 2009/08/05 23:17:54 jmc Exp $ |
2 |
C $Name: $ |
3 |
|
4 |
#include "MDSIO_OPTIONS.h" |
5 |
|
6 |
C======================================================================= |
7 |
SUBROUTINE MDSREADFIELDXZ_LOC( |
8 |
I fName, |
9 |
I filePrec, |
10 |
I arrType, |
11 |
I nNz, |
12 |
| arr, |
13 |
I irecord, |
14 |
I myThid ) |
15 |
C |
16 |
C Arguments: |
17 |
C |
18 |
C fName string base name for file to read |
19 |
C filePrec integer number of bits per word in file (32 or 64) |
20 |
C arrType char(2) declaration of "arr": either "RS" or "RL" |
21 |
C nNz integer size of third dimension: normally either 1 or Nr |
22 |
C arr RS/RL array to read into, arr(:,:,nNz,:,:) |
23 |
C irecord integer record number to read |
24 |
C myThid integer thread identifier |
25 |
C |
26 |
C MDSREADFIELD first checks to see if the file "fName" exists, then |
27 |
C if the file "fName.data" exists and finally the tiled files of the |
28 |
C form "fName.xxx.yyy.data" exist. |
29 |
C The precision of the file is decsribed by filePrec, set either |
30 |
C to floatPrec32 or floatPrec64. The precision or declaration of |
31 |
C the array argument must be consistently described by the char*(2) |
32 |
C string arrType, either "RS" or "RL". |
33 |
C This routine reads vertical slices (X-Z) including the overlap region. |
34 |
C irecord is the record number to be read and must be >= 1. |
35 |
C The file data is stored in arr *but* the overlaps are *not* updated. |
36 |
C |
37 |
C Created: 06/03/00 spk@ocean.mit.edu |
38 |
C |
39 |
|
40 |
implicit none |
41 |
C Global variables / common blocks |
42 |
#include "SIZE.h" |
43 |
#include "EEPARAMS.h" |
44 |
#include "PARAMS.h" |
45 |
|
46 |
C Routine arguments |
47 |
character*(*) fName |
48 |
integer filePrec |
49 |
character*(2) arrType |
50 |
integer nNz |
51 |
_RL arr(*) |
52 |
integer irecord |
53 |
integer myThid |
54 |
C Functions |
55 |
integer ILNBLNK |
56 |
integer MDS_RECLEN |
57 |
C Local variables |
58 |
character*(MAX_LEN_FNAM) dataFName |
59 |
integer iG,jG,irec,bi,bj,k,dUnit,IL |
60 |
logical exst |
61 |
Real*4 r4seg(sNx) |
62 |
Real*8 r8seg(sNx) |
63 |
logical globalFile,fileIsOpen |
64 |
integer length_of_rec |
65 |
character*(max_len_mbuf) msgbuf |
66 |
C ------------------------------------------------------------------ |
67 |
|
68 |
C Only do I/O if I am the master thread |
69 |
_BEGIN_MASTER( myThid ) |
70 |
|
71 |
C Record number must be >= 1 |
72 |
if (irecord .LT. 1) then |
73 |
write(msgbuf,'(a,i9.8)') |
74 |
& ' MDSREADFIELDXZ: argument irecord = ',irecord |
75 |
call print_message( msgbuf, standardmessageunit, |
76 |
& SQUEEZE_RIGHT , mythid) |
77 |
write(msgbuf,'(a)') |
78 |
& ' MDSREADFIELDXZ: Invalid value for irecord' |
79 |
call print_error( msgbuf, mythid ) |
80 |
stop 'ABNORMAL END: S/R MDSREADFIELDXZ' |
81 |
endif |
82 |
|
83 |
C Assume nothing |
84 |
globalFile = .FALSE. |
85 |
fileIsOpen = .FALSE. |
86 |
IL=ILNBLNK( fName ) |
87 |
|
88 |
C Assign a free unit number as the I/O channel for this routine |
89 |
call MDSFINDUNIT( dUnit, mythid ) |
90 |
|
91 |
C Check first for global file with simple name (ie. fName) |
92 |
dataFName = fName |
93 |
inquire( file=dataFName, exist=exst ) |
94 |
if (exst) then |
95 |
if ( debugLevel .GE. debLevA ) then |
96 |
write(msgbuf,'(a,a)') |
97 |
& ' MDSREADFIELDXZ: opening global file: ',dataFName(1:IL) |
98 |
call print_message( msgbuf, standardmessageunit, |
99 |
& SQUEEZE_RIGHT , mythid) |
100 |
endif |
101 |
globalFile = .TRUE. |
102 |
endif |
103 |
|
104 |
C If negative check for global file with MDS name (ie. fName.data) |
105 |
if (.NOT. globalFile) then |
106 |
write(dataFName,'(2a)') fName(1:IL),'.data' |
107 |
inquire( file=dataFName, exist=exst ) |
108 |
if (exst) then |
109 |
if ( debugLevel .GE. debLevA ) then |
110 |
write(msgbuf,'(a,a)') |
111 |
& ' MDSREADFIELDXZ: opening global file: ',dataFName(1:IL+5) |
112 |
call print_message( msgbuf, standardmessageunit, |
113 |
& SQUEEZE_RIGHT , mythid) |
114 |
endif |
115 |
globalFile = .TRUE. |
116 |
endif |
117 |
endif |
118 |
|
119 |
C If we are reading from a global file then we open it here |
120 |
if (globalFile) then |
121 |
length_of_rec=MDS_RECLEN( filePrec, sNx, mythid ) |
122 |
open( dUnit, file=dataFName, status='old', |
123 |
& access='direct', recl=length_of_rec ) |
124 |
fileIsOpen=.TRUE. |
125 |
endif |
126 |
|
127 |
C Loop over all tiles |
128 |
do bj=1,nSy |
129 |
do bi=1,nSx |
130 |
C If we are reading from a tiled MDS file then we open each one here |
131 |
if (.NOT. globalFile) then |
132 |
iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles |
133 |
jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles |
134 |
write(dataFName,'(2a,i3.3,a,i3.3,a)') |
135 |
& fName(1:IL),'.',iG,'.',jG,'.data' |
136 |
inquire( file=dataFName, exist=exst ) |
137 |
C Of course, we only open the file if the tile is "active" |
138 |
C (This is a place-holder for the active/passive mechanism |
139 |
if (exst) then |
140 |
if ( debugLevel .GE. debLevA ) then |
141 |
write(msgbuf,'(a,a)') |
142 |
& ' MDSREADFIELDXZ: opening file: ',dataFName(1:IL+13) |
143 |
call print_message( msgbuf, standardmessageunit, |
144 |
& SQUEEZE_RIGHT , mythid) |
145 |
endif |
146 |
length_of_rec=MDS_RECLEN( filePrec, sNx, mythid ) |
147 |
open( dUnit, file=dataFName, status='old', |
148 |
& access='direct', recl=length_of_rec ) |
149 |
fileIsOpen=.TRUE. |
150 |
else |
151 |
fileIsOpen=.FALSE. |
152 |
write(msgbuf,'(a,a)') |
153 |
& ' MDSREADFIELDXZ: filename: ',dataFName(1:IL+13) |
154 |
call print_message( msgbuf, standardmessageunit, |
155 |
& SQUEEZE_RIGHT , mythid) |
156 |
write(msgbuf,'(a)') |
157 |
& ' MDSREADFIELDXZ: File does not exist' |
158 |
call print_error( msgbuf, mythid ) |
159 |
stop 'ABNORMAL END: S/R MDSREADFIELDXZ' |
160 |
endif |
161 |
endif |
162 |
|
163 |
if (fileIsOpen) then |
164 |
do k=1,nNz |
165 |
if (globalFile) then |
166 |
iG = myXGlobalLo-1 + (bi-1)*sNx |
167 |
jG = (myYGlobalLo-1)/sNy + (bj-1) |
168 |
irec=1 + INT(iG/sNx) + nSx*nPx*(k-1) |
169 |
& + nSx*nPx*nNz*(irecord-1) |
170 |
else |
171 |
iG = 0 |
172 |
jG = 0 |
173 |
irec=k + nNz*(irecord-1) |
174 |
endif |
175 |
if (filePrec .eq. precFloat32) then |
176 |
read(dUnit,rec=irec) r4seg |
177 |
#ifdef _BYTESWAPIO |
178 |
call MDS_BYTESWAPR4(sNx,r4seg) |
179 |
#endif |
180 |
if (arrType .eq. 'RS') then |
181 |
call MDS_SEG4toRS_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r4seg,arr) |
182 |
elseif (arrType .eq. 'RL') then |
183 |
call MDS_SEG4toRL_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r4seg,arr) |
184 |
else |
185 |
write(msgbuf,'(a)') |
186 |
& ' MDSREADFIELDXZ: illegal value for arrType' |
187 |
call print_error( msgbuf, mythid ) |
188 |
stop 'ABNORMAL END: S/R MDSREADFIELDXZ' |
189 |
endif |
190 |
elseif (filePrec .eq. precFloat64) then |
191 |
read(dUnit,rec=irec) r8seg |
192 |
#ifdef _BYTESWAPIO |
193 |
call MDS_BYTESWAPR8( sNx, r8seg ) |
194 |
#endif |
195 |
if (arrType .eq. 'RS') then |
196 |
call MDS_SEG8toRS_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r8seg,arr) |
197 |
elseif (arrType .eq. 'RL') then |
198 |
call MDS_SEG8toRL_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r8seg,arr) |
199 |
else |
200 |
write(msgbuf,'(a)') |
201 |
& ' MDSREADFIELDXZ: illegal value for arrType' |
202 |
call print_error( msgbuf, mythid ) |
203 |
stop 'ABNORMAL END: S/R MDSREADFIELDXZ' |
204 |
endif |
205 |
else |
206 |
write(msgbuf,'(a)') |
207 |
& ' MDSREADFIELDXZ: illegal value for filePrec' |
208 |
call print_error( msgbuf, mythid ) |
209 |
stop 'ABNORMAL END: S/R MDSREADFIELDXZ' |
210 |
endif |
211 |
C End of k loop |
212 |
enddo |
213 |
if (.NOT. globalFile) then |
214 |
close( dUnit ) |
215 |
fileIsOpen = .FALSE. |
216 |
endif |
217 |
endif |
218 |
C End of bi,bj loops |
219 |
enddo |
220 |
enddo |
221 |
|
222 |
C If global file was opened then close it |
223 |
if (fileIsOpen .AND. globalFile) then |
224 |
close( dUnit ) |
225 |
fileIsOpen = .FALSE. |
226 |
endif |
227 |
|
228 |
_END_MASTER( myThid ) |
229 |
|
230 |
C ------------------------------------------------------------------ |
231 |
return |
232 |
end |
233 |
C======================================================================= |
234 |
|
235 |
C======================================================================= |
236 |
SUBROUTINE MDSREADFIELDYZ_LOC( |
237 |
I fName, |
238 |
I filePrec, |
239 |
I arrType, |
240 |
I nNz, |
241 |
| arr, |
242 |
I irecord, |
243 |
I myThid ) |
244 |
C |
245 |
C Arguments: |
246 |
C |
247 |
C fName string base name for file to read |
248 |
C filePrec integer number of bits per word in file (32 or 64) |
249 |
C arrType char(2) declaration of "arr": either "RS" or "RL" |
250 |
C nNz integer size of third dimension: normally either 1 or Nr |
251 |
C arr RS/RL array to read into, arr(:,:,nNz,:,:) |
252 |
C irecord integer record number to read |
253 |
C myThid integer thread identifier |
254 |
C |
255 |
C MDSREADFIELD first checks to see if the file "fName" exists, then |
256 |
C if the file "fName.data" exists and finally the tiled files of the |
257 |
C form "fName.xxx.yyy.data" exist. |
258 |
C The precision of the file is decsribed by filePrec, set either |
259 |
C to floatPrec32 or floatPrec64. The precision or declaration of |
260 |
C the array argument must be consistently described by the char*(2) |
261 |
C string arrType, either "RS" or "RL". |
262 |
C This routine reads vertical slices (Y-Z) including overlap regions. |
263 |
C irecord is the record number to be read and must be >= 1. |
264 |
C The file data is stored in arr *but* the overlaps are *not* updated. |
265 |
C |
266 |
C Created: 06/03/00 spk@ocean.mit.edu |
267 |
C |
268 |
|
269 |
implicit none |
270 |
C Global variables / common blocks |
271 |
#include "SIZE.h" |
272 |
#include "EEPARAMS.h" |
273 |
#include "PARAMS.h" |
274 |
|
275 |
C Routine arguments |
276 |
character*(*) fName |
277 |
integer filePrec |
278 |
character*(2) arrType |
279 |
integer nNz |
280 |
_RL arr(*) |
281 |
integer irecord |
282 |
integer myThid |
283 |
C Functions |
284 |
integer ILNBLNK |
285 |
integer MDS_RECLEN |
286 |
C Local variables |
287 |
character*(MAX_LEN_FNAM) dataFName |
288 |
integer iG,jG,irec,bi,bj,k,dUnit,IL |
289 |
logical exst |
290 |
Real*4 r4seg(sNy) |
291 |
Real*8 r8seg(sNy) |
292 |
logical globalFile,fileIsOpen |
293 |
integer length_of_rec |
294 |
character*(max_len_mbuf) msgbuf |
295 |
C ------------------------------------------------------------------ |
296 |
|
297 |
C Only do I/O if I am the master thread |
298 |
_BEGIN_MASTER( myThid ) |
299 |
|
300 |
C Record number must be >= 1 |
301 |
if (irecord .LT. 1) then |
302 |
write(msgbuf,'(a,i9.8)') |
303 |
& ' MDSREADFIELDYZ: argument irecord = ',irecord |
304 |
call print_message( msgbuf, standardmessageunit, |
305 |
& SQUEEZE_RIGHT , mythid) |
306 |
write(msgbuf,'(a)') |
307 |
& ' MDSREADFIELDYZ: Invalid value for irecord' |
308 |
call print_error( msgbuf, mythid ) |
309 |
stop 'ABNORMAL END: S/R MDSREADFIELDYZ' |
310 |
endif |
311 |
|
312 |
C Assume nothing |
313 |
globalFile = .FALSE. |
314 |
fileIsOpen = .FALSE. |
315 |
IL=ILNBLNK( fName ) |
316 |
|
317 |
C Assign a free unit number as the I/O channel for this routine |
318 |
call MDSFINDUNIT( dUnit, mythid ) |
319 |
|
320 |
C Check first for global file with simple name (ie. fName) |
321 |
dataFName = fName |
322 |
inquire( file=dataFName, exist=exst ) |
323 |
if (exst) then |
324 |
if ( debugLevel .GE. debLevA ) then |
325 |
write(msgbuf,'(a,a)') |
326 |
& ' MDSREADFIELDYZ: opening global file: ',dataFName(1:IL) |
327 |
call print_message( msgbuf, standardmessageunit, |
328 |
& SQUEEZE_RIGHT , mythid) |
329 |
endif |
330 |
globalFile = .TRUE. |
331 |
endif |
332 |
|
333 |
C If negative check for global file with MDS name (ie. fName.data) |
334 |
if (.NOT. globalFile) then |
335 |
write(dataFName,'(2a)') fName(1:IL),'.data' |
336 |
inquire( file=dataFName, exist=exst ) |
337 |
if (exst) then |
338 |
if ( debugLevel .GE. debLevA ) then |
339 |
write(msgbuf,'(a,a)') |
340 |
& ' MDSREADFIELDYZ: opening global file: ',dataFName(1:IL+5) |
341 |
call print_message( msgbuf, standardmessageunit, |
342 |
& SQUEEZE_RIGHT , mythid) |
343 |
endif |
344 |
globalFile = .TRUE. |
345 |
endif |
346 |
endif |
347 |
|
348 |
C If we are reading from a global file then we open it here |
349 |
if (globalFile) then |
350 |
length_of_rec=MDS_RECLEN( filePrec, sNy, mythid ) |
351 |
open( dUnit, file=dataFName, status='old', |
352 |
& access='direct', recl=length_of_rec ) |
353 |
fileIsOpen=.TRUE. |
354 |
endif |
355 |
|
356 |
C Loop over all tiles |
357 |
do bj=1,nSy |
358 |
do bi=1,nSx |
359 |
C If we are reading from a tiled MDS file then we open each one here |
360 |
if (.NOT. globalFile) then |
361 |
iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles |
362 |
jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles |
363 |
write(dataFName,'(2a,i3.3,a,i3.3,a)') |
364 |
& fName(1:IL),'.',iG,'.',jG,'.data' |
365 |
inquire( file=dataFName, exist=exst ) |
366 |
C Of course, we only open the file if the tile is "active" |
367 |
C (This is a place-holder for the active/passive mechanism |
368 |
if (exst) then |
369 |
if ( debugLevel .GE. debLevA ) then |
370 |
write(msgbuf,'(a,a)') |
371 |
& ' MDSREADFIELDYZ: opening file: ',dataFName(1:IL+13) |
372 |
call print_message( msgbuf, standardmessageunit, |
373 |
& SQUEEZE_RIGHT , mythid) |
374 |
endif |
375 |
length_of_rec=MDS_RECLEN( filePrec, sNy, mythid ) |
376 |
open( dUnit, file=dataFName, status='old', |
377 |
& access='direct', recl=length_of_rec ) |
378 |
fileIsOpen=.TRUE. |
379 |
else |
380 |
fileIsOpen=.FALSE. |
381 |
write(msgbuf,'(a,a)') |
382 |
& ' MDSREADFIELDYZ: filename: ',dataFName(1:IL+13) |
383 |
call print_message( msgbuf, standardmessageunit, |
384 |
& SQUEEZE_RIGHT , mythid) |
385 |
write(msgbuf,'(a)') |
386 |
& ' MDSREADFIELDYZ: File does not exist' |
387 |
call print_error( msgbuf, mythid ) |
388 |
stop 'ABNORMAL END: S/R MDSREADFIELDYZ' |
389 |
endif |
390 |
endif |
391 |
|
392 |
if (fileIsOpen) then |
393 |
do k=1,nNz |
394 |
if (globalFile) then |
395 |
iG = (myXGlobalLo-1)/sNx + (bi-1) |
396 |
jG = myYGlobalLo-1 + (bj-1)*sNy |
397 |
irec=1 + INT(jG/sNy) + nSy*nPy*(k-1) |
398 |
& + nSy*nPy*nNz*(irecord-1) |
399 |
else |
400 |
iG = 0 |
401 |
jG = 0 |
402 |
irec=k + nNz*(irecord-1) |
403 |
endif |
404 |
if (filePrec .eq. precFloat32) then |
405 |
read(dUnit,rec=irec) r4seg |
406 |
#ifdef _BYTESWAPIO |
407 |
call MDS_BYTESWAPR4(sNy,r4seg) |
408 |
#endif |
409 |
if (arrType .eq. 'RS') then |
410 |
call MDS_SEG4toRS_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r4seg,arr) |
411 |
elseif (arrType .eq. 'RL') then |
412 |
call MDS_SEG4toRL_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r4seg,arr) |
413 |
else |
414 |
write(msgbuf,'(a)') |
415 |
& ' MDSREADFIELDYZ: illegal value for arrType' |
416 |
call print_error( msgbuf, mythid ) |
417 |
stop 'ABNORMAL END: S/R MDSREADFIELDYZ' |
418 |
endif |
419 |
elseif (filePrec .eq. precFloat64) then |
420 |
read(dUnit,rec=irec) r8seg |
421 |
#ifdef _BYTESWAPIO |
422 |
call MDS_BYTESWAPR8( sNy, r8seg ) |
423 |
#endif |
424 |
if (arrType .eq. 'RS') then |
425 |
call MDS_SEG8toRS_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r8seg,arr) |
426 |
elseif (arrType .eq. 'RL') then |
427 |
call MDS_SEG8toRL_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r8seg,arr) |
428 |
else |
429 |
write(msgbuf,'(a)') |
430 |
& ' MDSREADFIELDYZ: illegal value for arrType' |
431 |
call print_error( msgbuf, mythid ) |
432 |
stop 'ABNORMAL END: S/R MDSREADFIELDYZ' |
433 |
endif |
434 |
else |
435 |
write(msgbuf,'(a)') |
436 |
& ' MDSREADFIELDYZ: illegal value for filePrec' |
437 |
call print_error( msgbuf, mythid ) |
438 |
stop 'ABNORMAL END: S/R MDSREADFIELDYZ' |
439 |
endif |
440 |
C End of k loop |
441 |
enddo |
442 |
if (.NOT. globalFile) then |
443 |
close( dUnit ) |
444 |
fileIsOpen = .FALSE. |
445 |
endif |
446 |
endif |
447 |
C End of bi,bj loops |
448 |
enddo |
449 |
enddo |
450 |
|
451 |
C If global file was opened then close it |
452 |
if (fileIsOpen .AND. globalFile) then |
453 |
close( dUnit ) |
454 |
fileIsOpen = .FALSE. |
455 |
endif |
456 |
|
457 |
_END_MASTER( myThid ) |
458 |
|
459 |
C ------------------------------------------------------------------ |
460 |
return |
461 |
end |
462 |
C======================================================================= |
463 |
|
464 |
C======================================================================= |
465 |
SUBROUTINE MDSWRITEFIELDXZ_LOC( |
466 |
I fName, |
467 |
I filePrec, |
468 |
I globalFile, |
469 |
I arrType, |
470 |
I nNz, |
471 |
I arr, |
472 |
I irecord, |
473 |
I myIter, |
474 |
I myThid ) |
475 |
C |
476 |
C Arguments: |
477 |
C |
478 |
C fName string base name for file to written |
479 |
C filePrec integer number of bits per word in file (32 or 64) |
480 |
C globalFile logical selects between writing a global or tiled file |
481 |
C C arrType char(2) declaration of "arr": either "RS" or "RL" |
482 |
C nNz integer size of second dimension: Nr |
483 |
C arr RL array to write, arr(:,nNz,:,:) |
484 |
C irecord integer record number to read |
485 |
C myIter integer time step number |
486 |
C myThid integer thread identifier |
487 |
C |
488 |
C MDSWRITEFIELDXZ creates either a file of the form "fName.data" |
489 |
C if the logical flag "globalFile" is set true. Otherwise |
490 |
C it creates MDS tiled files of the form "fName.xxx.yyy.data". |
491 |
C The precision of the file is decsribed by filePrec, set either |
492 |
C to floatPrec32 or floatPrec64. The precision or declaration of |
493 |
C the array argument must be consistently described by the char*(2) |
494 |
C string arrType, either "RS" or "RL". |
495 |
C This routine writes vertical slices (X-Z) including overlap regions. |
496 |
C irecord is the record number to be read and must be >= 1. |
497 |
C NOTE: It is currently assumed that |
498 |
C the highest record number in the file was the last record written. |
499 |
C |
500 |
C Modified: 06/02/00 spk@ocean.mit.edu |
501 |
|
502 |
implicit none |
503 |
C Global variables / common blocks |
504 |
#include "SIZE.h" |
505 |
#include "EEPARAMS.h" |
506 |
#include "PARAMS.h" |
507 |
|
508 |
C Routine arguments |
509 |
character*(*) fName |
510 |
integer filePrec |
511 |
logical globalFile |
512 |
character*(2) arrType |
513 |
integer nNz |
514 |
_RL arr(*) |
515 |
integer irecord |
516 |
integer myIter |
517 |
integer myThid |
518 |
C Functions |
519 |
integer ILNBLNK |
520 |
integer MDS_RECLEN |
521 |
C Local variables |
522 |
character*(MAX_LEN_FNAM) dataFName |
523 |
integer iG,jG,irec,bi,bj,k,dUnit,IL |
524 |
Real*4 r4seg(sNx) |
525 |
Real*8 r8seg(sNx) |
526 |
integer length_of_rec |
527 |
logical fileIsOpen |
528 |
character*(max_len_mbuf) msgbuf |
529 |
C ------------------------------------------------------------------ |
530 |
|
531 |
C Only do I/O if I am the master thread |
532 |
_BEGIN_MASTER( myThid ) |
533 |
|
534 |
C Record number must be >= 1 |
535 |
if (irecord .LT. 1) then |
536 |
write(msgbuf,'(a,i9.8)') |
537 |
& ' MDSWRITEFIELDXZ: argument irecord = ',irecord |
538 |
call print_message( msgbuf, standardmessageunit, |
539 |
& SQUEEZE_RIGHT , mythid) |
540 |
write(msgbuf,'(a)') |
541 |
& ' MDSWRITEFIELDXZ: invalid value for irecord' |
542 |
call print_error( msgbuf, mythid ) |
543 |
stop 'ABNORMAL END: S/R MDSWRITEFIELDXZ' |
544 |
endif |
545 |
|
546 |
C Assume nothing |
547 |
fileIsOpen=.FALSE. |
548 |
IL=ILNBLNK( fName ) |
549 |
|
550 |
C Assign a free unit number as the I/O channel for this routine |
551 |
call MDSFINDUNIT( dUnit, mythid ) |
552 |
|
553 |
C If we are writing to a global file then we open it here |
554 |
if (globalFile) then |
555 |
write(dataFName,'(2a)') fName(1:IL),'.data' |
556 |
if (irecord .EQ. 1) then |
557 |
length_of_rec=MDS_RECLEN( filePrec, sNx, mythid ) |
558 |
open( dUnit, file=dataFName, status=_NEW_STATUS, |
559 |
& access='direct', recl=length_of_rec ) |
560 |
fileIsOpen=.TRUE. |
561 |
else |
562 |
length_of_rec=MDS_RECLEN( filePrec, sNx, mythid ) |
563 |
open( dUnit, file=dataFName, status='old', |
564 |
& access='direct', recl=length_of_rec ) |
565 |
fileIsOpen=.TRUE. |
566 |
endif |
567 |
endif |
568 |
|
569 |
C Loop over all tiles |
570 |
do bj=1,nSy |
571 |
do bi=1,nSx |
572 |
C If we are writing to a tiled MDS file then we open each one here |
573 |
if (.NOT. globalFile) then |
574 |
iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles |
575 |
jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles |
576 |
write(dataFName,'(2a,i3.3,a,i3.3,a)') |
577 |
& fName(1:IL),'.',iG,'.',jG,'.data' |
578 |
if (irecord .EQ. 1) then |
579 |
length_of_rec=MDS_RECLEN( filePrec, sNx, mythid ) |
580 |
open( dUnit, file=dataFName, status=_NEW_STATUS, |
581 |
& access='direct', recl=length_of_rec ) |
582 |
fileIsOpen=.TRUE. |
583 |
else |
584 |
length_of_rec=MDS_RECLEN( filePrec, sNx, mythid ) |
585 |
open( dUnit, file=dataFName, status='old', |
586 |
& access='direct', recl=length_of_rec ) |
587 |
fileIsOpen=.TRUE. |
588 |
endif |
589 |
endif |
590 |
if (fileIsOpen) then |
591 |
do k=1,nNz |
592 |
if (globalFile) then |
593 |
iG = myXGlobalLo-1 + (bi-1)*sNx |
594 |
jG = (myYGlobalLo-1)/sNy + (bj-1) |
595 |
irec=1 + INT(iG/sNx) + nSx*nPx*(k-1) |
596 |
& + nSx*nPx*nNz*(irecord-1) |
597 |
else |
598 |
iG = 0 |
599 |
jG = 0 |
600 |
irec=k + nNz*(irecord-1) |
601 |
endif |
602 |
if (filePrec .eq. precFloat32) then |
603 |
if (arrType .eq. 'RS') then |
604 |
call MDS_SEG4toRS_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r4seg,arr) |
605 |
elseif (arrType .eq. 'RL') then |
606 |
call MDS_SEG4toRL_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r4seg,arr) |
607 |
else |
608 |
write(msgbuf,'(a)') |
609 |
& ' MDSWRITEFIELDXZ: illegal value for arrType' |
610 |
call print_error( msgbuf, mythid ) |
611 |
stop 'ABNORMAL END: S/R MDSWRITEFIELDXZ' |
612 |
endif |
613 |
#ifdef _BYTESWAPIO |
614 |
call MDS_BYTESWAPR4(sNx,r4seg) |
615 |
#endif |
616 |
write(dUnit,rec=irec) r4seg |
617 |
elseif (filePrec .eq. precFloat64) then |
618 |
if (arrType .eq. 'RS') then |
619 |
call MDS_SEG8toRS_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r8seg,arr) |
620 |
elseif (arrType .eq. 'RL') then |
621 |
call MDS_SEG8toRL_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r8seg,arr) |
622 |
else |
623 |
write(msgbuf,'(a)') |
624 |
& ' MDSWRITEFIELDXZ: illegal value for arrType' |
625 |
call print_error( msgbuf, mythid ) |
626 |
stop 'ABNORMAL END: S/R MDSWRITEFIELDXZ' |
627 |
endif |
628 |
#ifdef _BYTESWAPIO |
629 |
call MDS_BYTESWAPR8( sNx, r8seg ) |
630 |
#endif |
631 |
write(dUnit,rec=irec) r8seg |
632 |
else |
633 |
write(msgbuf,'(a)') |
634 |
& ' MDSWRITEFIELDXZ: illegal value for filePrec' |
635 |
call print_error( msgbuf, mythid ) |
636 |
stop 'ABNORMAL END: S/R MDSWRITEFIELDXZ' |
637 |
endif |
638 |
C End of k loop |
639 |
enddo |
640 |
else |
641 |
write(msgbuf,'(a)') |
642 |
& ' MDSWRITEFIELDXZ: I should never get to this point' |
643 |
call print_error( msgbuf, mythid ) |
644 |
stop 'ABNORMAL END: S/R MDSWRITEFIELDXZ' |
645 |
endif |
646 |
C If we were writing to a tiled MDS file then we close it here |
647 |
if (fileIsOpen .AND. (.NOT. globalFile)) then |
648 |
close( dUnit ) |
649 |
fileIsOpen = .FALSE. |
650 |
endif |
651 |
C End of bi,bj loops |
652 |
enddo |
653 |
enddo |
654 |
|
655 |
C If global file was opened then close it |
656 |
if (fileIsOpen .AND. globalFile) then |
657 |
close( dUnit ) |
658 |
fileIsOpen = .FALSE. |
659 |
endif |
660 |
|
661 |
C We put a barrier here to ensure that all processes have finished |
662 |
C writing their data before we update the meta-file |
663 |
_BARRIER |
664 |
|
665 |
_END_MASTER( myThid ) |
666 |
|
667 |
C ------------------------------------------------------------------ |
668 |
return |
669 |
end |
670 |
C======================================================================= |
671 |
|
672 |
C======================================================================= |
673 |
SUBROUTINE MDSWRITEFIELDYZ_LOC( |
674 |
I fName, |
675 |
I filePrec, |
676 |
I globalFile, |
677 |
I arrType, |
678 |
I nNz, |
679 |
I arr, |
680 |
I irecord, |
681 |
I myIter, |
682 |
I myThid ) |
683 |
C |
684 |
C Arguments: |
685 |
C |
686 |
C fName string base name for file to written |
687 |
C filePrec integer number of bits per word in file (32 or 64) |
688 |
C globalFile logical selects between writing a global or tiled file |
689 |
C C arrType char(2) declaration of "arr": either "RS" or "RL" |
690 |
C nNz integer size of second dimension: Nr |
691 |
C arr RL array to write, arr(:,nNz,:,:) |
692 |
C irecord integer record number to read |
693 |
C myIter integer time step number |
694 |
C myThid integer thread identifier |
695 |
C |
696 |
C MDSWRITEFIELDYZ creates either a file of the form "fName.data" |
697 |
C if the logical flag "globalFile" is set true. Otherwise |
698 |
C it creates MDS tiled files of the form "fName.xxx.yyy.data". |
699 |
C The precision of the file is decsribed by filePrec, set either |
700 |
C to floatPrec32 or floatPrec64. The precision or declaration of |
701 |
C the array argument must be consistently described by the char*(2) |
702 |
C string arrType, either "RS" or "RL". |
703 |
C This routine writes vertical slices (Y-Z) including overlap regions. |
704 |
C irecord is the record number to be read and must be >= 1. |
705 |
C NOTE: It is currently assumed that |
706 |
C the highest record number in the file was the last record written. |
707 |
C |
708 |
C Modified: 06/02/00 spk@ocean.mit.edu |
709 |
|
710 |
|
711 |
implicit none |
712 |
C Global variables / common blocks |
713 |
#include "SIZE.h" |
714 |
#include "EEPARAMS.h" |
715 |
#include "PARAMS.h" |
716 |
|
717 |
C Routine arguments |
718 |
character*(*) fName |
719 |
integer filePrec |
720 |
logical globalFile |
721 |
character*(2) arrType |
722 |
integer nNz |
723 |
_RL arr(*) |
724 |
integer irecord |
725 |
integer myIter |
726 |
integer myThid |
727 |
C Functions |
728 |
integer ILNBLNK |
729 |
integer MDS_RECLEN |
730 |
C Local variables |
731 |
character*(MAX_LEN_FNAM) dataFName |
732 |
integer iG,jG,irec,bi,bj,k,dUnit,IL |
733 |
Real*4 r4seg(sNy) |
734 |
Real*8 r8seg(sNy) |
735 |
integer length_of_rec |
736 |
logical fileIsOpen |
737 |
character*(max_len_mbuf) msgbuf |
738 |
C ------------------------------------------------------------------ |
739 |
|
740 |
C Only do I/O if I am the master thread |
741 |
_BEGIN_MASTER( myThid ) |
742 |
|
743 |
C Record number must be >= 1 |
744 |
if (irecord .LT. 1) then |
745 |
write(msgbuf,'(a,i9.8)') |
746 |
& ' MDSWRITEFIELDYZ: argument irecord = ',irecord |
747 |
call print_message( msgbuf, standardmessageunit, |
748 |
& SQUEEZE_RIGHT , mythid) |
749 |
write(msgbuf,'(a)') |
750 |
& ' MDSWRITEFIELDYZ: invalid value for irecord' |
751 |
call print_error( msgbuf, mythid ) |
752 |
stop 'ABNORMAL END: S/R MDSWRITEFIELDYZ' |
753 |
endif |
754 |
|
755 |
C Assume nothing |
756 |
fileIsOpen=.FALSE. |
757 |
IL=ILNBLNK( fName ) |
758 |
|
759 |
C Assign a free unit number as the I/O channel for this routine |
760 |
call MDSFINDUNIT( dUnit, mythid ) |
761 |
|
762 |
C If we are writing to a global file then we open it here |
763 |
if (globalFile) then |
764 |
write(dataFName,'(2a)') fName(1:IL),'.data' |
765 |
if (irecord .EQ. 1) then |
766 |
length_of_rec=MDS_RECLEN( filePrec, sNy, mythid ) |
767 |
open( dUnit, file=dataFName, status=_NEW_STATUS, |
768 |
& access='direct', recl=length_of_rec ) |
769 |
fileIsOpen=.TRUE. |
770 |
else |
771 |
length_of_rec=MDS_RECLEN( filePrec, sNy, mythid ) |
772 |
open( dUnit, file=dataFName, status='old', |
773 |
& access='direct', recl=length_of_rec ) |
774 |
fileIsOpen=.TRUE. |
775 |
endif |
776 |
endif |
777 |
|
778 |
C Loop over all tiles |
779 |
do bj=1,nSy |
780 |
do bi=1,nSx |
781 |
C If we are writing to a tiled MDS file then we open each one here |
782 |
if (.NOT. globalFile) then |
783 |
iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles |
784 |
jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles |
785 |
write(dataFName,'(2a,i3.3,a,i3.3,a)') |
786 |
& fName(1:IL),'.',iG,'.',jG,'.data' |
787 |
if (irecord .EQ. 1) then |
788 |
length_of_rec=MDS_RECLEN( filePrec, sNy, mythid ) |
789 |
open( dUnit, file=dataFName, status=_NEW_STATUS, |
790 |
& access='direct', recl=length_of_rec ) |
791 |
fileIsOpen=.TRUE. |
792 |
else |
793 |
length_of_rec=MDS_RECLEN( filePrec, sNy, mythid ) |
794 |
open( dUnit, file=dataFName, status='old', |
795 |
& access='direct', recl=length_of_rec ) |
796 |
fileIsOpen=.TRUE. |
797 |
endif |
798 |
endif |
799 |
if (fileIsOpen) then |
800 |
do k=1,nNz |
801 |
if (globalFile) then |
802 |
iG = (myXGlobalLo-1)/sNx + (bi-1) |
803 |
jG = myYGlobalLo-1 + (bj-1)*sNy |
804 |
irec=1 + INT(jG/sNy) + nSy*nPy*(k-1) |
805 |
& + nSy*nPy*nNz*(irecord-1) |
806 |
else |
807 |
iG = 0 |
808 |
jG = 0 |
809 |
irec=k + nNz*(irecord-1) |
810 |
endif |
811 |
if (filePrec .eq. precFloat32) then |
812 |
if (arrType .eq. 'RS') then |
813 |
call MDS_SEG4toRS_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r4seg,arr) |
814 |
elseif (arrType .eq. 'RL') then |
815 |
call MDS_SEG4toRL_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r4seg,arr) |
816 |
else |
817 |
write(msgbuf,'(a)') |
818 |
& ' MDSWRITEFIELDYZ: illegal value for arrType' |
819 |
call print_error( msgbuf, mythid ) |
820 |
stop 'ABNORMAL END: S/R MDSWRITEFIELDYZ' |
821 |
endif |
822 |
#ifdef _BYTESWAPIO |
823 |
call MDS_BYTESWAPR4(sNy,r4seg) |
824 |
#endif |
825 |
write(dUnit,rec=irec) r4seg |
826 |
elseif (filePrec .eq. precFloat64) then |
827 |
if (arrType .eq. 'RS') then |
828 |
call MDS_SEG8toRS_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r8seg,arr) |
829 |
elseif (arrType .eq. 'RL') then |
830 |
call MDS_SEG8toRL_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r8seg,arr) |
831 |
else |
832 |
write(msgbuf,'(a)') |
833 |
& ' MDSWRITEFIELDYZ: illegal value for arrType' |
834 |
call print_error( msgbuf, mythid ) |
835 |
stop 'ABNORMAL END: S/R MDSWRITEFIELDYZ' |
836 |
endif |
837 |
#ifdef _BYTESWAPIO |
838 |
call MDS_BYTESWAPR8( sNy, r8seg ) |
839 |
#endif |
840 |
write(dUnit,rec=irec) r8seg |
841 |
else |
842 |
write(msgbuf,'(a)') |
843 |
& ' MDSWRITEFIELDYZ: illegal value for filePrec' |
844 |
call print_error( msgbuf, mythid ) |
845 |
stop 'ABNORMAL END: S/R MDSWRITEFIELDYZ' |
846 |
endif |
847 |
C End of k loop |
848 |
enddo |
849 |
else |
850 |
write(msgbuf,'(a)') |
851 |
& ' MDSWRITEFIELDYZ: I should never get to this point' |
852 |
call print_error( msgbuf, mythid ) |
853 |
stop 'ABNORMAL END: S/R MDSWRITEFIELDYZ' |
854 |
endif |
855 |
C If we were writing to a tiled MDS file then we close it here |
856 |
if (fileIsOpen .AND. (.NOT. globalFile)) then |
857 |
close( dUnit ) |
858 |
fileIsOpen = .FALSE. |
859 |
endif |
860 |
C End of bi,bj loops |
861 |
enddo |
862 |
enddo |
863 |
|
864 |
C If global file was opened then close it |
865 |
if (fileIsOpen .AND. globalFile) then |
866 |
close( dUnit ) |
867 |
fileIsOpen = .FALSE. |
868 |
endif |
869 |
|
870 |
C We put a barrier here to ensure that all processes have finished |
871 |
C writing their data before we update the meta-file |
872 |
_BARRIER |
873 |
|
874 |
_END_MASTER( myThid ) |
875 |
|
876 |
C ------------------------------------------------------------------ |
877 |
return |
878 |
end |
879 |
C======================================================================= |
880 |
|