/[MITgcm]/MITgcm/pkg/mdsio/mdsio_gl_slice.F
ViewVC logotype

Contents of /MITgcm/pkg/mdsio/mdsio_gl_slice.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.3 - (show annotations) (download)
Tue Jul 8 15:00:26 2003 UTC (20 years, 11 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint51f_post, checkpoint51d_post, checkpoint51j_post, checkpoint51h_pre, branchpoint-genmake2, checkpoint51c_post, checkpoint51i_pre, checkpoint51e_post, checkpoint51f_pre, checkpoint51g_post
Branch point for: branch-genmake2
Changes since 1.2: +8 -4 lines
o introducing integer flag debugLevel
o introducing pathname variable mdsioLocalDir for mdsio

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

  ViewVC Help
Powered by ViewVC 1.1.22