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

Diff of /MITgcm/pkg/mdsio/mdsio_write_field.F

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

revision 1.6 by jmc, Wed May 6 02:42:49 2009 UTC revision 1.16 by jmc, Tue Sep 1 19:08:27 2009 UTC
# Line 13  C !INTERFACE: Line 13  C !INTERFACE:
13       I   useCurrentDir,       I   useCurrentDir,
14       I   arrType,       I   arrType,
15       I   kSize,kLo,kHi,       I   kSize,kLo,kHi,
16       I   arr,       I   fldRL, fldRS,
17       I   jrecord,       I   jrecord,
18       I   myIter,       I   myIter,
19       I   myThid )       I   myThid )
# Line 26  C filePrec  (integer) :: number of bits Line 26  C filePrec  (integer) :: number of bits
26  C globalFile (logical):: selects between writing a global or tiled file  C globalFile (logical):: selects between writing a global or tiled file
27  C useCurrentDir(logic):: always write to the current directory (even if  C useCurrentDir(logic):: always write to the current directory (even if
28  C                        "mdsioLocalDir" is set)  C                        "mdsioLocalDir" is set)
29  C arrType   (char(2)) :: declaration of "arr": either "RS" or "RL"  C arrType   (char(2)) :: which array (fldRL/RS) to write, either "RL" or "RS"
30  C kSize     (integer) :: size of third dimension: normally either 1 or Nr  C kSize     (integer) :: size of third dimension: normally either 1 or Nr
31  C kLo       (integer) :: 1rst vertical level (of array "arr") to write  C kLo       (integer) :: 1rst vertical level (of array fldRL/RS) to write
32  C kHi       (integer) :: last vertical level (of array "arr") to write  C kHi       (integer) :: last vertical level (of array fldRL/RS) to write
33  C arr       ( RS/RL ) :: array to write, arr(:,:,kSize,:,:)  C fldRL       ( RL )  :: array to write if arrType="RL", fldRL(:,:,kSize,:,:)
34    C fldRS       ( RS )  :: array to write if arrType="RS", fldRS(:,:,kSize,:,:)
35  C irecord   (integer) :: record number to write  C irecord   (integer) :: record number to write
36  C myIter    (integer) :: time step number  C myIter    (integer) :: time step number
37  C myThid    (integer) :: thread identifier  C myThid    (integer) :: thread identifier
# Line 43  C Currently, the meta-files are not read Line 44  C Currently, the meta-files are not read
44  C  to parse files in fortran. We should read meta information before  C  to parse files in fortran. We should read meta information before
45  C  adding records to an existing multi-record file.  C  adding records to an existing multi-record file.
46  C The precision of the file is decsribed by filePrec, set either  C The precision of the file is decsribed by filePrec, set either
47  C  to floatPrec32 or floatPrec64. The precision or declaration of  C  to floatPrec32 or floatPrec64. The char*(2) string arrType, either
48  C  the array argument must be consistently described by the char*(2)  C  "RL" or "RS", selects which array is written, either fldRL or fldRS.
 C  string arrType, either "RS" or "RL".  
49  C (kSize,kLo,kHi) allows for both 2-D and 3-D arrays to be handled, with  C (kSize,kLo,kHi) allows for both 2-D and 3-D arrays to be handled, with
50  C  the option to only write a sub-set of consecutive vertical levels (from  C  the option to only write a sub-set of consecutive vertical levels (from
51  C  kLo to kHi); (kSize,kLo,kHi)=(1,1,1) implies a 2-D model field and  C  kLo to kHi); (kSize,kLo,kHi)=(1,1,1) implies a 2-D model field and
# Line 71  C Global variables / common blocks Line 71  C Global variables / common blocks
71  #include "EEPARAMS.h"  #include "EEPARAMS.h"
72  #include "PARAMS.h"  #include "PARAMS.h"
73  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
74  #include "W2_EXCH2_TOPOLOGY.h"  # include "W2_EXCH2_SIZE.h"
75  #include "W2_EXCH2_PARAMS.h"  # include "W2_EXCH2_TOPOLOGY.h"
76    # include "W2_EXCH2_PARAMS.h"
77  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
78  #include "MDSIO_SCPU.h"  #include "EEBUFF_SCPU.h"
79    #ifdef ALLOW_FIZHI
80    # include "fizhi_SIZE.h"
81    #endif /* ALLOW_FIZHI */
82    #include "MDSIO_BUFF_3D.h"
83    
84  C !INPUT PARAMETERS:  C !INPUT PARAMETERS:
85        CHARACTER*(*) fName        CHARACTER*(*) fName
# Line 83  C !INPUT PARAMETERS: Line 88  C !INPUT PARAMETERS:
88        LOGICAL useCurrentDir        LOGICAL useCurrentDir
89        CHARACTER*(2) arrType        CHARACTER*(2) arrType
90        INTEGER kSize, kLo, kHi        INTEGER kSize, kLo, kHi
91  cph(        _RL fldRL(*)
92  cph      Real arr(*)        _RS fldRS(*)
       _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,kSize,nSx,nSy)  
 cph)  
93        INTEGER jrecord        INTEGER jrecord
94        INTEGER myIter        INTEGER myIter
95        INTEGER myThid        INTEGER myThid
# Line 101  C !FUNCTIONS Line 104  C !FUNCTIONS
104        EXTERNAL MASTER_CPU_IO        EXTERNAL MASTER_CPU_IO
105    
106  C !LOCAL VARIABLES:  C !LOCAL VARIABLES:
107    C     bBij  :: base shift in Buffer index for tile bi,bj
108        CHARACTER*(MAX_LEN_FNAM) dataFName,metaFName,pfName        CHARACTER*(MAX_LEN_FNAM) dataFName,metaFName,pfName
109        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
110        LOGICAL fileIsOpen        LOGICAL fileIsOpen
111        LOGICAL iAmDoingIO        LOGICAL iAmDoingIO
112        LOGICAL writeMetaF        LOGICAL writeMetaF
113          LOGICAL useExch2ioLayOut
114        LOGICAL zeroBuff        LOGICAL zeroBuff
115        INTEGER xSize, ySize        INTEGER xSize, ySize
116        INTEGER irecord        INTEGER irecord
117        INTEGER iG,jG,bi,bj,i,j,k,nNz        INTEGER iG,jG,bi,bj
118          INTEGER i1,i2,i,j,k,nNz
119        INTEGER irec,dUnit,IL,pIL        INTEGER irec,dUnit,IL,pIL
120        INTEGER dimList(3,3), nDims, map2gl(2)        INTEGER dimList(3,3), nDims, map2gl(2)
       INTEGER iGjLoc, jGjLoc  
121        INTEGER length_of_rec        INTEGER length_of_rec
122        Real*4 r4seg(sNx)        INTEGER bBij
123        Real*8 r8seg(sNx)        INTEGER tNx, tNy, global_nTx
124          INTEGER tBx, tBy, iGjLoc, jGjLoc
125  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
126  c     INTEGER tGy,tGx,tNy,tNx,tN        INTEGER tN
       INTEGER tGy,tGx,    tNx,tN  
       INTEGER global_nTx  
127  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
128        INTEGER tNy        _RL dummyRL(1)
129          CHARACTER*8 blank8c
130    
131          DATA dummyRL(1) / 0. _d 0 /
132          DATA blank8c / '        ' /
133    
134  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
135  C Set dimensions:  C Set dimensions:
136        xSize = Nx        xSize = Nx
137        ySize = Ny        ySize = Ny
138  #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)        useExch2ioLayOut = .FALSE.
139        xSize = exch2_global_Nx  #ifdef ALLOW_EXCH2
140        ySize = exch2_global_Ny        IF ( W2_useE2ioLayOut ) THEN
141  #endif          xSize = exch2_global_Nx
142            ySize = exch2_global_Ny
143            useExch2ioLayOut = .TRUE.
144          ENDIF
145    #endif /* ALLOW_EXCH2 */
146    
147  C-    default:  C-    default:
148        iGjLoc = 0        iGjLoc = 0
# Line 147  C Assume nothing Line 159  C Assume nothing
159  C Only do I/O if I am the master thread (and mpi process 0 IF useSingleCpuIO):  C Only do I/O if I am the master thread (and mpi process 0 IF useSingleCpuIO):
160        iAmDoingIO = MASTER_CPU_IO(myThid)        iAmDoingIO = MASTER_CPU_IO(myThid)
161    
 C Only do I/O if I am the master thread  
       IF ( iAmDoingIO ) THEN  
   
162  C Record number must be >= 1  C Record number must be >= 1
163          IF (irecord .LT. 1) THEN        IF (irecord .LT. 1) THEN
164           WRITE(msgBuf,'(A,I9.8)')          WRITE(msgBuf,'(3A,I10)')
165       &     ' MDS_WRITE_FIELD: argument irecord = ',irecord       &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
166           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
167       &                       SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid )
168            WRITE(msgBuf,'(A,I9.8)')
169         &    ' MDS_WRITE_FIELD: argument irecord = ',irecord
170            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
171         &                      SQUEEZE_RIGHT , myThid )
172           WRITE(msgBuf,'(A)')           WRITE(msgBuf,'(A)')
173       &     ' MDS_WRITE_FIELD: invalid value for irecord'       &    ' MDS_WRITE_FIELD: invalid value for irecord'
174           CALL PRINT_ERROR( msgBuf, myThid )          CALL PRINT_ERROR( msgBuf, myThid )
175           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'          CALL ALL_PROC_DIE( myThid )
176          ENDIF          STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
177          ENDIF
178  C check for valid sub-set of levels:  C check for valid sub-set of levels:
179          IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN        IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN
180           WRITE(msgBuf,'(3(A,I6))')          WRITE(msgBuf,'(3A,I10)')
181       &     ' MDS_WRITE_FIELD: arguments kSize=', kSize,       &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
182       &     ' , kLo=', kLo, ' , kHi=', kHi          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
183           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,       &                      SQUEEZE_RIGHT , myThid )
184       &                       SQUEEZE_RIGHT , myThid)          WRITE(msgBuf,'(3(A,I6))')
185           WRITE(msgBuf,'(A)')       &    ' MDS_WRITE_FIELD: arguments kSize=', kSize,
186       &     ' MDS_WRITE_FIELD: invalid sub-set of levels'       &    ' , kLo=', kLo, ' , kHi=', kHi
187           CALL PRINT_ERROR( msgBuf, myThid )          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
188           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'       &                      SQUEEZE_RIGHT , myThid )
189          ENDIF          WRITE(msgBuf,'(A)')
190         &    ' MDS_WRITE_FIELD: invalid sub-set of levels'
191            CALL PRINT_ERROR( msgBuf, myThid )
192            CALL ALL_PROC_DIE( myThid )
193            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
194          ENDIF
195    C check for 3-D Buffer size:
196          IF ( .NOT.useSingleCpuIO .AND. nNz.GT.size3dBuf ) THEN
197            WRITE(msgBuf,'(3A,I10)')
198         &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
199            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
200         &                      SQUEEZE_RIGHT , myThid )
201            WRITE(msgBuf,'(3(A,I6))')
202         &    ' MDS_WRITE_FIELD: Nb Lev to write =', nNz,
203         &    ' >', size3dBuf, ' = buffer 3rd Dim'
204            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
205         &                      SQUEEZE_RIGHT , myThid )
206            WRITE(msgBuf,'(A)')
207         &    ' MDS_WRITE_FIELD: buffer 3rd Dim. too small'
208            CALL PRINT_ERROR( msgBuf, myThid )
209            WRITE(msgBuf,'(A)')
210         &    ' increase "size3dBuf" in "MDSIO_BUFF_3D.h" and recompile'
211            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
212         &                      SQUEEZE_RIGHT , myThid)
213            CALL ALL_PROC_DIE( myThid )
214            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
215          ENDIF
216    
217    C Only do I/O if I am the master thread
218          IF ( iAmDoingIO ) THEN
219    
220  C Assign special directory  C Assign special directory
221          IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN          IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN
# Line 195  C globalFile is too slow, then try using Line 238  C globalFile is too slow, then try using
238  C Master thread of process 0, only, opens a global file  C Master thread of process 0, only, opens a global file
239         IF ( iAmDoingIO ) THEN         IF ( iAmDoingIO ) THEN
240           WRITE(dataFName,'(2a)') fName(1:IL),'.data'           WRITE(dataFName,'(2a)') fName(1:IL),'.data'
241           length_of_rec=MDS_RECLEN(filePrec,xSize*ySize,myThid)           length_of_rec = MDS_RECLEN( filePrec, xSize*ySize, myThid )
242           IF (irecord .EQ. 1) THEN           IF (irecord .EQ. 1) THEN
243            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
244       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
# Line 205  C Master thread of process 0, only, open Line 248  C Master thread of process 0, only, open
248           ENDIF           ENDIF
249         ENDIF         ENDIF
250    
251  C Gather array and WRITE it to file, one vertical level at a time  C Gather array and write it to file, one vertical level at a time
252         DO k=kLo,kHi         DO k=kLo,kHi
253  C-      copy from arr(level=k) to 2-D "local":          zeroBuff = k.EQ.kLo
254          IF ( arrType.EQ.'RS' ) THEN  C-      copy from fldRL/RS(level=k) to 2-D "local":
255            CALL MDS_PASStoRS(sharedLocalBuf,arr,k,kSize,.FALSE.,myThid)          IF ( filePrec.EQ.precFloat32 ) THEN
256          ELSEIF ( arrType.EQ.'RL' ) THEN            IF ( arrType.EQ.'RS' ) THEN
257            CALL MDS_PASStoRL(sharedLocalBuf,arr,k,kSize,.FALSE.,myThid)              CALL MDS_PASS_R4toRS( sharedLocBuf_r4, fldRS,
258         I                       1, k, kSize, 0, 0, .FALSE., myThid )
259              ELSEIF ( arrType.EQ.'RL' ) THEN
260                CALL MDS_PASS_R4toRL( sharedLocBuf_r4, fldRL,
261         I                       1, k, kSize, 0, 0, .FALSE., myThid )
262              ELSE
263                WRITE(msgBuf,'(2A)')
264         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
265                CALL PRINT_ERROR( msgBuf, myThid )
266                CALL ALL_PROC_DIE( myThid )
267                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
268              ENDIF
269    C Wait for all threads to finish filling shared buffer
270              CALL BAR2( myThid )
271              CALL GATHER_2D_R4(
272         O                       xy_buffer_r4,
273         I                       sharedLocBuf_r4,
274         I                       xSize, ySize,
275         I                       useExch2ioLayOut, zeroBuff, myThid )
276            ELSEIF ( filePrec.EQ.precFloat64 ) THEN
277              IF ( arrType.EQ.'RS' ) THEN
278                CALL MDS_PASS_R8toRS( sharedLocBuf_r8, fldRS,
279         I                       1, k, kSize, 0, 0, .FALSE., myThid )
280    
281              ELSEIF ( arrType.EQ.'RL' ) THEN
282                CALL MDS_PASS_R8toRL( sharedLocBuf_r8, fldRL,
283         I                       1, k, kSize, 0, 0, .FALSE., myThid )
284              ELSE
285                WRITE(msgBuf,'(2A)')
286         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
287                CALL PRINT_ERROR( msgBuf, myThid )
288                CALL ALL_PROC_DIE( myThid )
289                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
290              ENDIF
291    C Wait for all threads to finish filling shared buffer
292              CALL BAR2( myThid )
293              CALL GATHER_2D_R8(
294         O                       xy_buffer_r8,
295         I                       sharedLocBuf_r8,
296         I                       xSize, ySize,
297         I                       useExch2ioLayOut, zeroBuff, myThid )
298          ELSE          ELSE
299            WRITE(msgBuf,'(A)')            WRITE(msgBuf,'(A,I6)')
300       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
301            CALL PRINT_ERROR( msgBuf, myThid )            CALL PRINT_ERROR( msgBuf, myThid )
302              CALL ALL_PROC_DIE( myThid )
303            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
304          ENDIF          ENDIF
305          CALL GATHER_2D( globalBuf, sharedLocalBuf, myThid )  C Make other threads wait for "gather" completion so that after this,
306    C  shared buffer can again be modified by any thread
307            CALL BAR2( myThid )
308    
309          IF ( iAmDoingIO ) THEN          IF ( iAmDoingIO ) THEN
310  C Map  global model (real*8) array to the appropriate global io-buffer            irec = 1 + k-kLo + (irecord-1)*nNz
311            zeroBuff = k.EQ.kLo            IF ( filePrec.EQ.precFloat32 ) THEN
           CALL MDS_MAP_GLOBAL(  
      U                 xy_buffer_r4, xy_buffer_r8,  
      U                 globalBuf,  
      I                 xSize, ySize, filePrec,  
      I                 .FALSE., zeroBuff )  
   
           irec=k+1-kLo+nNz*(irecord-1)  
           IF (filePrec .EQ. precFloat32) THEN  
312  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
313             CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )             CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )
314  #endif  #endif
315             WRITE(dUnit,rec=irec) ( xy_buffer_r4(i),i=1,xSize*ySize )             WRITE(dUnit,rec=irec) ( xy_buffer_r4(i),i=1,xSize*ySize )
316            ELSEIF (filePrec .EQ. precFloat64) THEN            ELSE
317  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
318             CALL MDS_BYTESWAPR8( xSize*ySize, xy_buffer_r8 )             CALL MDS_BYTESWAPR8( xSize*ySize, xy_buffer_r8 )
319  #endif  #endif
320             WRITE(dUnit,rec=irec) ( xy_buffer_r8(i),i=1,xSize*ySize )             WRITE(dUnit,rec=irec) ( xy_buffer_r8(i),i=1,xSize*ySize )
           ELSE  
            WRITE(msgBuf,'(A)')  
      &       ' MDS_WRITE_FIELD: illegal value for filePrec'  
            CALL PRINT_ERROR( msgBuf, myThid )  
            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'  
321            ENDIF            ENDIF
322  C-      end if iAmDoingIO  C-      end if iAmDoingIO
323          ENDIF          ENDIF
# Line 260  C---+----1----+----2----+----3----+----4 Line 333  C---+----1----+----2----+----3----+----4
333  C---  else .NOT.useSingleCpuIO  C---  else .NOT.useSingleCpuIO
334        ELSE        ELSE
335    
336    C---    Copy from fldRL/RS to 3-D buffer (multi-threads):
337            IF ( filePrec.EQ.precFloat32 ) THEN
338              IF ( arrType.EQ.'RS' ) THEN
339                CALL MDS_PASS_R4toRS( shared3dBuf_r4, fldRS,
340         I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
341              ELSEIF ( arrType.EQ.'RL' ) THEN
342                CALL MDS_PASS_R4toRL( shared3dBuf_r4, fldRL,
343         I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
344              ELSE
345                WRITE(msgBuf,'(2A)')
346         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
347                CALL PRINT_ERROR( msgBuf, myThid )
348                CALL ALL_PROC_DIE( myThid )
349                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
350              ENDIF
351            ELSEIF ( filePrec.EQ.precFloat64 ) THEN
352              IF ( arrType.EQ.'RS' ) THEN
353                CALL MDS_PASS_R8toRS( shared3dBuf_r8, fldRS,
354         I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
355              ELSEIF ( arrType.EQ.'RL' ) THEN
356                CALL MDS_PASS_R8toRL( shared3dBuf_r8, fldRL,
357         I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
358              ELSE
359                WRITE(msgBuf,'(2A)')
360         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
361                CALL PRINT_ERROR( msgBuf, myThid )
362                CALL ALL_PROC_DIE( myThid )
363                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
364              ENDIF
365            ELSE
366              WRITE(msgBuf,'(A,I6)')
367         &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
368              CALL PRINT_ERROR( msgBuf, myThid )
369              CALL ALL_PROC_DIE( myThid )
370              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
371            ENDIF
372    
373    C Wait for all threads to finish filling shared buffer
374           CALL BAR2( myThid )
375    
376  C Only do I/O if I am the master thread  C Only do I/O if I am the master thread
377         IF ( iAmDoingIO ) THEN         IF ( iAmDoingIO ) THEN
378    
379    #ifdef _BYTESWAPIO
380            IF ( filePrec.EQ.precFloat32 ) THEN
381              CALL MDS_BYTESWAPR4( sNx*sNy*nNz*nSx*nSy, shared3dBuf_r4 )
382            ELSE
383              CALL MDS_BYTESWAPR8( sNx*sNy*nNz*nSx*nSy, shared3dBuf_r8 )
384            ENDIF
385    #endif
386    
387  C If we are writing to a global file then we open it here  C If we are writing to a global file then we open it here
388          IF (globalFile) THEN          IF (globalFile) THEN
389           WRITE(dataFName,'(2a)') fName(1:IL),'.data'            WRITE(dataFName,'(2a)') fName(1:IL),'.data'
390           IF (irecord .EQ. 1) THEN            length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
391            length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )            IF (irecord .EQ. 1) THEN
392            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,             OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
393       &            access='direct', recl=length_of_rec )       &             access='direct', recl=length_of_rec )
394            fileIsOpen=.TRUE.            ELSE
395           ELSE             OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
396            length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )       &             access='direct', recl=length_of_rec )
397            OPEN( dUnit, file=dataFName, status=_OLD_STATUS,            ENDIF
      &            access='direct', recl=length_of_rec )  
398            fileIsOpen=.TRUE.            fileIsOpen=.TRUE.
          ENDIF  
399          ENDIF          ENDIF
400    
401  C Loop over all tiles  C Loop over all tiles
402          DO bj=1,nSy          DO bj=1,nSy
403           DO bi=1,nSx           DO bi=1,nSx
404              bBij = sNx*sNy*nNz*( bi-1 + (bj-1)*nSx )
405    
406              tNx = sNx
407              tNy = sNy
408              global_nTx = xSize/sNx
409              tBx = myXGlobalLo-1 + (bi-1)*sNx
410              tBy = myYGlobalLo-1 + (bj-1)*sNy
411    #ifdef ALLOW_EXCH2
412              IF ( useExch2ioLayOut ) THEN
413                tN = W2_myTileList(bi,bj)
414    c           tNx = exch2_tNx(tN)
415    c           tNy = exch2_tNy(tN)
416    c           global_nTx = exch2_global_Nx/tNx
417                tBx = exch2_txGlobalo(tN) - 1
418                tBy = exch2_tyGlobalo(tN) - 1
419                IF   ( exch2_mydNx(tN) .GT. xSize ) THEN
420    C-          face x-size larger than glob-size : fold it
421                  iGjLoc = 0
422                  jGjLoc = exch2_mydNx(tN) / xSize
423                ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
424    C-          tile y-size larger than glob-size : make a long line
425                  iGjLoc = exch2_mydNx(tN)
426                  jGjLoc = 0
427                ELSE
428    C-          default (face fit into global-IO-array)
429                  iGjLoc = 0
430                  jGjLoc = 1
431                ENDIF
432              ENDIF
433    #endif /* ALLOW_EXCH2 */
434    
435              IF (globalFile) THEN
436    C--- Case of 1 Global file:
437    
438               DO k=kLo,kHi
439                DO j=1,tNy
440                 irec = 1 + ( tBx + (j-1)*iGjLoc )/tNx
441         &                + ( tBy + (j-1)*jGjLoc )*global_nTx
442         &            +( k-kLo + (irecord-1)*nNz )*global_nTx*ySize
443                 i1 = bBij + 1 + (j-1)*sNx + (k-kLo)*sNx*sNy
444                 i2 = bBij +         j*sNx + (k-kLo)*sNx*sNy
445                 IF ( filePrec.EQ.precFloat32 ) THEN
446                  WRITE(dUnit,rec=irec) (shared3dBuf_r4(i),i=i1,i2)
447                 ELSE
448                  WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
449                 ENDIF
450    C End of j,k loops
451                ENDDO
452               ENDDO
453    
454              ELSE
455    C--- Case of 1 file per tile (globalFile=F):
456    
457  C If we are writing to a tiled MDS file then we open each one here  C If we are writing to a tiled MDS file then we open each one here
458            IF (.NOT. globalFile) THEN             iG=bi+(myXGlobalLo-1)/sNx
459             iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles             jG=bj+(myYGlobalLo-1)/sNy
            jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles  
460             WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')             WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
461       &              pfName(1:pIL),'.',iG,'.',jG,'.data'       &            pfName(1:pIL),'.',iG,'.',jG,'.data'
462               length_of_rec = MDS_RECLEN( filePrec, sNx*sNy*nNz, myThid )
463             IF (irecord .EQ. 1) THEN             IF (irecord .EQ. 1) THEN
             length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )  
464              OPEN( dUnit, file=dataFName, status=_NEW_STATUS,              OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
465       &            access='direct', recl=length_of_rec )       &            access='direct', recl=length_of_rec )
             fileIsOpen=.TRUE.  
466             ELSE             ELSE
             length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )  
467              OPEN( dUnit, file=dataFName, status=_OLD_STATUS,              OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
468       &            access='direct', recl=length_of_rec )       &            access='direct', recl=length_of_rec )
             fileIsOpen=.TRUE.  
469             ENDIF             ENDIF
470            ENDIF             fileIsOpen=.TRUE.
471    
472            IF (fileIsOpen) THEN             irec = irecord
473             tNy = sNy             i1 = bBij + 1
474  #ifdef ALLOW_EXCH2             i2 = bBij + sNx*sNy*nNz
475             tN = W2_myTileList(bi)             IF ( filePrec.EQ.precFloat32 ) THEN
476             tGy = exch2_tyGlobalo(tN)               WRITE(dUnit,rec=irec) (shared3dBuf_r4(i),i=i1,i2)
            tGx = exch2_txGlobalo(tN)  
            tNy = exch2_tNy(tN)  
            tNx = exch2_tNx(tN)  
            IF   ( exch2_mydNx(tN) .GT. xSize ) THEN  
 C-         face x-size larger than glob-size : fold it  
              iGjLoc = 0  
              jGjLoc = exch2_mydNx(tN) / xSize  
            ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN  
 C-         tile y-size larger than glob-size : make a long line  
              iGjLoc = exch2_mydNx(tN)  
              jGjLoc = 0  
477             ELSE             ELSE
478  C-         default (face fit into global-IO-array)               WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
              iGjLoc = 0  
              jGjLoc = 1  
479             ENDIF             ENDIF
480             global_nTx = exch2_global_Nx/tNx  
481  #endif /* ALLOW_EXCH2 */  C here We close the tiled MDS file
482             DO k=1,nNz             IF ( fileIsOpen ) THEN
483              DO j=1,tNy               CLOSE( dUnit )
484               IF (globalFile) THEN               fileIsOpen = .FALSE.
485  #ifdef ALLOW_EXCH2             ENDIF
486                irec = 1 + ( tGx-1 + (j-1)*iGjLoc )/tNx  
487       &                 + ( tGy-1 + (j-1)*jGjLoc )*global_nTx  C--- End Global File / tile-file cases
      &                 + ( k-kLo + (irecord-1)*nNz  
      &                   )*ySize*global_nTx  
 #else /* ALLOW_EXCH2 */  
               iG = myXGlobalLo-1 + (bi-1)*sNx  
               jG = myYGlobalLo-1 + (bj-1)*sNy  
               irec= 1 + INT(iG/sNx) + nSx*nPx*(jG+j-1)  
      &                + nSx*nPx*Ny*(k-kLo)  
      &                + nSx*nPx*Ny*nNz*(irecord-1)  
 #endif /* ALLOW_EXCH2 */  
              ELSE  
               irec=j + sNy*(k-kLo) + sNy*nNz*(irecord-1)  
              ENDIF  
              IF (filePrec .EQ. precFloat32) THEN  
               IF (arrType .EQ. 'RS') THEN  
                CALL MDS_SEG4toRS( j,bi,bj,k,kSize, r4seg,.FALSE.,arr )  
               ELSEIF (arrType .EQ. 'RL') THEN  
                CALL MDS_SEG4toRL( j,bi,bj,k,kSize, r4seg,.FALSE.,arr )  
               ELSE  
                WRITE(msgBuf,'(A)')  
      &           ' MDS_WRITE_FIELD: illegal value for arrType'  
                CALL PRINT_ERROR( msgBuf, myThid )  
                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'  
               ENDIF  
 #ifdef _BYTESWAPIO  
               CALL MDS_BYTESWAPR4( sNx, r4seg )  
 #endif  
               WRITE(dUnit,rec=irec) r4seg  
              ELSEIF (filePrec .EQ. precFloat64) THEN  
               IF (arrType .EQ. 'RS') THEN  
                CALL MDS_SEG8toRS( j,bi,bj,k,kSize, r8seg,.FALSE.,arr )  
               ELSEIF (arrType .EQ. 'RL') THEN  
                CALL MDS_SEG8toRL( j,bi,bj,k,kSize, r8seg,.FALSE.,arr )  
               ELSE  
                WRITE(msgBuf,'(A)')  
      &           ' MDS_WRITE_FIELD: illegal value for arrType'  
                CALL PRINT_ERROR( msgBuf, myThid )  
                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'  
               ENDIF  
 #ifdef _BYTESWAPIO  
               CALL MDS_BYTESWAPR8( sNx, r8seg )  
 #endif  
               WRITE(dUnit,rec=irec) r8seg  
              ELSE  
               WRITE(msgBuf,'(A)')  
      &          ' MDS_WRITE_FIELD: illegal value for filePrec'  
               CALL PRINT_ERROR( msgBuf, myThid )  
               STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'  
              ENDIF  
 C End of j loop  
             ENDDO  
 C End of k loop  
            ENDDO  
           ELSE  
 C fileIsOpen=F  
            WRITE(msgBuf,'(A)')  
      &       ' MDS_WRITE_FIELD: I should never get to this point'  
            CALL PRINT_ERROR( msgBuf, myThid )  
            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'  
           ENDIF  
 C If we were writing to a tiled MDS file then we close it here  
           IF (fileIsOpen .AND. (.NOT. globalFile)) THEN  
            CLOSE( dUnit )  
            fileIsOpen = .FALSE.  
488            ENDIF            ENDIF
489    
490  C Create meta-file for each tile if we are tiling  C Create meta-file for each tile if we are tiling
491            IF ( .NOT.globalFile .AND. writeMetaF ) THEN            IF ( .NOT.globalFile .AND. writeMetaF ) THEN
492             iG=bi+(myXGlobalLo-1)/sNx             iG=bi+(myXGlobalLo-1)/sNx
493             jG=bj+(myYGlobalLo-1)/sNy             jG=bj+(myYGlobalLo-1)/sNy
494             WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')             WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')
495       &              pfName(1:pIL),'.',iG,'.',jG,'.meta'       &              pfName(1:pIL),'.',iG,'.',jG,'.meta'
 #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)  
            tN = W2_myTileList(bi)  
496             dimList(1,1) = xSize             dimList(1,1) = xSize
497             dimList(2,1) = exch2_txGlobalo(tN)             dimList(2,1) = tBx + 1
498             dimList(3,1) = exch2_txGlobalo(tN)+sNx-1             dimList(3,1) = tBx + tNx
499             dimList(1,2) = ySize             dimList(1,2) = ySize
500             dimList(2,2) = exch2_tyGlobalo(tN)             dimList(2,2) = tBy + 1
501             dimList(3,2) = exch2_tyGlobalo(tN)+sNy-1             dimList(3,2) = tBy + tNy
 #else /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */  
 C- jmc: if MISSING_TILE_IO, keep meta files unchanged  
 C       to stay consistent with global file structure  
            dimList(1,1) = Nx  
            dimList(2,1) = myXGlobalLo+(bi-1)*sNx  
            dimList(3,1) = myXGlobalLo+bi*sNx-1  
            dimList(1,2) = Ny  
            dimList(2,2) = myYGlobalLo+(bj-1)*sNy  
            dimList(3,2) = myYGlobalLo+bj*sNy-1  
 #endif /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */  
502             dimList(1,3) = nNz             dimList(1,3) = nNz
503             dimList(2,3) = 1             dimList(2,3) = 1
504             dimList(3,3) = nNz             dimList(3,3) = nNz
505    c          dimList(1,3) = kSize
506    c          dimList(2,3) = kLo
507    c          dimList(3,3) = kHi
508             nDims = 3             nDims = 3
509             IF ( nNz.EQ.1 ) nDims = 2             IF ( nNz.EQ.1 ) nDims = 2
510             map2gl(1) = iGjLoc             map2gl(1) = iGjLoc
511             map2gl(2) = jGjLoc             map2gl(2) = jGjLoc
512             CALL MDS_WRITE_META(             CALL MDS_WRITE_META(
513       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
514       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims, dimList, map2gl, 0, blank8c,
515       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, dummyRL, irecord, myIter, myThid )
516            ENDIF            ENDIF
517    
518  C End of bi,bj loops  C End of bi,bj loops
519           ENDDO           ENDDO
520          ENDDO          ENDDO
521    
522  C If global file was opened then close it  C If global file was opened then close it
523          IF (fileIsOpen .AND. globalFile) THEN          IF (fileIsOpen .AND. globalFile) THEN
524           CLOSE( dUnit )            CLOSE( dUnit )
525           fileIsOpen = .FALSE.            fileIsOpen = .FALSE.
526          ENDIF          ENDIF
527    
528  C- endif iAmDoingIO  C- endif iAmDoingIO
529         ENDIF         ENDIF
530    
531    C Make other threads wait for I/O completion so that after this,
532    C  3-D buffer can again be modified by any thread
533           CALL BAR2( myThid )
534    
535  C     if useSingleCpuIO / else / end  C     if useSingleCpuIO / else / end
536        ENDIF        ENDIF
537    
# Line 459  C Create meta-file for the global-file ( Line 548  C Create meta-file for the global-file (
548           dimList(1,3) = nNz           dimList(1,3) = nNz
549           dimList(2,3) = 1           dimList(2,3) = 1
550           dimList(3,3) = nNz           dimList(3,3) = nNz
551    c        dimList(1,3) = kSize
552    c        dimList(2,3) = kLo
553    c        dimList(3,3) = kHi
554           nDims = 3           nDims = 3
555           IF ( nNz.EQ.1 ) nDims = 2           IF ( nNz.EQ.1 ) nDims = 2
556           map2gl(1) = 0           map2gl(1) = 0
557           map2gl(2) = 1           map2gl(2) = 1
558           CALL MDS_WRITE_META(           CALL MDS_WRITE_META(
559       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
560       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims, dimList, map2gl, 0, blank8c,
561       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, dummyRL, irecord, myIter, myThid )
562  c    I              metaFName, dataFName, the_run_name, titleLine,  c    I              metaFName, dataFName, the_run_name, titleLine,
563  c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,  c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,
564  c    I              nTimRec, timList, irecord, myIter, myThid )  c    I              nTimRec, timList, irecord, myIter, myThid )
565        ENDIF        ENDIF
566    
 C To be safe, make other processes wait for I/O completion  
       _BARRIER  
   
567  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
568        RETURN        RETURN
569        END        END
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.16
  ViewVC Help
Powered by ViewVC 1.1.22