/[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.4 by jmc, Tue Nov 13 19:37:44 2007 UTC revision 1.17 by jmc, Thu Dec 23 02:41:47 2010 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 57  C  routine arguments and file, i.e., if Line 57  C  routine arguments and file, i.e., if
57  C  the meta information will record the number of records to be 2. This,  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.  C  again, is because we have read the meta information. To be fixed.
59  C  C
60    C- Multi-threaded: Only Master thread does IO (and MPI calls) and get data
61    C   from a shared buffer that any thread can copy to.
62    C- Convention regarding thread synchronisation (BARRIER):
63    C  A per-thread (or per tile) partition of the 2-D shared-buffer (sharedLocBuf_r4/r8)
64    C   is readily available => any access (e.g., by master-thread) to a portion
65    C   owned by an other thread is put between BARRIER (protected).
66    C  No thread partition exist for the 3-D shared buffer (shared3dBuf_r4/r8);
67    C   Therefore, the 3-D buffer is considered to be owned by master-thread and
68    C   any access by other than master thread is put between BARRIER (protected).
69    C
70  C Created: 03/16/99 adcroft@mit.edu  C Created: 03/16/99 adcroft@mit.edu
71  C Changed: 01/06/02 menemenlis@jpl.nasa.gov  C Changed: 01/06/02 menemenlis@jpl.nasa.gov
72  C          added useSingleCpuIO hack  C          added useSingleCpuIO hack
# Line 69  C !USES: Line 79  C !USES:
79  C Global variables / common blocks  C Global variables / common blocks
80  #include "SIZE.h"  #include "SIZE.h"
81  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "EESUPPORT.h"  
82  #include "PARAMS.h"  #include "PARAMS.h"
83  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
84  #include "W2_EXCH2_TOPOLOGY.h"  # include "W2_EXCH2_SIZE.h"
85  #include "W2_EXCH2_PARAMS.h"  # include "W2_EXCH2_TOPOLOGY.h"
86    # include "W2_EXCH2_PARAMS.h"
87  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
88  #include "MDSIO_SCPU.h"  #include "EEBUFF_SCPU.h"
89    #ifdef ALLOW_FIZHI
90    # include "fizhi_SIZE.h"
91    #endif /* ALLOW_FIZHI */
92    #include "MDSIO_BUFF_3D.h"
93    
94  C !INPUT PARAMETERS:  C !INPUT PARAMETERS:
95        CHARACTER*(*) fName        CHARACTER*(*) fName
# Line 84  C !INPUT PARAMETERS: Line 98  C !INPUT PARAMETERS:
98        LOGICAL useCurrentDir        LOGICAL useCurrentDir
99        CHARACTER*(2) arrType        CHARACTER*(2) arrType
100        INTEGER kSize, kLo, kHi        INTEGER kSize, kLo, kHi
101  cph(        _RL fldRL(*)
102  cph      Real arr(*)        _RS fldRS(*)
       _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,kSize,nSx,nSy)  
 cph)  
103        INTEGER jrecord        INTEGER jrecord
104        INTEGER myIter        INTEGER myIter
105        INTEGER myThid        INTEGER myThid
# Line 102  C !FUNCTIONS Line 114  C !FUNCTIONS
114        EXTERNAL MASTER_CPU_IO        EXTERNAL MASTER_CPU_IO
115    
116  C !LOCAL VARIABLES:  C !LOCAL VARIABLES:
117    C     bBij  :: base shift in Buffer index for tile bi,bj
118        CHARACTER*(MAX_LEN_FNAM) dataFName,metaFName,pfName        CHARACTER*(MAX_LEN_FNAM) dataFName,metaFName,pfName
119        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
120        LOGICAL fileIsOpen        LOGICAL fileIsOpen
121        LOGICAL iAmDoingIO        LOGICAL iAmDoingIO
122        LOGICAL writeMetaF        LOGICAL writeMetaF
123          LOGICAL useExch2ioLayOut
124          LOGICAL zeroBuff
125          INTEGER xSize, ySize
126        INTEGER irecord        INTEGER irecord
127        INTEGER iG,jG,bi,bj,i,j,k,nNz        INTEGER iG,jG,bi,bj
128          INTEGER i1,i2,i,j,k,nNz
129        INTEGER irec,dUnit,IL,pIL        INTEGER irec,dUnit,IL,pIL
130        INTEGER dimList(3,3), nDims, map2gl(2)        INTEGER dimList(3,3), nDims, map2gl(2)
131        INTEGER iGjLoc, jGjLoc        INTEGER length_of_rec
132        INTEGER x_size,y_size,length_of_rec        INTEGER bBij
133  #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)        INTEGER tNx, tNy, global_nTx
134        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)  
135  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
136  c     INTEGER tGy,tGx,tNy,tNx,tN        INTEGER tN
       INTEGER tGy,tGx,    tNx,tN  
137  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
138        INTEGER tNy        _RL dummyRL(1)
139          CHARACTER*8 blank8c
140    
141          DATA dummyRL(1) / 0. _d 0 /
142          DATA blank8c / '        ' /
143    
144  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
145    C Set dimensions:
146          xSize = Nx
147          ySize = Ny
148          useExch2ioLayOut = .FALSE.
149    #ifdef ALLOW_EXCH2
150          IF ( W2_useE2ioLayOut ) THEN
151            xSize = exch2_global_Nx
152            ySize = exch2_global_Ny
153            useExch2ioLayOut = .TRUE.
154          ENDIF
155    #endif /* ALLOW_EXCH2 */
156    
157  C-    default:  C-    default:
158        iGjLoc = 0        iGjLoc = 0
# Line 149  C Assume nothing Line 169  C Assume nothing
169  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):
170        iAmDoingIO = MASTER_CPU_IO(myThid)        iAmDoingIO = MASTER_CPU_IO(myThid)
171    
 C Only do I/O if I am the master thread  
       IF ( iAmDoingIO ) THEN  
   
172  C Record number must be >= 1  C Record number must be >= 1
173          IF (irecord .LT. 1) THEN        IF (irecord .LT. 1) THEN
174           WRITE(msgBuf,'(A,I9.8)')          WRITE(msgBuf,'(3A,I10)')
175       &     ' MDS_WRITE_FIELD: argument irecord = ',irecord       &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
176           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
177       &                       SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid )
178            WRITE(msgBuf,'(A,I9.8)')
179         &    ' MDS_WRITE_FIELD: argument irecord = ',irecord
180            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
181         &                      SQUEEZE_RIGHT , myThid )
182           WRITE(msgBuf,'(A)')           WRITE(msgBuf,'(A)')
183       &     ' MDS_WRITE_FIELD: invalid value for irecord'       &    ' MDS_WRITE_FIELD: invalid value for irecord'
184           CALL PRINT_ERROR( msgBuf, myThid )          CALL PRINT_ERROR( msgBuf, myThid )
185           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'          CALL ALL_PROC_DIE( myThid )
186          ENDIF          STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
187          ENDIF
188  C check for valid sub-set of levels:  C check for valid sub-set of levels:
189          IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN        IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN
190           WRITE(msgBuf,'(3(A,I6))')          WRITE(msgBuf,'(3A,I10)')
191       &     ' MDS_WRITE_FIELD: arguments kSize=', kSize,       &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
192       &     ' , kLo=', kLo, ' , kHi=', kHi          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
193           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,       &                      SQUEEZE_RIGHT , myThid )
194       &                       SQUEEZE_RIGHT , myThid)          WRITE(msgBuf,'(3(A,I6))')
195           WRITE(msgBuf,'(A)')       &    ' MDS_WRITE_FIELD: arguments kSize=', kSize,
196       &     ' MDS_WRITE_FIELD: invalid sub-set of levels'       &    ' , kLo=', kLo, ' , kHi=', kHi
197           CALL PRINT_ERROR( msgBuf, myThid )          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
198           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'       &                      SQUEEZE_RIGHT , myThid )
199          ENDIF          WRITE(msgBuf,'(A)')
200         &    ' MDS_WRITE_FIELD: invalid sub-set of levels'
201            CALL PRINT_ERROR( msgBuf, myThid )
202            CALL ALL_PROC_DIE( myThid )
203            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
204          ENDIF
205    C check for 3-D Buffer size:
206          IF ( .NOT.useSingleCpuIO .AND. nNz.GT.size3dBuf ) THEN
207            WRITE(msgBuf,'(3A,I10)')
208         &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
209            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
210         &                      SQUEEZE_RIGHT , myThid )
211            WRITE(msgBuf,'(3(A,I6))')
212         &    ' MDS_WRITE_FIELD: Nb Lev to write =', nNz,
213         &    ' >', size3dBuf, ' = buffer 3rd Dim'
214            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
215         &                      SQUEEZE_RIGHT , myThid )
216            WRITE(msgBuf,'(A)')
217         &    ' MDS_WRITE_FIELD: buffer 3rd Dim. too small'
218            CALL PRINT_ERROR( msgBuf, myThid )
219            WRITE(msgBuf,'(A)')
220         &    ' increase "size3dBuf" in "MDSIO_BUFF_3D.h" and recompile'
221            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
222         &                      SQUEEZE_RIGHT , myThid)
223            CALL ALL_PROC_DIE( myThid )
224            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
225          ENDIF
226    
227    C Only do I/O if I am the master thread
228          IF ( iAmDoingIO ) THEN
229    
230  C Assign special directory  C Assign special directory
231          IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN          IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN
# Line 197  C globalFile is too slow, then try using Line 248  C globalFile is too slow, then try using
248  C Master thread of process 0, only, opens a global file  C Master thread of process 0, only, opens a global file
249         IF ( iAmDoingIO ) THEN         IF ( iAmDoingIO ) THEN
250           WRITE(dataFName,'(2a)') fName(1:IL),'.data'           WRITE(dataFName,'(2a)') fName(1:IL),'.data'
251           length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,myThid)           length_of_rec = MDS_RECLEN( filePrec, xSize*ySize, myThid )
252           IF (irecord .EQ. 1) THEN           IF (irecord .EQ. 1) THEN
253            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
254       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
# Line 207  C Master thread of process 0, only, open Line 258  C Master thread of process 0, only, open
258           ENDIF           ENDIF
259         ENDIF         ENDIF
260    
261  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
262         DO k=kLo,kHi         DO k=kLo,kHi
263  C-      copy from arr(level=k) to 2-D "local":          zeroBuff = k.EQ.kLo
264          IF ( arrType.EQ.'RS' ) THEN  C-      copy from fldRL/RS(level=k) to 2-D "local":
265            CALL MDS_PASStoRS(sharedLocalBuf,arr,k,kSize,.FALSE.,myThid)          IF ( filePrec.EQ.precFloat32 ) THEN
266          ELSEIF ( arrType.EQ.'RL' ) THEN            IF ( arrType.EQ.'RS' ) THEN
267            CALL MDS_PASStoRL(sharedLocalBuf,arr,k,kSize,.FALSE.,myThid)              CALL MDS_PASS_R4toRS( sharedLocBuf_r4, fldRS,
268         I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
269              ELSEIF ( arrType.EQ.'RL' ) THEN
270                CALL MDS_PASS_R4toRL( sharedLocBuf_r4, fldRL,
271         I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
272              ELSE
273                WRITE(msgBuf,'(2A)')
274         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
275                CALL PRINT_ERROR( msgBuf, myThid )
276                CALL ALL_PROC_DIE( myThid )
277                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
278              ENDIF
279    C Wait for all threads to finish filling shared buffer
280              CALL BAR2( myThid )
281              CALL GATHER_2D_R4(
282         O                       xy_buffer_r4,
283         I                       sharedLocBuf_r4,
284         I                       xSize, ySize,
285         I                       useExch2ioLayOut, zeroBuff, myThid )
286            ELSEIF ( filePrec.EQ.precFloat64 ) THEN
287              IF ( arrType.EQ.'RS' ) THEN
288                CALL MDS_PASS_R8toRS( sharedLocBuf_r8, fldRS,
289         I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
290              ELSEIF ( arrType.EQ.'RL' ) THEN
291                CALL MDS_PASS_R8toRL( sharedLocBuf_r8, fldRL,
292         I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
293              ELSE
294                WRITE(msgBuf,'(2A)')
295         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
296                CALL PRINT_ERROR( msgBuf, myThid )
297                CALL ALL_PROC_DIE( myThid )
298                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
299              ENDIF
300    C Wait for all threads to finish filling shared buffer
301              CALL BAR2( myThid )
302              CALL GATHER_2D_R8(
303         O                       xy_buffer_r8,
304         I                       sharedLocBuf_r8,
305         I                       xSize, ySize,
306         I                       useExch2ioLayOut, zeroBuff, myThid )
307          ELSE          ELSE
308            WRITE(msgBuf,'(A)')            WRITE(msgBuf,'(A,I6)')
309       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
310            CALL PRINT_ERROR( msgBuf, myThid )            CALL PRINT_ERROR( msgBuf, myThid )
311              CALL ALL_PROC_DIE( myThid )
312            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
313          ENDIF          ENDIF
314          CALL GATHER_2D( globalBuf, sharedLocalBuf, myThid )  C Make other threads wait for "gather" completion so that after this,
315    C  shared buffer can again be modified by any thread
316            CALL BAR2( myThid )
317    
318          IF ( iAmDoingIO ) THEN          IF ( iAmDoingIO ) THEN
319  #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)            irec = 1 + k-kLo + (irecord-1)*nNz
320            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+1-kLo+nNz*(irecord-1)  
           IF (filePrec .EQ. precFloat32) THEN  
321  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
322             CALL MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )             CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )
323  #endif  #endif
324             WRITE(dUnit,rec=irec) xy_buffer_r4             WRITE(dUnit,rec=irec) ( xy_buffer_r4(i),i=1,xSize*ySize )
325            ELSEIF (filePrec .EQ. precFloat64) THEN            ELSE
326  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
327             CALL MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )             CALL MDS_BYTESWAPR8( xSize*ySize, xy_buffer_r8 )
328  #endif  #endif
329             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'  
330            ENDIF            ENDIF
331  C-      end if iAmDoingIO  C-      end if iAmDoingIO
332          ENDIF          ENDIF
# Line 335  C---+----1----+----2----+----3----+----4 Line 342  C---+----1----+----2----+----3----+----4
342  C---  else .NOT.useSingleCpuIO  C---  else .NOT.useSingleCpuIO
343        ELSE        ELSE
344    
345    C Wait for all thread to finish. This prevents other threads (e.g., master)
346    C  to continue to acces 3-D buffer while this thread is filling it.
347            CALL BAR2( myThid )
348    
349    C---    Copy from fldRL/RS to 3-D buffer (multi-threads):
350            IF ( filePrec.EQ.precFloat32 ) THEN
351              IF ( arrType.EQ.'RS' ) THEN
352                CALL MDS_PASS_R4toRS( shared3dBuf_r4, fldRS,
353         I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
354              ELSEIF ( arrType.EQ.'RL' ) THEN
355                CALL MDS_PASS_R4toRL( shared3dBuf_r4, fldRL,
356         I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
357              ELSE
358                WRITE(msgBuf,'(2A)')
359         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
360                CALL PRINT_ERROR( msgBuf, myThid )
361                CALL ALL_PROC_DIE( myThid )
362                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
363              ENDIF
364            ELSEIF ( filePrec.EQ.precFloat64 ) THEN
365              IF ( arrType.EQ.'RS' ) THEN
366                CALL MDS_PASS_R8toRS( shared3dBuf_r8, fldRS,
367         I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
368              ELSEIF ( arrType.EQ.'RL' ) THEN
369                CALL MDS_PASS_R8toRL( shared3dBuf_r8, fldRL,
370         I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
371              ELSE
372                WRITE(msgBuf,'(2A)')
373         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
374                CALL PRINT_ERROR( msgBuf, myThid )
375                CALL ALL_PROC_DIE( myThid )
376                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
377              ENDIF
378            ELSE
379              WRITE(msgBuf,'(A,I6)')
380         &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
381              CALL PRINT_ERROR( msgBuf, myThid )
382              CALL ALL_PROC_DIE( myThid )
383              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
384            ENDIF
385    
386    C Wait for all threads to finish filling shared buffer
387           CALL BAR2( myThid )
388    
389  C Only do I/O if I am the master thread  C Only do I/O if I am the master thread
390         IF ( iAmDoingIO ) THEN         IF ( iAmDoingIO ) THEN
391    
392    #ifdef _BYTESWAPIO
393            IF ( filePrec.EQ.precFloat32 ) THEN
394              CALL MDS_BYTESWAPR4( sNx*sNy*nNz*nSx*nSy, shared3dBuf_r4 )
395            ELSE
396              CALL MDS_BYTESWAPR8( sNx*sNy*nNz*nSx*nSy, shared3dBuf_r8 )
397            ENDIF
398    #endif
399    
400  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
401          IF (globalFile) THEN          IF (globalFile) THEN
402           WRITE(dataFName,'(2a)') fName(1:IL),'.data'            WRITE(dataFName,'(2a)') fName(1:IL),'.data'
403           IF (irecord .EQ. 1) THEN            length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
404            length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )            IF (irecord .EQ. 1) THEN
405            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,             OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
406       &            access='direct', recl=length_of_rec )       &             access='direct', recl=length_of_rec )
407            fileIsOpen=.TRUE.            ELSE
408           ELSE             OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
409            length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )       &             access='direct', recl=length_of_rec )
410            OPEN( dUnit, file=dataFName, status=_OLD_STATUS,            ENDIF
      &            access='direct', recl=length_of_rec )  
411            fileIsOpen=.TRUE.            fileIsOpen=.TRUE.
          ENDIF  
412          ENDIF          ENDIF
413    
414  C Loop over all tiles  C Loop over all tiles
415          DO bj=1,nSy          DO bj=1,nSy
416           DO bi=1,nSx           DO bi=1,nSx
417              bBij = sNx*sNy*nNz*( bi-1 + (bj-1)*nSx )
418    
419              tNx = sNx
420              tNy = sNy
421              global_nTx = xSize/sNx
422              tBx = myXGlobalLo-1 + (bi-1)*sNx
423              tBy = myYGlobalLo-1 + (bj-1)*sNy
424    #ifdef ALLOW_EXCH2
425              IF ( useExch2ioLayOut ) THEN
426                tN = W2_myTileList(bi,bj)
427    c           tNx = exch2_tNx(tN)
428    c           tNy = exch2_tNy(tN)
429    c           global_nTx = exch2_global_Nx/tNx
430                tBx = exch2_txGlobalo(tN) - 1
431                tBy = exch2_tyGlobalo(tN) - 1
432                IF   ( exch2_mydNx(tN) .GT. xSize ) THEN
433    C-          face x-size larger than glob-size : fold it
434                  iGjLoc = 0
435                  jGjLoc = exch2_mydNx(tN) / xSize
436                ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
437    C-          tile y-size larger than glob-size : make a long line
438                  iGjLoc = exch2_mydNx(tN)
439                  jGjLoc = 0
440                ELSE
441    C-          default (face fit into global-IO-array)
442                  iGjLoc = 0
443                  jGjLoc = 1
444                ENDIF
445              ENDIF
446    #endif /* ALLOW_EXCH2 */
447    
448              IF (globalFile) THEN
449    C--- Case of 1 Global file:
450    
451               DO k=kLo,kHi
452                DO j=1,tNy
453                 irec = 1 + ( tBx + (j-1)*iGjLoc )/tNx
454         &                + ( tBy + (j-1)*jGjLoc )*global_nTx
455         &            +( k-kLo + (irecord-1)*nNz )*global_nTx*ySize
456                 i1 = bBij + 1 + (j-1)*sNx + (k-kLo)*sNx*sNy
457                 i2 = bBij +         j*sNx + (k-kLo)*sNx*sNy
458                 IF ( filePrec.EQ.precFloat32 ) THEN
459                  WRITE(dUnit,rec=irec) (shared3dBuf_r4(i),i=i1,i2)
460                 ELSE
461                  WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
462                 ENDIF
463    C End of j,k loops
464                ENDDO
465               ENDDO
466    
467              ELSE
468    C--- Case of 1 file per tile (globalFile=F):
469    
470  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
471            IF (.NOT. globalFile) THEN             iG=bi+(myXGlobalLo-1)/sNx
472             iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles             jG=bj+(myYGlobalLo-1)/sNy
            jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles  
473             WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')             WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
474       &              pfName(1:pIL),'.',iG,'.',jG,'.data'       &            pfName(1:pIL),'.',iG,'.',jG,'.data'
475               length_of_rec = MDS_RECLEN( filePrec, sNx*sNy*nNz, myThid )
476             IF (irecord .EQ. 1) THEN             IF (irecord .EQ. 1) THEN
             length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )  
477              OPEN( dUnit, file=dataFName, status=_NEW_STATUS,              OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
478       &            access='direct', recl=length_of_rec )       &            access='direct', recl=length_of_rec )
             fileIsOpen=.TRUE.  
479             ELSE             ELSE
             length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )  
480              OPEN( dUnit, file=dataFName, status=_OLD_STATUS,              OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
481       &            access='direct', recl=length_of_rec )       &            access='direct', recl=length_of_rec )
             fileIsOpen=.TRUE.  
482             ENDIF             ENDIF
483            ENDIF             fileIsOpen=.TRUE.
484    
485            IF (fileIsOpen) THEN             irec = irecord
486             tNy = sNy             i1 = bBij + 1
487  #ifdef ALLOW_EXCH2             i2 = bBij + sNx*sNy*nNz
488             tN = W2_myTileList(bi)             IF ( filePrec.EQ.precFloat32 ) THEN
489             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  
490             ELSE             ELSE
491  C-         default (face fit into global-IO-array)               WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
              iGjLoc = 0  
              jGjLoc = 1  
492             ENDIF             ENDIF
493  #endif /* ALLOW_EXCH2 */  
494             DO k=1,nNz  C here We close the tiled MDS file
495              DO j=1,tNy             IF ( fileIsOpen ) THEN
496               IF (globalFile) THEN               CLOSE( dUnit )
497  #ifdef ALLOW_EXCH2               fileIsOpen = .FALSE.
498                irec = 1 + ( tGx-1 + (j-1)*iGjLoc )/tNx             ENDIF
499       &                 + ( tGy-1 + (j-1)*jGjLoc )*exch2_domain_nxt  
500       &                 + ( k-kLo + (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-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.  
501            ENDIF            ENDIF
502    
503  C Create meta-file for each tile if we are tiling  C Create meta-file for each tile if we are tiling
504            IF ( .NOT.globalFile .AND. writeMetaF ) THEN            IF ( .NOT.globalFile .AND. writeMetaF ) THEN
505             iG=bi+(myXGlobalLo-1)/sNx             iG=bi+(myXGlobalLo-1)/sNx
506             jG=bj+(myYGlobalLo-1)/sNy             jG=bj+(myYGlobalLo-1)/sNy
507             WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')             WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')
508       &              pfName(1:pIL),'.',iG,'.',jG,'.meta'       &              pfName(1:pIL),'.',iG,'.',jG,'.meta'
509  #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)             dimList(1,1) = xSize
510             tN = W2_myTileList(bi)             dimList(2,1) = tBx + 1
511             dimList(1,1)=x_size             dimList(3,1) = tBx + tNx
512             dimList(2,1)=exch2_txGlobalo(tN)             dimList(1,2) = ySize
513             dimList(3,1)=exch2_txGlobalo(tN)+sNx-1             dimList(2,2) = tBy + 1
514             dimList(1,2)=y_size             dimList(3,2) = tBy + tNy
515             dimList(2,2)=exch2_tyGlobalo(tN)             dimList(1,3) = nNz
516             dimList(3,2)=exch2_tyGlobalo(tN)+sNy-1             dimList(2,3) = 1
517  #else /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */             dimList(3,3) = nNz
518  C- jmc: if MISSING_TILE_IO, keep meta files unchanged  c          dimList(1,3) = kSize
519  C       to stay consistent with global file structure  c          dimList(2,3) = kLo
520             dimList(1,1)=Nx  c          dimList(3,3) = kHi
521             dimList(2,1)=myXGlobalLo+(bi-1)*sNx             nDims = 3
522             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  
523             map2gl(1) = iGjLoc             map2gl(1) = iGjLoc
524             map2gl(2) = jGjLoc             map2gl(2) = jGjLoc
525             CALL MDS_WRITE_META(             CALL MDS_WRITE_META(
526       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
527       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims, dimList, map2gl, 0, blank8c,
528       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, dummyRL, irecord, myIter, myThid )
529            ENDIF            ENDIF
530    
531  C End of bi,bj loops  C End of bi,bj loops
532           ENDDO           ENDDO
533          ENDDO          ENDDO
534    
535  C If global file was opened then close it  C If global file was opened then close it
536          IF (fileIsOpen .AND. globalFile) THEN          IF (fileIsOpen .AND. globalFile) THEN
537           CLOSE( dUnit )            CLOSE( dUnit )
538           fileIsOpen = .FALSE.            fileIsOpen = .FALSE.
539          ENDIF          ENDIF
540    
541  C- endif iAmDoingIO  C- endif iAmDoingIO
542         ENDIF         ENDIF
543    
544    C Make other threads wait for I/O completion so that after this,
545    C  3-D buffer can again be modified by any thread
546    c      CALL BAR2( myThid )
547    
548  C     if useSingleCpuIO / else / end  C     if useSingleCpuIO / else / end
549        ENDIF        ENDIF
550    
# Line 524  C Create meta-file for the global-file ( Line 552  C Create meta-file for the global-file (
552        IF ( writeMetaF .AND. iAmDoingIO .AND.        IF ( writeMetaF .AND. iAmDoingIO .AND.
553       &    (globalFile .OR. useSingleCpuIO) ) THEN       &    (globalFile .OR. useSingleCpuIO) ) THEN
554           WRITE(metaFName,'(2A)') fName(1:IL),'.meta'           WRITE(metaFName,'(2A)') fName(1:IL),'.meta'
555           dimList(1,1)=x_size           dimList(1,1) = xSize
556           dimList(2,1)=1           dimList(2,1) = 1
557           dimList(3,1)=x_size           dimList(3,1) = xSize
558           dimList(1,2)=y_size           dimList(1,2) = ySize
559           dimList(2,2)=1           dimList(2,2) = 1
560           dimList(3,2)=y_size           dimList(3,2) = ySize
561           dimList(1,3)=nNz           dimList(1,3) = nNz
562           dimList(2,3)=1           dimList(2,3) = 1
563           dimList(3,3)=nNz           dimList(3,3) = nNz
564           nDims=3  c        dimList(1,3) = kSize
565           IF ( nNz.EQ.1 ) nDims=2  c        dimList(2,3) = kLo
566    c        dimList(3,3) = kHi
567             nDims = 3
568             IF ( nNz.EQ.1 ) nDims = 2
569           map2gl(1) = 0           map2gl(1) = 0
570           map2gl(2) = 1           map2gl(2) = 1
571           CALL MDS_WRITE_META(           CALL MDS_WRITE_META(
572       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
573       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims, dimList, map2gl, 0, blank8c,
574       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, dummyRL, irecord, myIter, myThid )
575  c    I              metaFName, dataFName, the_run_name, titleLine,  c    I              metaFName, dataFName, the_run_name, titleLine,
576  c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,  c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,
577  c    I              nTimRec, timList, irecord, myIter, myThid )  c    I              nTimRec, timList, irecord, myIter, myThid )
578        ENDIF        ENDIF
579    
 C To be safe, make other processes wait for I/O completion  
       _BARRIER  
   
580  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
581        RETURN        RETURN
582        END        END
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.17
  ViewVC Help
Powered by ViewVC 1.1.22