/[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.15 by jmc, Sun Aug 2 20:42:43 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_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 80  C !INPUT PARAMETERS: Line 87  C !INPUT PARAMETERS:
87        LOGICAL globalFile        LOGICAL globalFile
88        LOGICAL useCurrentDir        LOGICAL useCurrentDir
89        CHARACTER*(2) arrType        CHARACTER*(2) arrType
90        INTEGER zSize, nNz        INTEGER kSize, kLo, kHi
91  cph(  cph(
92  cph      Real arr(*)  cph      Real arr(*)
93        _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)
94  cph)  cph)
95        INTEGER jrecord        INTEGER jrecord
96        INTEGER myIter        INTEGER myIter
# Line 99  C !FUNCTIONS Line 106  C !FUNCTIONS
106        EXTERNAL MASTER_CPU_IO        EXTERNAL MASTER_CPU_IO
107    
108  C !LOCAL VARIABLES:  C !LOCAL VARIABLES:
109    C     bBij  :: base shift in Buffer index for tile bi,bj
110        CHARACTER*(MAX_LEN_FNAM) dataFName,metaFName,pfName        CHARACTER*(MAX_LEN_FNAM) dataFName,metaFName,pfName
111        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
112        LOGICAL fileIsOpen        LOGICAL fileIsOpen
113        LOGICAL iAmDoingIO        LOGICAL iAmDoingIO
114        LOGICAL writeMetaF        LOGICAL writeMetaF
115          LOGICAL useExch2ioLayOut
116          LOGICAL zeroBuff
117          INTEGER xSize, ySize
118        INTEGER irecord        INTEGER irecord
119        INTEGER iG,jG,irec,bi,bj,i,j,k,dUnit,IL,pIL        INTEGER iG,jG,bi,bj
120          INTEGER i1,i2,i,j,k,nNz
121          INTEGER irec,dUnit,IL,pIL
122        INTEGER dimList(3,3), nDims, map2gl(2)        INTEGER dimList(3,3), nDims, map2gl(2)
123        INTEGER iGjLoc, jGjLoc        INTEGER length_of_rec
124        INTEGER x_size,y_size,length_of_rec        INTEGER bBij
125  #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)        INTEGER tNx, tNy, global_nTx
126        INTEGER iG_IO,jG_IO,npe, loc_xGlobalLo, loc_yGlobalLo        INTEGER tBx, tBy, iGjLoc, jGjLoc
       PARAMETER ( x_size = exch2_domain_nxt * sNx )  
       PARAMETER ( y_size = exch2_domain_nyt * sNy )  
 #else  
       PARAMETER ( x_size = Nx )  
       PARAMETER ( y_size = Ny )  
 #endif  
       Real*4 r4seg(sNx)  
       Real*8 r8seg(sNx)  
       Real*4 xy_buffer_r4(x_size,y_size)  
       Real*8 xy_buffer_r8(x_size,y_size)  
       Real*8 globalBuf(Nx,Ny)  
127  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
128  c     INTEGER tGy,tGx,tNy,tNx,tN        INTEGER tN
       INTEGER tGy,tGx,    tNx,tN  
129  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
130        INTEGER tNy        _RL dummyRL(1)
131          CHARACTER*8 blank8c
132    
133          DATA dummyRL(1) / 0. _d 0 /
134          DATA blank8c / '        ' /
135    
136  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
137    C Set dimensions:
138          xSize = Nx
139          ySize = Ny
140          useExch2ioLayOut = .FALSE.
141    #ifdef ALLOW_EXCH2
142          IF ( W2_useE2ioLayOut ) THEN
143            xSize = exch2_global_Nx
144            ySize = exch2_global_Ny
145            useExch2ioLayOut = .TRUE.
146          ENDIF
147    #endif /* ALLOW_EXCH2 */
148    
149  C-    default:  C-    default:
150        iGjLoc = 0        iGjLoc = 0
# Line 138  C Assume nothing Line 154  C Assume nothing
154        fileIsOpen = .FALSE.        fileIsOpen = .FALSE.
155        IL  = ILNBLNK( fName )        IL  = ILNBLNK( fName )
156        pIL = ILNBLNK( mdsioLocalDir )        pIL = ILNBLNK( mdsioLocalDir )
157          nNz = 1 + kHi - kLo
158        irecord = ABS(jrecord)        irecord = ABS(jrecord)
159        writeMetaF = jrecord.GT.0        writeMetaF = jrecord.GT.0
160    
161  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):
162        iAmDoingIO = MASTER_CPU_IO(myThid)        iAmDoingIO = MASTER_CPU_IO(myThid)
163    
 C Only do I/O if I am the master thread  
       IF ( iAmDoingIO ) THEN  
   
164  C Record number must be >= 1  C Record number must be >= 1
165          IF (irecord .LT. 1) THEN        IF (irecord .LT. 1) THEN
166           WRITE(msgBuf,'(A,I9.8)')          WRITE(msgBuf,'(3A,I10)')
167       &     ' MDS_WRITE_FIELD: argument irecord = ',irecord       &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
168           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
169       &                       SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid )
170            WRITE(msgBuf,'(A,I9.8)')
171         &    ' MDS_WRITE_FIELD: argument irecord = ',irecord
172            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
173         &                      SQUEEZE_RIGHT , myThid )
174           WRITE(msgBuf,'(A)')           WRITE(msgBuf,'(A)')
175       &     ' MDS_WRITE_FIELD: invalid value for irecord'       &    ' MDS_WRITE_FIELD: invalid value for irecord'
176           CALL PRINT_ERROR( msgBuf, myThid )          CALL PRINT_ERROR( msgBuf, myThid )
177           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'          CALL ALL_PROC_DIE( myThid )
178          ENDIF          STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
179          ENDIF
180    C check for valid sub-set of levels:
181          IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN
182            WRITE(msgBuf,'(3A,I10)')
183         &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
184            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
185         &                      SQUEEZE_RIGHT , myThid )
186            WRITE(msgBuf,'(3(A,I6))')
187         &    ' MDS_WRITE_FIELD: arguments kSize=', kSize,
188         &    ' , kLo=', kLo, ' , kHi=', kHi
189            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
190         &                      SQUEEZE_RIGHT , myThid )
191            WRITE(msgBuf,'(A)')
192         &    ' MDS_WRITE_FIELD: invalid sub-set of levels'
193            CALL PRINT_ERROR( msgBuf, myThid )
194            CALL ALL_PROC_DIE( myThid )
195            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
196          ENDIF
197    C check for 3-D Buffer size:
198          IF ( .NOT.useSingleCpuIO .AND. nNz.GT.size3dBuf ) THEN
199            WRITE(msgBuf,'(3A,I10)')
200         &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
201            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
202         &                      SQUEEZE_RIGHT , myThid )
203            WRITE(msgBuf,'(3(A,I6))')
204         &    ' MDS_WRITE_FIELD: Nb Lev to write =', nNz,
205         &    ' >', size3dBuf, ' = buffer 3rd Dim'
206            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
207         &                      SQUEEZE_RIGHT , myThid )
208            WRITE(msgBuf,'(A)')
209         &    ' MDS_WRITE_FIELD: buffer 3rd Dim. too small'
210            CALL PRINT_ERROR( msgBuf, myThid )
211            WRITE(msgBuf,'(A)')
212         &    ' increase "size3dBuf" in "MDSIO_BUFF_3D.h" and recompile'
213            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
214         &                      SQUEEZE_RIGHT , myThid)
215            CALL ALL_PROC_DIE( myThid )
216            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
217          ENDIF
218    
219    C Only do I/O if I am the master thread
220          IF ( iAmDoingIO ) THEN
221    
222  C Assign special directory  C Assign special directory
223          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 240  C globalFile is too slow, then try using
240  C Master thread of process 0, only, opens a global file  C Master thread of process 0, only, opens a global file
241         IF ( iAmDoingIO ) THEN         IF ( iAmDoingIO ) THEN
242           WRITE(dataFName,'(2a)') fName(1:IL),'.data'           WRITE(dataFName,'(2a)') fName(1:IL),'.data'
243           length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,myThid)           length_of_rec = MDS_RECLEN( filePrec, xSize*ySize, myThid )
244           IF (irecord .EQ. 1) THEN           IF (irecord .EQ. 1) THEN
245            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
246       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
# Line 190  C Master thread of process 0, only, open Line 250  C Master thread of process 0, only, open
250           ENDIF           ENDIF
251         ENDIF         ENDIF
252    
253  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
254         DO k=1,nNz         DO k=kLo,kHi
255            zeroBuff = k.EQ.kLo
256  C-      copy from arr(level=k) to 2-D "local":  C-      copy from arr(level=k) to 2-D "local":
257          IF ( arrType.EQ.'RS' ) THEN          IF ( filePrec.EQ.precFloat32 ) THEN
258            CALL MDS_PASStoRS(sharedLocalBuf,arr,k,zSize,.FALSE.,myThid)            IF ( arrType.EQ.'RS' ) THEN
259          ELSEIF ( arrType.EQ.'RL' ) THEN              CALL MDS_PASS_R4toRS( sharedLocBuf_r4, arr,
260            CALL MDS_PASStoRL(sharedLocalBuf,arr,k,zSize,.FALSE.,myThid)       I                       1, k, kSize, 0, 0, .FALSE., myThid )
261              ELSEIF ( arrType.EQ.'RL' ) THEN
262                CALL MDS_PASS_R4toRL( sharedLocBuf_r4, arr,
263         I                       1, k, kSize, 0, 0, .FALSE., myThid )
264              ELSE
265                WRITE(msgBuf,'(2A)')
266         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
267                CALL PRINT_ERROR( msgBuf, myThid )
268                CALL ALL_PROC_DIE( myThid )
269                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
270              ENDIF
271    C Wait for all threads to finish filling shared buffer
272              CALL BAR2( myThid )
273              CALL GATHER_2D_R4(
274         O                       xy_buffer_r4,
275         I                       sharedLocBuf_r4,
276         I                       xSize, ySize,
277         I                       useExch2ioLayOut, zeroBuff, myThid )
278            ELSEIF ( filePrec.EQ.precFloat64 ) THEN
279              IF ( arrType.EQ.'RS' ) THEN
280                CALL MDS_PASS_R8toRS( sharedLocBuf_r8, arr,
281         I                       1, k, kSize, 0, 0, .FALSE., myThid )
282    
283              ELSEIF ( arrType.EQ.'RL' ) THEN
284                CALL MDS_PASS_R8toRL( sharedLocBuf_r8, arr,
285         I                       1, k, kSize, 0, 0, .FALSE., myThid )
286              ELSE
287                WRITE(msgBuf,'(2A)')
288         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
289                CALL PRINT_ERROR( msgBuf, myThid )
290                CALL ALL_PROC_DIE( myThid )
291                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
292              ENDIF
293    C Wait for all threads to finish filling shared buffer
294              CALL BAR2( myThid )
295              CALL GATHER_2D_R8(
296         O                       xy_buffer_r8,
297         I                       sharedLocBuf_r8,
298         I                       xSize, ySize,
299         I                       useExch2ioLayOut, zeroBuff, myThid )
300          ELSE          ELSE
301            WRITE(msgBuf,'(A)')            WRITE(msgBuf,'(A,I6)')
302       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
303            CALL PRINT_ERROR( msgBuf, myThid )            CALL PRINT_ERROR( msgBuf, myThid )
304              CALL ALL_PROC_DIE( myThid )
305            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
306          ENDIF          ENDIF
307          CALL GATHER_2D( globalBuf, sharedLocalBuf, myThid )  C Make other threads wait for "gather" completion so that after this,
308    C  shared buffer can again be modified by any thread
309            CALL BAR2( myThid )
310    
311          IF ( iAmDoingIO ) THEN          IF ( iAmDoingIO ) THEN
312  #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)            irec = 1 + k-kLo + (irecord-1)*nNz
313            IF (filePrec .EQ. precFloat32) THEN            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  
           ENDIF  
   
           bj=1  
           DO npe=1,nPx*nPy  
            DO bi=1,nSx  
 #ifdef ALLOW_USE_MPI  
             loc_xGlobalLo = mpi_myXGlobalLo(npe)  
             loc_yGlobalLo = mpi_myYGlobalLo(npe)  
 #else  /* ALLOW_USE_MPI */  
             loc_xGlobalLo = myXGlobalLo  
             loc_yGlobalLo = myYGlobalLo  
 #endif /* ALLOW_USE_MPI */  
             tN = W2_mpi_myTileList(npe,bi)  
             IF   ( exch2_mydNx(tN) .GT. x_size ) THEN  
 C-          face x-size larger than glob-size : fold it  
               iGjLoc = 0  
               jGjLoc = exch2_mydNx(tN) / x_size  
             ELSEIF ( exch2_tNy(tN) .GT. y_size ) THEN  
 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  
           ENDIF  
 #endif /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */  
   
           irec=k+nNz*(irecord-1)  
           IF (filePrec .EQ. precFloat32) THEN  
314  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
315             CALL MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )             CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )
316  #endif  #endif
317             WRITE(dUnit,rec=irec) xy_buffer_r4             WRITE(dUnit,rec=irec) ( xy_buffer_r4(i),i=1,xSize*ySize )
318            ELSEIF (filePrec .EQ. precFloat64) THEN            ELSE
319  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
320             CALL MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )             CALL MDS_BYTESWAPR8( xSize*ySize, xy_buffer_r8 )
321  #endif  #endif
322             WRITE(dUnit,rec=irec) xy_buffer_r8             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'  
323            ENDIF            ENDIF
324  C-      end if iAmDoingIO  C-      end if iAmDoingIO
325          ENDIF          ENDIF
# Line 318  C---+----1----+----2----+----3----+----4 Line 335  C---+----1----+----2----+----3----+----4
335  C---  else .NOT.useSingleCpuIO  C---  else .NOT.useSingleCpuIO
336        ELSE        ELSE
337    
338    C---    Copy from arr to 3-D buffer (multi-threads):
339            IF ( filePrec.EQ.precFloat32 ) THEN
340              IF ( arrType.EQ.'RS' ) THEN
341                CALL MDS_PASS_R4toRS( shared3dBuf_r4, arr,
342         I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
343              ELSEIF ( arrType.EQ.'RL' ) THEN
344                CALL MDS_PASS_R4toRL( shared3dBuf_r4, arr,
345         I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
346              ELSE
347                WRITE(msgBuf,'(2A)')
348         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
349                CALL PRINT_ERROR( msgBuf, myThid )
350                CALL ALL_PROC_DIE( myThid )
351                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
352              ENDIF
353            ELSEIF ( filePrec.EQ.precFloat64 ) THEN
354              IF ( arrType.EQ.'RS' ) THEN
355                CALL MDS_PASS_R8toRS( shared3dBuf_r8, arr,
356         I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
357              ELSEIF ( arrType.EQ.'RL' ) THEN
358                CALL MDS_PASS_R8toRL( shared3dBuf_r8, arr,
359         I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
360              ELSE
361                WRITE(msgBuf,'(2A)')
362         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
363                CALL PRINT_ERROR( msgBuf, myThid )
364                CALL ALL_PROC_DIE( myThid )
365                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
366              ENDIF
367            ELSE
368              WRITE(msgBuf,'(A,I6)')
369         &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
370              CALL PRINT_ERROR( msgBuf, myThid )
371              CALL ALL_PROC_DIE( myThid )
372              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
373            ENDIF
374    
375    C Wait for all threads to finish filling shared buffer
376           CALL BAR2( myThid )
377    
378  C Only do I/O if I am the master thread  C Only do I/O if I am the master thread
379         IF ( iAmDoingIO ) THEN         IF ( iAmDoingIO ) THEN
380    
381    #ifdef _BYTESWAPIO
382            IF ( filePrec.EQ.precFloat32 ) THEN
383              CALL MDS_BYTESWAPR4( sNx*sNy*nNz*nSx*nSy, shared3dBuf_r4 )
384            ELSE
385              CALL MDS_BYTESWAPR8( sNx*sNy*nNz*nSx*nSy, shared3dBuf_r8 )
386            ENDIF
387    #endif
388    
389  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
390          IF (globalFile) THEN          IF (globalFile) THEN
391           WRITE(dataFName,'(2a)') fName(1:IL),'.data'            WRITE(dataFName,'(2a)') fName(1:IL),'.data'
392           IF (irecord .EQ. 1) THEN            length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
393            length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )            IF (irecord .EQ. 1) THEN
394            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,             OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
395       &            access='direct', recl=length_of_rec )       &             access='direct', recl=length_of_rec )
396            fileIsOpen=.TRUE.            ELSE
397           ELSE             OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
398            length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )       &             access='direct', recl=length_of_rec )
399            OPEN( dUnit, file=dataFName, status=_OLD_STATUS,            ENDIF
      &            access='direct', recl=length_of_rec )  
400            fileIsOpen=.TRUE.            fileIsOpen=.TRUE.
          ENDIF  
401          ENDIF          ENDIF
402    
403  C Loop over all tiles  C Loop over all tiles
404          DO bj=1,nSy          DO bj=1,nSy
405           DO bi=1,nSx           DO bi=1,nSx
406              bBij = sNx*sNy*nNz*( bi-1 + (bj-1)*nSx )
407    
408              tNx = sNx
409              tNy = sNy
410              global_nTx = xSize/sNx
411              tBx = myXGlobalLo-1 + (bi-1)*sNx
412              tBy = myYGlobalLo-1 + (bj-1)*sNy
413    #ifdef ALLOW_EXCH2
414              IF ( useExch2ioLayOut ) THEN
415                tN = W2_myTileList(bi,bj)
416    c           tNx = exch2_tNx(tN)
417    c           tNy = exch2_tNy(tN)
418    c           global_nTx = exch2_global_Nx/tNx
419                tBx = exch2_txGlobalo(tN) - 1
420                tBy = exch2_tyGlobalo(tN) - 1
421                IF   ( exch2_mydNx(tN) .GT. xSize ) THEN
422    C-          face x-size larger than glob-size : fold it
423                  iGjLoc = 0
424                  jGjLoc = exch2_mydNx(tN) / xSize
425                ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
426    C-          tile y-size larger than glob-size : make a long line
427                  iGjLoc = exch2_mydNx(tN)
428                  jGjLoc = 0
429                ELSE
430    C-          default (face fit into global-IO-array)
431                  iGjLoc = 0
432                  jGjLoc = 1
433                ENDIF
434              ENDIF
435    #endif /* ALLOW_EXCH2 */
436    
437              IF (globalFile) THEN
438    C--- Case of 1 Global file:
439    
440               DO k=kLo,kHi
441                DO j=1,tNy
442                 irec = 1 + ( tBx + (j-1)*iGjLoc )/tNx
443         &                + ( tBy + (j-1)*jGjLoc )*global_nTx
444         &            +( k-kLo + (irecord-1)*nNz )*global_nTx*ySize
445                 i1 = bBij + 1 + (j-1)*sNx + (k-kLo)*sNx*sNy
446                 i2 = bBij +         j*sNx + (k-kLo)*sNx*sNy
447                 IF ( filePrec.EQ.precFloat32 ) THEN
448                  WRITE(dUnit,rec=irec) (shared3dBuf_r4(i),i=i1,i2)
449                 ELSE
450                  WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
451                 ENDIF
452    C End of j,k loops
453                ENDDO
454               ENDDO
455    
456              ELSE
457    C--- Case of 1 file per tile (globalFile=F):
458    
459  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
460            IF (.NOT. globalFile) THEN             iG=bi+(myXGlobalLo-1)/sNx
461             iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles             jG=bj+(myYGlobalLo-1)/sNy
            jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles  
462             WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')             WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
463       &              pfName(1:pIL),'.',iG,'.',jG,'.data'       &            pfName(1:pIL),'.',iG,'.',jG,'.data'
464               length_of_rec = MDS_RECLEN( filePrec, sNx*sNy*nNz, myThid )
465             IF (irecord .EQ. 1) THEN             IF (irecord .EQ. 1) THEN
             length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )  
466              OPEN( dUnit, file=dataFName, status=_NEW_STATUS,              OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
467       &            access='direct', recl=length_of_rec )       &            access='direct', recl=length_of_rec )
             fileIsOpen=.TRUE.  
468             ELSE             ELSE
             length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )  
469              OPEN( dUnit, file=dataFName, status=_OLD_STATUS,              OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
470       &            access='direct', recl=length_of_rec )       &            access='direct', recl=length_of_rec )
             fileIsOpen=.TRUE.  
471             ENDIF             ENDIF
472            ENDIF             fileIsOpen=.TRUE.
473    
474            IF (fileIsOpen) THEN             irec = irecord
475             tNy = sNy             i1 = bBij + 1
476  #ifdef ALLOW_EXCH2             i2 = bBij + sNx*sNy*nNz
477             tN = W2_myTileList(bi)             IF ( filePrec.EQ.precFloat32 ) THEN
478             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. x_size ) THEN  
 C-         face x-size larger than glob-size : fold it  
              iGjLoc = 0  
              jGjLoc = exch2_mydNx(tN) / x_size  
            ELSEIF ( exch2_tNy(tN) .GT. y_size ) THEN  
 C-         tile y-size larger than glob-size : make a long line  
              iGjLoc = exch2_mydNx(tN)  
              jGjLoc = 0  
479             ELSE             ELSE
480  C-         default (face fit into global-IO-array)               WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
              iGjLoc = 0  
              jGjLoc = 1  
481             ENDIF             ENDIF
482  #endif /* ALLOW_EXCH2 */  
483             DO k=1,nNz  C here We close the tiled MDS file
484              DO j=1,tNy             IF ( fileIsOpen ) THEN
485               IF (globalFile) THEN               CLOSE( dUnit )
486  #ifdef ALLOW_EXCH2               fileIsOpen = .FALSE.
487                irec = 1 + ( tGx-1 + (j-1)*iGjLoc )/tNx             ENDIF
488       &                 + ( tGy-1 + (j-1)*jGjLoc )*exch2_domain_nxt  
489       &                 + ( k-1 + (irecord-1)*nNz  C--- End Global File / tile-file cases
      &                   )*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  
              IF (filePrec .EQ. precFloat32) THEN  
               IF (arrType .EQ. 'RS') THEN  
                CALL MDS_SEG4toRS( j,bi,bj,k,zSize, r4seg,.FALSE.,arr )  
               ELSEIF (arrType .EQ. 'RL') THEN  
                CALL MDS_SEG4toRL( j,bi,bj,k,zSize, 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,zSize, r8seg,.FALSE.,arr )  
               ELSEIF (arrType .EQ. 'RL') THEN  
                CALL MDS_SEG8toRL( j,bi,bj,k,zSize, 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.  
490            ENDIF            ENDIF
491    
492  C Create meta-file for each tile if we are tiling  C Create meta-file for each tile if we are tiling
493            IF ( .NOT.globalFile .AND. writeMetaF ) THEN            IF ( .NOT.globalFile .AND. writeMetaF ) THEN
494             iG=bi+(myXGlobalLo-1)/sNx             iG=bi+(myXGlobalLo-1)/sNx
495             jG=bj+(myYGlobalLo-1)/sNy             jG=bj+(myYGlobalLo-1)/sNy
496             WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')             WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')
497       &              pfName(1:pIL),'.',iG,'.',jG,'.meta'       &              pfName(1:pIL),'.',iG,'.',jG,'.meta'
498  #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)             dimList(1,1) = xSize
499             tN = W2_myTileList(bi)             dimList(2,1) = tBx + 1
500             dimList(1,1)=x_size             dimList(3,1) = tBx + tNx
501             dimList(2,1)=exch2_txGlobalo(tN)             dimList(1,2) = ySize
502             dimList(3,1)=exch2_txGlobalo(tN)+sNx-1             dimList(2,2) = tBy + 1
503             dimList(1,2)=y_size             dimList(3,2) = tBy + tNy
504             dimList(2,2)=exch2_tyGlobalo(tN)             dimList(1,3) = nNz
505             dimList(3,2)=exch2_tyGlobalo(tN)+sNy-1             dimList(2,3) = 1
506  #else /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */             dimList(3,3) = nNz
507  C- jmc: if MISSING_TILE_IO, keep meta files unchanged  c          dimList(1,3) = kSize
508  C       to stay consistent with global file structure  c          dimList(2,3) = kLo
509             dimList(1,1)=Nx  c          dimList(3,3) = kHi
510             dimList(2,1)=myXGlobalLo+(bi-1)*sNx             nDims = 3
511             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  
512             map2gl(1) = iGjLoc             map2gl(1) = iGjLoc
513             map2gl(2) = jGjLoc             map2gl(2) = jGjLoc
514             CALL MDS_WRITE_META(             CALL MDS_WRITE_META(
515       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
516       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims, dimList, map2gl, 0, blank8c,
517       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, dummyRL, irecord, myIter, myThid )
518            ENDIF            ENDIF
519    
520  C End of bi,bj loops  C End of bi,bj loops
521           ENDDO           ENDDO
522          ENDDO          ENDDO
523    
524  C If global file was opened then close it  C If global file was opened then close it
525          IF (fileIsOpen .AND. globalFile) THEN          IF (fileIsOpen .AND. globalFile) THEN
526           CLOSE( dUnit )            CLOSE( dUnit )
527           fileIsOpen = .FALSE.            fileIsOpen = .FALSE.
528          ENDIF          ENDIF
529    
530  C- endif iAmDoingIO  C- endif iAmDoingIO
531         ENDIF         ENDIF
532    
533    C Make other threads wait for I/O completion so that after this,
534    C  3-D buffer can again be modified by any thread
535           CALL BAR2( myThid )
536    
537  C     if useSingleCpuIO / else / end  C     if useSingleCpuIO / else / end
538        ENDIF        ENDIF
539    
# Line 507  C Create meta-file for the global-file ( Line 541  C Create meta-file for the global-file (
541        IF ( writeMetaF .AND. iAmDoingIO .AND.        IF ( writeMetaF .AND. iAmDoingIO .AND.
542       &    (globalFile .OR. useSingleCpuIO) ) THEN       &    (globalFile .OR. useSingleCpuIO) ) THEN
543           WRITE(metaFName,'(2A)') fName(1:IL),'.meta'           WRITE(metaFName,'(2A)') fName(1:IL),'.meta'
544           dimList(1,1)=x_size           dimList(1,1) = xSize
545           dimList(2,1)=1           dimList(2,1) = 1
546           dimList(3,1)=x_size           dimList(3,1) = xSize
547           dimList(1,2)=y_size           dimList(1,2) = ySize
548           dimList(2,2)=1           dimList(2,2) = 1
549           dimList(3,2)=y_size           dimList(3,2) = ySize
550           dimList(1,3)=nNz           dimList(1,3) = nNz
551           dimList(2,3)=1           dimList(2,3) = 1
552           dimList(3,3)=nNz           dimList(3,3) = nNz
553           nDims=3  c        dimList(1,3) = kSize
554           IF ( nNz.EQ.1 ) nDims=2  c        dimList(2,3) = kLo
555           map2gl(1) = iGjLoc  c        dimList(3,3) = kHi
556           map2gl(2) = jGjLoc           nDims = 3
557             IF ( nNz.EQ.1 ) nDims = 2
558             map2gl(1) = 0
559             map2gl(2) = 1
560           CALL MDS_WRITE_META(           CALL MDS_WRITE_META(
561       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
562       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims, dimList, map2gl, 0, blank8c,
563       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, dummyRL, irecord, myIter, myThid )
564  c    I              metaFName, dataFName, the_run_name, titleLine,  c    I              metaFName, dataFName, the_run_name, titleLine,
565  c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,  c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,
566  c    I              nTimRec, timList, irecord, myIter, myThid )  c    I              nTimRec, timList, irecord, myIter, myThid )
567        ENDIF        ENDIF
568    
 C To be safe, make other processes wait for I/O completion  
       _BARRIER  
   
569  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
570        RETURN        RETURN
571        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.15
  ViewVC Help
Powered by ViewVC 1.1.22