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