/[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.2 by jmc, Mon Mar 19 02:30:49 2007 UTC revision 1.10 by jmc, Mon Jun 1 14:20:31 2009 UTC
# Line 12  C !INTERFACE: Line 12  C !INTERFACE:
12       I   globalFile,       I   globalFile,
13       I   useCurrentDir,       I   useCurrentDir,
14       I   arrType,       I   arrType,
15       I   zSize,nNz,       I   kSize,kLo,kHi,
16       I   arr,       I   arr,
17       I   jrecord,       I   jrecord,
18       I   myIter,       I   myIter,
# Line 27  C globalFile (logical):: selects between Line 27  C globalFile (logical):: selects between
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)) :: declaration of "arr": either "RS" or "RL"
30  C zSize     (integer) :: size of third dimension: normally either 1 or Nr  C kSize     (integer) :: size of third dimension: normally either 1 or Nr
31  C nNz       (integer) :: number of vertical levels to write  C kLo       (integer) :: 1rst vertical level (of array "arr") to write
32  C arr       ( RS/RL ) :: array to write, arr(:,:,zSize,:,:)  C kHi       (integer) :: last vertical level (of array "arr") to write
33    C arr       ( RS/RL ) :: array to write, arr(:,:,kSize,:,:)
34  C irecord   (integer) :: record number to write  C irecord   (integer) :: record number to write
35  C myIter    (integer) :: time step number  C myIter    (integer) :: time step number
36  C myThid    (integer) :: thread identifier  C myThid    (integer) :: thread identifier
37  C  C
38  C MDS_WRITE_FIELD creates either a file of the form "fName.data" and  C MDS_WRITE_FIELD creates either a file of the form "fName.data" and
39  C "fName.meta" if the logical flag "globalFile" is set true. Otherwise  C  "fName.meta" if the logical flag "globalFile" is set true. Otherwise
40  C it creates MDS tiled files of the form "fName.xxx.yyy.data" and  C  it creates MDS tiled files of the form "fName.xxx.yyy.data" and
41  C "fName.xxx.yyy.meta". If jrecord > 0, a meta-file is created.  C  "fName.xxx.yyy.meta". If jrecord > 0, a meta-file is created.
42  C Currently, the meta-files are not read because it is difficult  C Currently, the meta-files are not read because it is difficult
43  C to parse files in fortran. We should read meta information before  C  to parse files in fortran. We should read meta information before
44  C adding records to an existing multi-record file.  C  adding records to an existing multi-record file.
45  C The precision of the file is decsribed by filePrec, set either  C The precision of the file is decsribed by filePrec, set either
46  C to floatPrec32 or floatPrec64. The precision or declaration of  C  to floatPrec32 or floatPrec64. The precision or declaration of
47  C the array argument must be consistently described by the char*(2)  C  the array argument must be consistently described by the char*(2)
48  C string arrType, either "RS" or "RL". nNz allows for both 2-D and  C  string arrType, either "RS" or "RL".
49  C 3-D arrays to be handled. nNz=1 implies a 2-D model field and  C (kSize,kLo,kHi) allows for both 2-D and 3-D arrays to be handled, with
50  C nNz=Nr implies a 3-D model field. irecord=|jrecord| is the record number  C  the option to only write a sub-set of consecutive vertical levels (from
51  C to be written and must be >= 1. NOTE: It is currently assumed that  C  kLo to kHi); (kSize,kLo,kHi)=(1,1,1) implies a 2-D model field and
52  C the highest record number in the file was the last record written.  C  (kSize,kLo,kHi)=(Nr,1,Nr) implies a 3-D model field.
53  C Nor is there a consistency check between the routine arguments and file.  C irecord=|jrecord| is the record number to be written and must be >= 1.
54  C ie. if you write record 2 after record 4 the meta information  C NOTE: It is currently assumed that the highest record number in the file
55  C will record the number of records to be 2. This, again, is because  C  was the last record written. Nor is there a consistency check between the
56  C we have read the meta information. To be fixed.  C  routine arguments and file, i.e., if you write record 2 after record 4
57    C  the meta information will record the number of records to be 2. This,
58    C  again, is because we have read the meta information. To be fixed.
59  C  C
60  C Created: 03/16/99 adcroft@mit.edu  C Created: 03/16/99 adcroft@mit.edu
61  C Changed: 01/06/02 menemenlis@jpl.nasa.gov  C Changed: 01/06/02 menemenlis@jpl.nasa.gov
# Line 66  C !USES: Line 69  C !USES:
69  C Global variables / common blocks  C Global variables / common blocks
70  #include "SIZE.h"  #include "SIZE.h"
71  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "EESUPPORT.h"  
72  #include "PARAMS.h"  #include "PARAMS.h"
73  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
74    #include "W2_EXCH2_SIZE.h"
75  #include "W2_EXCH2_TOPOLOGY.h"  #include "W2_EXCH2_TOPOLOGY.h"
76  #include "W2_EXCH2_PARAMS.h"  #include "W2_EXCH2_PARAMS.h"
77  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
78  #include "MDSIO_SCPU.h"  #include "EEBUFF_SCPU.h"
79    
80  C !INPUT PARAMETERS:  C !INPUT PARAMETERS:
81        CHARACTER*(*) fName        CHARACTER*(*) fName
# Line 80  C !INPUT PARAMETERS: Line 83  C !INPUT PARAMETERS:
83        LOGICAL globalFile        LOGICAL globalFile
84        LOGICAL useCurrentDir        LOGICAL useCurrentDir
85        CHARACTER*(2) arrType        CHARACTER*(2) arrType
86        INTEGER zSize, nNz        INTEGER kSize, kLo, kHi
87  cph(  cph(
88  cph      Real arr(*)  cph      Real arr(*)
89        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,zSize,nSx,nSy)        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,kSize,nSx,nSy)
90  cph)  cph)
91        INTEGER jrecord        INTEGER jrecord
92        INTEGER myIter        INTEGER myIter
# Line 104  C !LOCAL VARIABLES: Line 107  C !LOCAL VARIABLES:
107        LOGICAL fileIsOpen        LOGICAL fileIsOpen
108        LOGICAL iAmDoingIO        LOGICAL iAmDoingIO
109        LOGICAL writeMetaF        LOGICAL writeMetaF
110          LOGICAL useExch2ioLayOut
111          LOGICAL zeroBuff
112          INTEGER xSize, ySize
113        INTEGER irecord        INTEGER irecord
114        INTEGER iG,jG,irec,bi,bj,i,j,k,dUnit,IL,pIL        INTEGER iG,jG,bi,bj,i,j,k,nNz
115          INTEGER irec,dUnit,IL,pIL
116        INTEGER dimList(3,3), nDims, map2gl(2)        INTEGER dimList(3,3), nDims, map2gl(2)
117        INTEGER iGjLoc, jGjLoc        INTEGER length_of_rec
       INTEGER x_size,y_size,length_of_rec  
 #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)  
       INTEGER iG_IO,jG_IO,npe, loc_xGlobalLo, loc_yGlobalLo  
       PARAMETER ( x_size = exch2_domain_nxt * sNx )  
       PARAMETER ( y_size = exch2_domain_nyt * sNy )  
 #else  
       PARAMETER ( x_size = Nx )  
       PARAMETER ( y_size = Ny )  
 #endif  
118        Real*4 r4seg(sNx)        Real*4 r4seg(sNx)
119        Real*8 r8seg(sNx)        Real*8 r8seg(sNx)
120        Real*4 xy_buffer_r4(x_size,y_size)        Real*4 r4loc(sNx,sNy)
121        Real*8 xy_buffer_r8(x_size,y_size)        Real*8 r8loc(sNx,sNy)
122        Real*8 globalBuf(Nx,Ny)        INTEGER tNx, tNy, global_nTx
123          INTEGER tBx, tBy, iGjLoc, jGjLoc
124  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
125  c     INTEGER tGy,tGx,tNy,tNx,tN        INTEGER tN
       INTEGER tGy,tGx,    tNx,tN  
126  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
       INTEGER tNy  
127    
128  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
129    C Set dimensions:
130          xSize = Nx
131          ySize = Ny
132          useExch2ioLayOut = .FALSE.
133    #ifdef ALLOW_EXCH2
134          IF ( W2_useE2ioLayOut ) THEN
135            xSize = exch2_global_Nx
136            ySize = exch2_global_Ny
137            useExch2ioLayOut = .TRUE.
138          ENDIF
139    #endif /* ALLOW_EXCH2 */
140    
141  C-    default:  C-    default:
142        iGjLoc = 0        iGjLoc = 0
# Line 138  C Assume nothing Line 146  C Assume nothing
146        fileIsOpen = .FALSE.        fileIsOpen = .FALSE.
147        IL  = ILNBLNK( fName )        IL  = ILNBLNK( fName )
148        pIL = ILNBLNK( mdsioLocalDir )        pIL = ILNBLNK( mdsioLocalDir )
149          nNz = 1 + kHi - kLo
150        irecord = ABS(jrecord)        irecord = ABS(jrecord)
151        writeMetaF = jrecord.GT.0        writeMetaF = jrecord.GT.0
152    
# Line 158  C Record number must be >= 1 Line 167  C Record number must be >= 1
167           CALL PRINT_ERROR( msgBuf, myThid )           CALL PRINT_ERROR( msgBuf, myThid )
168           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
169          ENDIF          ENDIF
170    C check for valid sub-set of levels:
171            IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN
172             WRITE(msgBuf,'(3(A,I6))')
173         &     ' MDS_WRITE_FIELD: arguments kSize=', kSize,
174         &     ' , kLo=', kLo, ' , kHi=', kHi
175             CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
176         &                       SQUEEZE_RIGHT , myThid)
177             WRITE(msgBuf,'(A)')
178         &     ' MDS_WRITE_FIELD: invalid sub-set of levels'
179             CALL PRINT_ERROR( msgBuf, myThid )
180             STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
181            ENDIF
182    
183  C Assign special directory  C Assign special directory
184          IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN          IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN
# Line 180  C globalFile is too slow, then try using Line 201  C globalFile is too slow, then try using
201  C Master thread of process 0, only, opens a global file  C Master thread of process 0, only, opens a global file
202         IF ( iAmDoingIO ) THEN         IF ( iAmDoingIO ) THEN
203           WRITE(dataFName,'(2a)') fName(1:IL),'.data'           WRITE(dataFName,'(2a)') fName(1:IL),'.data'
204           length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,myThid)           length_of_rec = MDS_RECLEN( filePrec, xSize*ySize, myThid )
205           IF (irecord .EQ. 1) THEN           IF (irecord .EQ. 1) THEN
206            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
207       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
# Line 191  C Master thread of process 0, only, open Line 212  C Master thread of process 0, only, open
212         ENDIF         ENDIF
213    
214  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
215         DO k=1,nNz         DO k=kLo,kHi
216            zeroBuff = k.EQ.kLo
217  C-      copy from arr(level=k) to 2-D "local":  C-      copy from arr(level=k) to 2-D "local":
218          IF ( arrType.EQ.'RS' ) THEN          IF ( filePrec.EQ.precFloat32 ) THEN
219            CALL MDS_PASStoRS(sharedLocalBuf,arr,k,zSize,.FALSE.,myThid)            IF ( arrType.EQ.'RS' ) THEN
220          ELSEIF ( arrType.EQ.'RL' ) THEN              CALL MDS_PASS_R4toRS( sharedLocBuf_r4, arr,
221            CALL MDS_PASStoRL(sharedLocalBuf,arr,k,zSize,.FALSE.,myThid)       I                            k, kSize, 0,0, .FALSE., myThid )
222          ELSE            ELSEIF ( arrType.EQ.'RL' ) THEN
223            WRITE(msgBuf,'(A)')              CALL MDS_PASS_R4toRL( sharedLocBuf_r4, arr,
224         I                            k, kSize, 0,0, .FALSE., myThid )
225              ELSE
226                WRITE(msgBuf,'(A)')
227       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &         ' MDS_WRITE_FIELD: illegal value for arrType'
228            CALL PRINT_ERROR( msgBuf, myThid )              CALL PRINT_ERROR( msgBuf, myThid )
229            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
         ENDIF  
         CALL GATHER_2D( globalBuf, sharedLocalBuf, myThid )  
   
         IF ( iAmDoingIO ) THEN  
 #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)  
           IF (filePrec .EQ. precFloat32) THEN  
            DO J=1,y_size  
             DO I=1,x_size  
              xy_buffer_r4(I,J) = 0.0  
             ENDDO  
            ENDDO  
           ELSEIF (filePrec .EQ. precFloat64) THEN  
            DO J=1,y_size  
             DO I=1,x_size  
              xy_buffer_r8(I,J) = 0.0  
             ENDDO  
            ENDDO  
230            ENDIF            ENDIF
231              CALL GATHER_2D_R4(
232            bj=1       O                       xy_buffer_r4,
233            DO npe=1,nPx*nPy       I                       sharedLocBuf_r4,
234             DO bi=1,nSx       I                       xSize, ySize,
235  #ifdef ALLOW_USE_MPI       I                       useExch2ioLayOut, zeroBuff, myThid )
236              loc_xGlobalLo = mpi_myXGlobalLo(npe)          ELSEIF ( filePrec.EQ.precFloat64 ) THEN
237              loc_yGlobalLo = mpi_myYGlobalLo(npe)            IF ( arrType.EQ.'RS' ) THEN
238  #else  /* ALLOW_USE_MPI */              CALL MDS_PASS_R8toRS( sharedLocBuf_r8, arr,
239              loc_xGlobalLo = myXGlobalLo       I                            k, kSize, 0,0, .FALSE., myThid )
240              loc_yGlobalLo = myYGlobalLo            ELSEIF ( arrType.EQ.'RL' ) THEN
241  #endif /* ALLOW_USE_MPI */              CALL MDS_PASS_R8toRL( sharedLocBuf_r8, arr,
242              tN = W2_mpi_myTileList(npe,bi)       I                            k, kSize, 0,0, .FALSE., myThid )
243              IF   ( exch2_mydNx(tN) .GT. x_size ) THEN            ELSE
244  C-          face x-size larger than glob-size : fold it              WRITE(msgBuf,'(A)')
245                iGjLoc = 0       &         ' MDS_WRITE_FIELD: illegal value for arrType'
246                jGjLoc = exch2_mydNx(tN) / x_size              CALL PRINT_ERROR( msgBuf, myThid )
247              ELSEIF ( exch2_tNy(tN) .GT. y_size ) THEN              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
 C-          tile y-size larger than glob-size : make a long line  
               iGjLoc = exch2_mydNx(tN)  
               jGjLoc = 0  
             ELSE  
 C-          default (face fit into global-IO-array)  
               iGjLoc = 0  
               jGjLoc = 1  
             ENDIF  
   
             IF (filePrec .EQ. precFloat32) THEN  
              DO J=1,sNy  
               DO I=1,sNx  
                iG = loc_xGlobalLo-1+(bi-1)*sNx+i  
                jG = loc_yGlobalLo-1+(bj-1)*sNy+j  
                iG_IO=exch2_txGlobalo(tN)+iGjLoc*(j-1)+i-1  
                jG_IO=exch2_tyGlobalo(tN)+jGjLoc*(j-1)  
                xy_buffer_r4(iG_IO,jG_IO) = globalBuf(iG,jG)  
               ENDDO  
              ENDDO  
             ELSEIF (filePrec .EQ. precFloat64) THEN  
              DO J=1,sNy  
               DO I=1,sNx  
                iG = loc_xGlobalLo-1+(bi-1)*sNx+i  
                jG = loc_yGlobalLo-1+(bj-1)*sNy+j  
                iG_IO=exch2_txGlobalo(tN)+iGjLoc*(j-1)+i-1  
                jG_IO=exch2_tyGlobalo(tN)+jGjLoc*(j-1)  
                xy_buffer_r8(iG_IO,jG_IO) = globalBuf(iG,jG)  
               ENDDO  
              ENDDO  
             ENDIF  
   
 C--    end of npe & bi loops  
            ENDDO  
           ENDDO  
 #else /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */  
           IF (filePrec .EQ. precFloat32) THEN  
            DO J=1,Ny  
             DO I=1,Nx  
              xy_buffer_r4(I,J) = globalBuf(I,J)  
             ENDDO  
            ENDDO  
           ELSEIF (filePrec .EQ. precFloat64) THEN  
            DO J=1,Ny  
             DO I=1,Nx  
              xy_buffer_r8(I,J) = globalBuf(I,J)  
             ENDDO  
            ENDDO  
248            ENDIF            ENDIF
249  #endif /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */            CALL GATHER_2D_R8(
250         O                       xy_buffer_r8,
251         I                       sharedLocBuf_r8,
252         I                       xSize, ySize,
253         I                       useExch2ioLayOut, zeroBuff, myThid )
254            ELSE
255               WRITE(msgBuf,'(A)')
256         &       ' MDS_WRITE_FIELD: illegal value for filePrec'
257               CALL PRINT_ERROR( msgBuf, myThid )
258               STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
259            ENDIF
260    
261            irec=k+nNz*(irecord-1)          IF ( iAmDoingIO ) THEN
262              irec = 1 + k-kLo + (irecord-1)*nNz
263            IF (filePrec .EQ. precFloat32) THEN            IF (filePrec .EQ. precFloat32) THEN
264  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
265             CALL MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )             CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )
266  #endif  #endif
267             WRITE(dUnit,rec=irec) xy_buffer_r4             WRITE(dUnit,rec=irec) ( xy_buffer_r4(i),i=1,xSize*ySize )
268            ELSEIF (filePrec .EQ. precFloat64) THEN            ELSEIF (filePrec .EQ. precFloat64) THEN
269  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
270             CALL MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )             CALL MDS_BYTESWAPR8( xSize*ySize, xy_buffer_r8 )
271  #endif  #endif
272             WRITE(dUnit,rec=irec) xy_buffer_r8             WRITE(dUnit,rec=irec) ( xy_buffer_r8(i),i=1,xSize*ySize )
273            ELSE            ELSE
274             WRITE(msgBuf,'(A)')             WRITE(msgBuf,'(A)')
275       &       ' MDS_WRITE_FIELD: illegal value for filePrec'       &       ' MDS_WRITE_FIELD: illegal value for filePrec'
# Line 324  C Only do I/O if I am the master thread Line 296  C Only do I/O if I am the master thread
296  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
297          IF (globalFile) THEN          IF (globalFile) THEN
298           WRITE(dataFName,'(2a)') fName(1:IL),'.data'           WRITE(dataFName,'(2a)') fName(1:IL),'.data'
299             length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
300           IF (irecord .EQ. 1) THEN           IF (irecord .EQ. 1) THEN
           length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )  
301            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
302       &            access='direct', recl=length_of_rec )       &            access='direct', recl=length_of_rec )
           fileIsOpen=.TRUE.  
303           ELSE           ELSE
           length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )  
304            OPEN( dUnit, file=dataFName, status=_OLD_STATUS,            OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
305       &            access='direct', recl=length_of_rec )       &            access='direct', recl=length_of_rec )
           fileIsOpen=.TRUE.  
306           ENDIF           ENDIF
307             fileIsOpen=.TRUE.
308          ENDIF          ENDIF
309    
310  C Loop over all tiles  C Loop over all tiles
311          DO bj=1,nSy          DO bj=1,nSy
312           DO bi=1,nSx           DO bi=1,nSx
 C If we are writing to a tiled MDS file then we open each one here  
           IF (.NOT. globalFile) THEN  
            iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles  
            jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles  
            WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')  
      &              pfName(1:pIL),'.',iG,'.',jG,'.data'  
            IF (irecord .EQ. 1) THEN  
             length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )  
             OPEN( dUnit, file=dataFName, status=_NEW_STATUS,  
      &            access='direct', recl=length_of_rec )  
             fileIsOpen=.TRUE.  
            ELSE  
             length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )  
             OPEN( dUnit, file=dataFName, status=_OLD_STATUS,  
      &            access='direct', recl=length_of_rec )  
             fileIsOpen=.TRUE.  
            ENDIF  
           ENDIF  
313    
314            IF (fileIsOpen) THEN            tNx = sNx
315             tNy = sNy            tNy = sNy
316              global_nTx = xSize/sNx
317              tBx = myXGlobalLo-1 + (bi-1)*sNx
318              tBy = myYGlobalLo-1 + (bj-1)*sNy
319  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
320             tN = W2_myTileList(bi)            IF ( useExch2ioLayOut ) THEN
321             tGy = exch2_tyGlobalo(tN)              tN = W2_myTileList(bi)
322             tGx = exch2_txGlobalo(tN)  c           tNx = exch2_tNx(tN)
323             tNy = exch2_tNy(tN)  c           tNy = exch2_tNy(tN)
324             tNx = exch2_tNx(tN)  c           global_nTx = exch2_global_Nx/tNx
325             IF   ( exch2_mydNx(tN) .GT. x_size ) THEN              tBx = exch2_txGlobalo(tN) - 1
326  C-         face x-size larger than glob-size : fold it              tBy = exch2_tyGlobalo(tN) - 1
327               iGjLoc = 0              IF   ( exch2_mydNx(tN) .GT. xSize ) THEN
328               jGjLoc = exch2_mydNx(tN) / x_size  C-          face x-size larger than glob-size : fold it
329             ELSEIF ( exch2_tNy(tN) .GT. y_size ) THEN                iGjLoc = 0
330  C-         tile y-size larger than glob-size : make a long line                jGjLoc = exch2_mydNx(tN) / xSize
331               iGjLoc = exch2_mydNx(tN)              ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
332               jGjLoc = 0  C-          tile y-size larger than glob-size : make a long line
333             ELSE                iGjLoc = exch2_mydNx(tN)
334  C-         default (face fit into global-IO-array)                jGjLoc = 0
335               iGjLoc = 0              ELSE
336               jGjLoc = 1  C-          default (face fit into global-IO-array)
337             ENDIF                iGjLoc = 0
338                  jGjLoc = 1
339                ENDIF
340              ENDIF
341  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
342             DO k=1,nNz  
343              IF (globalFile) THEN
344    C--- Case of 1 Global file:
345    
346               DO k=kLo,kHi
347              DO j=1,tNy              DO j=1,tNy
348               IF (globalFile) THEN               irec = 1 + ( tBx + (j-1)*iGjLoc )/tNx
349  #ifdef ALLOW_EXCH2       &                + ( tBy + (j-1)*jGjLoc )*global_nTx
350                irec = 1 + ( tGx-1 + (j-1)*iGjLoc )/tNx       &            +( k-kLo + (irecord-1)*nNz )*global_nTx*ySize
      &                 + ( tGy-1 + (j-1)*jGjLoc )*exch2_domain_nxt  
      &                 + ( k-1 + (irecord-1)*nNz  
      &                   )*y_size*exch2_domain_nxt  
 #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-1)  
      &                + nSx*nPx*Ny*nNz*(irecord-1)  
 #endif /* ALLOW_EXCH2 */  
              ELSE  
               irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)  
              ENDIF  
351               IF (filePrec .EQ. precFloat32) THEN               IF (filePrec .EQ. precFloat32) THEN
352                IF (arrType .EQ. 'RS') THEN                IF (arrType .EQ. 'RS') THEN
353                 CALL MDS_SEG4toRS( j,bi,bj,k,zSize, r4seg,.FALSE.,arr )                 CALL MDS_SEG4toRS( j,bi,bj,k,kSize, r4seg,.FALSE.,arr )
354                ELSEIF (arrType .EQ. 'RL') THEN                ELSEIF (arrType .EQ. 'RL') THEN
355                 CALL MDS_SEG4toRL( j,bi,bj,k,zSize, r4seg,.FALSE.,arr )                 CALL MDS_SEG4toRL( j,bi,bj,k,kSize, r4seg,.FALSE.,arr )
356                ELSE                ELSE
357                 WRITE(msgBuf,'(A)')                 WRITE(msgBuf,'(A)')
358       &           ' MDS_WRITE_FIELD: illegal value for arrType'       &           ' MDS_WRITE_FIELD: illegal value for arrType'
# Line 416  C-         default (face fit into global Line 365  C-         default (face fit into global
365                WRITE(dUnit,rec=irec) r4seg                WRITE(dUnit,rec=irec) r4seg
366               ELSEIF (filePrec .EQ. precFloat64) THEN               ELSEIF (filePrec .EQ. precFloat64) THEN
367                IF (arrType .EQ. 'RS') THEN                IF (arrType .EQ. 'RS') THEN
368                 CALL MDS_SEG8toRS( j,bi,bj,k,zSize, r8seg,.FALSE.,arr )                 CALL MDS_SEG8toRS( j,bi,bj,k,kSize, r8seg,.FALSE.,arr )
369                ELSEIF (arrType .EQ. 'RL') THEN                ELSEIF (arrType .EQ. 'RL') THEN
370                 CALL MDS_SEG8toRL( j,bi,bj,k,zSize, r8seg,.FALSE.,arr )                 CALL MDS_SEG8toRL( j,bi,bj,k,kSize, r8seg,.FALSE.,arr )
371                ELSE                ELSE
372                 WRITE(msgBuf,'(A)')                 WRITE(msgBuf,'(A)')
373       &           ' MDS_WRITE_FIELD: illegal value for arrType'       &           ' MDS_WRITE_FIELD: illegal value for arrType'
# Line 439  C End of j loop Line 388  C End of j loop
388              ENDDO              ENDDO
389  C End of k loop  C End of k loop
390             ENDDO             ENDDO
391    
392            ELSE            ELSE
393  C fileIsOpen=F  C--- Case of 1 file per tile (globalFile=F):
394             WRITE(msgBuf,'(A)')  
395       &       ' MDS_WRITE_FIELD: I should never get to this point'  C If we are writing to a tiled MDS file then we open each one here
396             CALL PRINT_ERROR( msgBuf, myThid )             iG=bi+(myXGlobalLo-1)/sNx
397             STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'             jG=bj+(myYGlobalLo-1)/sNy
398            ENDIF             WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
399  C If we were writing to a tiled MDS file then we close it here       &              pfName(1:pIL),'.',iG,'.',jG,'.data'
400            IF (fileIsOpen .AND. (.NOT. globalFile)) THEN             length_of_rec = MDS_RECLEN( filePrec, sNx*sNy, myThid )
401             CLOSE( dUnit )             IF (irecord .EQ. 1) THEN
402             fileIsOpen = .FALSE.              OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
403         &            access='direct', recl=length_of_rec )
404               ELSE
405                OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
406         &            access='direct', recl=length_of_rec )
407               ENDIF
408               fileIsOpen=.TRUE.
409    
410               DO k=kLo,kHi
411    
412                 irec = 1 + k-kLo + (irecord-1)*nNz
413                 IF (filePrec .EQ. precFloat32) THEN
414                  IF ( arrType.EQ.'RS' ) THEN
415                   CALL MDS_PASS_R4toRS( r4loc, arr,
416         I                           k, kSize, bi,bj,.FALSE., myThid )
417                  ELSEIF ( arrType.EQ.'RL' ) THEN
418                   CALL MDS_PASS_R4toRL( r4loc, arr,
419         I                           k, kSize, bi,bj,.FALSE., myThid )
420                  ELSE
421                   WRITE(msgBuf,'(A)')
422         &           ' MDS_WRITE_FIELD: illegal value for arrType'
423                   CALL PRINT_ERROR( msgBuf, myThid )
424                   STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
425                  ENDIF
426    #ifdef _BYTESWAPIO
427                  CALL MDS_BYTESWAPR4( sNx*sNy, r4loc )
428    #endif
429                  WRITE(dUnit,rec=irec) r4loc
430                 ELSEIF (filePrec .EQ. precFloat64) THEN
431                  IF ( arrType.EQ.'RS' ) THEN
432                   CALL MDS_PASS_R8toRS( r8loc, arr,
433         I                           k, kSize, bi,bj,.FALSE., myThid )
434                  ELSEIF ( arrType.EQ.'RL' ) THEN
435                   CALL MDS_PASS_R8toRL( r8loc, arr,
436         I                           k, kSize, bi,bj,.FALSE., myThid )
437                  ELSE
438                   WRITE(msgBuf,'(A)')
439         &           ' MDS_WRITE_FIELD: illegal value for arrType'
440                   CALL PRINT_ERROR( msgBuf, myThid )
441                   STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
442                  ENDIF
443    #ifdef _BYTESWAPIO
444                  CALL MDS_BYTESWAPR8( sNx*sNy, r8loc )
445    #endif
446                  WRITE(dUnit,rec=irec) r8loc
447                 ELSE
448                  WRITE(msgBuf,'(A)')
449         &          ' MDS_WRITE_FIELD: illegal value for filePrec'
450                  CALL PRINT_ERROR( msgBuf, myThid )
451                  STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
452                 ENDIF
453    
454    C End of k loop
455               ENDDO
456    
457    C here We close the tiled MDS file
458               IF ( fileIsOpen ) THEN
459                CLOSE( dUnit )
460                fileIsOpen = .FALSE.
461               ENDIF
462    
463    C--- End Global File / tile-file cases
464            ENDIF            ENDIF
465    
466  C Create meta-file for each tile if we are tiling  C Create meta-file for each tile if we are tiling
467            IF ( .NOT.globalFile .AND. writeMetaF ) THEN            IF ( .NOT.globalFile .AND. writeMetaF ) THEN
468             iG=bi+(myXGlobalLo-1)/sNx             iG=bi+(myXGlobalLo-1)/sNx
469             jG=bj+(myYGlobalLo-1)/sNy             jG=bj+(myYGlobalLo-1)/sNy
470             WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')             WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')
471       &              pfName(1:pIL),'.',iG,'.',jG,'.meta'       &              pfName(1:pIL),'.',iG,'.',jG,'.meta'
472  #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)             dimList(1,1) = xSize
473             tN = W2_myTileList(bi)             dimList(2,1) = tBx + 1
474             dimList(1,1)=x_size             dimList(3,1) = tBx + tNx
475             dimList(2,1)=exch2_txGlobalo(tN)             dimList(1,2) = ySize
476             dimList(3,1)=exch2_txGlobalo(tN)+sNx-1             dimList(2,2) = tBy + 1
477             dimList(1,2)=y_size             dimList(3,2) = tBy + tNy
478             dimList(2,2)=exch2_tyGlobalo(tN)             dimList(1,3) = nNz
479             dimList(3,2)=exch2_tyGlobalo(tN)+sNy-1             dimList(2,3) = 1
480  #else /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */             dimList(3,3) = nNz
481  C- jmc: if MISSING_TILE_IO, keep meta files unchanged  c          dimList(1,3) = kSize
482  C       to stay consistent with global file structure  c          dimList(2,3) = kLo
483             dimList(1,1)=Nx  c          dimList(3,3) = kHi
484             dimList(2,1)=myXGlobalLo+(bi-1)*sNx             nDims = 3
485             dimList(3,1)=myXGlobalLo+bi*sNx-1             IF ( nNz.EQ.1 ) nDims = 2
            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) */  
            dimList(1,3)=nNz  
            dimList(2,3)=1  
            dimList(3,3)=nNz  
            nDims=3  
            IF ( nNz.EQ.1 ) nDims=2  
486             map2gl(1) = iGjLoc             map2gl(1) = iGjLoc
487             map2gl(2) = jGjLoc             map2gl(2) = jGjLoc
488             CALL MDS_WRITE_META(             CALL MDS_WRITE_META(
# Line 487  C       to stay consistent with global f Line 490  C       to stay consistent with global f
490       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims,dimList,map2gl, 0,  ' ',
491       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, UNSET_RL, irecord, myIter, myThid )
492            ENDIF            ENDIF
493    
494  C End of bi,bj loops  C End of bi,bj loops
495           ENDDO           ENDDO
496          ENDDO          ENDDO
# Line 507  C Create meta-file for the global-file ( Line 511  C Create meta-file for the global-file (
511        IF ( writeMetaF .AND. iAmDoingIO .AND.        IF ( writeMetaF .AND. iAmDoingIO .AND.
512       &    (globalFile .OR. useSingleCpuIO) ) THEN       &    (globalFile .OR. useSingleCpuIO) ) THEN
513           WRITE(metaFName,'(2A)') fName(1:IL),'.meta'           WRITE(metaFName,'(2A)') fName(1:IL),'.meta'
514           dimList(1,1)=x_size           dimList(1,1) = xSize
515           dimList(2,1)=1           dimList(2,1) = 1
516           dimList(3,1)=x_size           dimList(3,1) = xSize
517           dimList(1,2)=y_size           dimList(1,2) = ySize
518           dimList(2,2)=1           dimList(2,2) = 1
519           dimList(3,2)=y_size           dimList(3,2) = ySize
520           dimList(1,3)=nNz           dimList(1,3) = nNz
521           dimList(2,3)=1           dimList(2,3) = 1
522           dimList(3,3)=nNz           dimList(3,3) = nNz
523           nDims=3  c        dimList(1,3) = kSize
524           IF ( nNz.EQ.1 ) nDims=2  c        dimList(2,3) = kLo
525           map2gl(1) = iGjLoc  c        dimList(3,3) = kHi
526           map2gl(2) = jGjLoc           nDims = 3
527             IF ( nNz.EQ.1 ) nDims = 2
528             map2gl(1) = 0
529             map2gl(2) = 1
530           CALL MDS_WRITE_META(           CALL MDS_WRITE_META(
531       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
532       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims,dimList,map2gl, 0,  ' ',
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.10
  ViewVC Help
Powered by ViewVC 1.1.22