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