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