/[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.10 by jmc, Mon Jun 1 14:20:31 2009 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 71  C Global variables / common blocks Line 81  C Global variables / common blocks
81  #include "EEPARAMS.h"  #include "EEPARAMS.h"
82  #include "PARAMS.h"  #include "PARAMS.h"
83  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
84  #include "W2_EXCH2_SIZE.h"  # include "W2_EXCH2_SIZE.h"
85  #include "W2_EXCH2_TOPOLOGY.h"  # include "W2_EXCH2_TOPOLOGY.h"
86  #include "W2_EXCH2_PARAMS.h"  # include "W2_EXCH2_PARAMS.h"
87  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
88  #include "EEBUFF_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
# Line 111  C !LOCAL VARIABLES: Line 124  C !LOCAL VARIABLES:
124        LOGICAL zeroBuff        LOGICAL zeroBuff
125        INTEGER xSize, ySize        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 length_of_rec        INTEGER length_of_rec
132        Real*4 r4seg(sNx)        INTEGER bBij
       Real*8 r8seg(sNx)  
       Real*4 r4loc(sNx,sNy)  
       Real*8 r8loc(sNx,sNy)  
133        INTEGER tNx, tNy, global_nTx        INTEGER tNx, tNy, global_nTx
134        INTEGER tBx, tBy, iGjLoc, jGjLoc        INTEGER tBx, tBy, iGjLoc, jGjLoc
135  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
136        INTEGER tN        INTEGER tN
137  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
138          _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:  C Set dimensions:
# Line 153  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 211  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          zeroBuff = k.EQ.kLo          zeroBuff = k.EQ.kLo
264  C-      copy from arr(level=k) to 2-D "local":  C-      copy from fldRL/RS(level=k) to 2-D "local":
265          IF ( filePrec.EQ.precFloat32 ) THEN          IF ( filePrec.EQ.precFloat32 ) THEN
266            IF ( arrType.EQ.'RS' ) THEN            IF ( arrType.EQ.'RS' ) THEN
267              CALL MDS_PASS_R4toRS( sharedLocBuf_r4, arr,              CALL MDS_PASS_R4toRS( sharedLocBuf_r4, fldRS,
268       I                            k, kSize, 0,0, .FALSE., myThid )       I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
269            ELSEIF ( arrType.EQ.'RL' ) THEN            ELSEIF ( arrType.EQ.'RL' ) THEN
270              CALL MDS_PASS_R4toRL( sharedLocBuf_r4, arr,              CALL MDS_PASS_R4toRL( sharedLocBuf_r4, fldRL,
271       I                            k, kSize, 0,0, .FALSE., myThid )       I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
272            ELSE            ELSE
273              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(2A)')
274       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
275              CALL PRINT_ERROR( msgBuf, myThid )              CALL PRINT_ERROR( msgBuf, myThid )
276                CALL ALL_PROC_DIE( myThid )
277              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
278            ENDIF            ENDIF
279    C Wait for all threads to finish filling shared buffer
280              CALL BAR2( myThid )
281            CALL GATHER_2D_R4(            CALL GATHER_2D_R4(
282       O                       xy_buffer_r4,       O                       xy_buffer_r4,
283       I                       sharedLocBuf_r4,       I                       sharedLocBuf_r4,
# Line 235  C-      copy from arr(level=k) to 2-D "l Line 285  C-      copy from arr(level=k) to 2-D "l
285       I                       useExch2ioLayOut, zeroBuff, myThid )       I                       useExch2ioLayOut, zeroBuff, myThid )
286          ELSEIF ( filePrec.EQ.precFloat64 ) THEN          ELSEIF ( filePrec.EQ.precFloat64 ) THEN
287            IF ( arrType.EQ.'RS' ) THEN            IF ( arrType.EQ.'RS' ) THEN
288              CALL MDS_PASS_R8toRS( sharedLocBuf_r8, arr,              CALL MDS_PASS_R8toRS( sharedLocBuf_r8, fldRS,
289       I                            k, kSize, 0,0, .FALSE., myThid )       I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
290            ELSEIF ( arrType.EQ.'RL' ) THEN            ELSEIF ( arrType.EQ.'RL' ) THEN
291              CALL MDS_PASS_R8toRL( sharedLocBuf_r8, arr,              CALL MDS_PASS_R8toRL( sharedLocBuf_r8, fldRL,
292       I                            k, kSize, 0,0, .FALSE., myThid )       I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
293            ELSE            ELSE
294              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(2A)')
295       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
296              CALL PRINT_ERROR( msgBuf, myThid )              CALL PRINT_ERROR( msgBuf, myThid )
297                CALL ALL_PROC_DIE( myThid )
298              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
299            ENDIF            ENDIF
300    C Wait for all threads to finish filling shared buffer
301              CALL BAR2( myThid )
302            CALL GATHER_2D_R8(            CALL GATHER_2D_R8(
303       O                       xy_buffer_r8,       O                       xy_buffer_r8,
304       I                       sharedLocBuf_r8,       I                       sharedLocBuf_r8,
305       I                       xSize, ySize,       I                       xSize, ySize,
306       I                       useExch2ioLayOut, zeroBuff, myThid )       I                       useExch2ioLayOut, zeroBuff, myThid )
307          ELSE          ELSE
308             WRITE(msgBuf,'(A)')            WRITE(msgBuf,'(A,I6)')
309       &       ' MDS_WRITE_FIELD: illegal value for filePrec'       &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
310             CALL PRINT_ERROR( msgBuf, myThid )            CALL PRINT_ERROR( msgBuf, myThid )
311             STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'            CALL ALL_PROC_DIE( myThid )
312              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
313          ENDIF          ENDIF
314    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            irec = 1 + k-kLo + (irecord-1)*nNz            irec = 1 + k-kLo + (irecord-1)*nNz
320            IF (filePrec .EQ. precFloat32) THEN            IF ( filePrec.EQ.precFloat32 ) THEN
321  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
322             CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )             CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )
323  #endif  #endif
324             WRITE(dUnit,rec=irec) ( xy_buffer_r4(i),i=1,xSize*ySize )             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( xSize*ySize, xy_buffer_r8 )             CALL MDS_BYTESWAPR8( xSize*ySize, xy_buffer_r8 )
328  #endif  #endif
329             WRITE(dUnit,rec=irec) ( xy_buffer_r8(i),i=1,xSize*ySize )             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 290  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           length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )            length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
404           IF (irecord .EQ. 1) THEN            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           ELSE            ELSE
408            OPEN( dUnit, file=dataFName, status=_OLD_STATUS,             OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
409       &            access='direct', recl=length_of_rec )       &             access='direct', recl=length_of_rec )
410           ENDIF            ENDIF
411           fileIsOpen=.TRUE.            fileIsOpen=.TRUE.
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            tNx = sNx
420            tNy = sNy            tNy = sNy
# Line 318  C Loop over all tiles Line 423  C Loop over all tiles
423            tBy = myYGlobalLo-1 + (bj-1)*sNy            tBy = myYGlobalLo-1 + (bj-1)*sNy
424  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
425            IF ( useExch2ioLayOut ) THEN            IF ( useExch2ioLayOut ) THEN
426              tN = W2_myTileList(bi)              tN = W2_myTileList(bi,bj)
427  c           tNx = exch2_tNx(tN)  c           tNx = exch2_tNx(tN)
428  c           tNy = exch2_tNy(tN)  c           tNy = exch2_tNy(tN)
429  c           global_nTx = exch2_global_Nx/tNx  c           global_nTx = exch2_global_Nx/tNx
# Line 348  C--- Case of 1 Global file: Line 453  C--- Case of 1 Global file:
453               irec = 1 + ( tBx + (j-1)*iGjLoc )/tNx               irec = 1 + ( tBx + (j-1)*iGjLoc )/tNx
454       &                + ( tBy + (j-1)*jGjLoc )*global_nTx       &                + ( tBy + (j-1)*jGjLoc )*global_nTx
455       &            +( k-kLo + (irecord-1)*nNz )*global_nTx*ySize       &            +( k-kLo + (irecord-1)*nNz )*global_nTx*ySize
456               IF (filePrec .EQ. precFloat32) THEN               i1 = bBij + 1 + (j-1)*sNx + (k-kLo)*sNx*sNy
457                IF (arrType .EQ. 'RS') THEN               i2 = bBij +         j*sNx + (k-kLo)*sNx*sNy
458                 CALL MDS_SEG4toRS( j,bi,bj,k,kSize, r4seg,.FALSE.,arr )               IF ( filePrec.EQ.precFloat32 ) THEN
459                ELSEIF (arrType .EQ. 'RL') THEN                WRITE(dUnit,rec=irec) (shared3dBuf_r4(i),i=i1,i2)
                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  
460               ELSE               ELSE
461                WRITE(msgBuf,'(A)')                WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
      &          ' MDS_WRITE_FIELD: illegal value for filePrec'  
               CALL PRINT_ERROR( msgBuf, myThid )  
               STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'  
462               ENDIF               ENDIF
463  C End of j loop  C End of j,k loops
464              ENDDO              ENDDO
 C End of k loop  
465             ENDDO             ENDDO
466    
467            ELSE            ELSE
# Line 396  C If we are writing to a tiled MDS file Line 471  C If we are writing to a tiled MDS file
471             iG=bi+(myXGlobalLo-1)/sNx             iG=bi+(myXGlobalLo-1)/sNx
472             jG=bj+(myYGlobalLo-1)/sNy             jG=bj+(myYGlobalLo-1)/sNy
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, myThid )             length_of_rec = MDS_RECLEN( filePrec, sNx*sNy*nNz, myThid )
476             IF (irecord .EQ. 1) THEN             IF (irecord .EQ. 1) THEN
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 )
# Line 407  C If we are writing to a tiled MDS file Line 482  C If we are writing to a tiled MDS file
482             ENDIF             ENDIF
483             fileIsOpen=.TRUE.             fileIsOpen=.TRUE.
484    
485             DO k=kLo,kHi             irec = irecord
486               i1 = bBij + 1
487               irec = 1 + k-kLo + (irecord-1)*nNz             i2 = bBij + sNx*sNy*nNz
488               IF (filePrec .EQ. precFloat32) THEN             IF ( filePrec.EQ.precFloat32 ) THEN
489                IF ( arrType.EQ.'RS' ) THEN               WRITE(dUnit,rec=irec) (shared3dBuf_r4(i),i=i1,i2)
490                 CALL MDS_PASS_R4toRS( r4loc, arr,             ELSE
491       I                           k, kSize, bi,bj,.FALSE., myThid )               WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
492                ELSEIF ( arrType.EQ.'RL' ) THEN             ENDIF
                CALL MDS_PASS_R4toRL( r4loc, arr,  
      I                           k, kSize, bi,bj,.FALSE., myThid )  
               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*sNy, r4loc )  
 #endif  
               WRITE(dUnit,rec=irec) r4loc  
              ELSEIF (filePrec .EQ. precFloat64) THEN  
               IF ( arrType.EQ.'RS' ) THEN  
                CALL MDS_PASS_R8toRS( r8loc, arr,  
      I                           k, kSize, bi,bj,.FALSE., myThid )  
               ELSEIF ( arrType.EQ.'RL' ) THEN  
                CALL MDS_PASS_R8toRL( r8loc, arr,  
      I                           k, kSize, bi,bj,.FALSE., myThid )  
               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*sNy, r8loc )  
 #endif  
               WRITE(dUnit,rec=irec) r8loc  
              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 k loop  
            ENDDO  
493    
494  C here We close the tiled MDS file  C here We close the tiled MDS file
495             IF ( fileIsOpen ) THEN             IF ( fileIsOpen ) THEN
496              CLOSE( dUnit )               CLOSE( dUnit )
497              fileIsOpen = .FALSE.               fileIsOpen = .FALSE.
498             ENDIF             ENDIF
499    
500  C--- End Global File / tile-file cases  C--- End Global File / tile-file cases
# Line 487  c          dimList(3,3) = kHi Line 524  c          dimList(3,3) = kHi
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
# Line 497  C End of bi,bj loops Line 534  C End of bi,bj loops
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 529  c        dimList(3,3) = kHi Line 570  c        dimList(3,3) = kHi
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.10  
changed lines
  Added in v.1.17
  ViewVC Help
Powered by ViewVC 1.1.22