/[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.20 by jmc, Tue Aug 12 17:38:11 2014 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 42  C  "fName.xxx.yyy.meta". If jrecord > 0, Line 43  C  "fName.xxx.yyy.meta". If jrecord > 0,
43  C Currently, the meta-files are not read because it is difficult  C Currently, the meta-files are not read because it is difficult
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 described 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    
172  C Only do I/O if I am the master thread  C File name should not be too long:
173        IF ( iAmDoingIO ) THEN  C    IL(+pIL if not useCurrentDir)(+5: '.data')(+8: bi,bj) =< MAX_LEN_FNAM
174    C    and shorter enough to be written to msgBuf with other informations
175          IF ( useCurrentDir .AND. (90+IL).GT.MAX_LEN_MBUF ) THEN
176            WRITE(msgBuf,'(2A,2(I4,A))') 'MDS_WRITE_FIELD: ',
177         &   'Too long (IL=',IL,') file name:'
178            CALL PRINT_ERROR( msgBuf, myThid )
179            WRITE(errorMessageUnit,'(3A)')'file: >',fName(1:IL),'<'
180            CALL ALL_PROC_DIE( myThid )
181            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
182          ELSEIF ( (90+IL+pIL).GT.MAX_LEN_MBUF ) THEN
183            WRITE(msgBuf,'(2A,2(I4,A))') 'MDS_WRITE_FIELD: ',
184         &   'Too long (pIL=',pIL,', IL=',IL,') pfix + file name:'
185            CALL PRINT_ERROR( msgBuf, myThid )
186            WRITE(errorMessageUnit,'(3A)')'pfix: >',mdsioLocalDir(1:pIL),'<'
187            WRITE(errorMessageUnit,'(3A)')'file: >',fName(1:IL),'<'
188            CALL ALL_PROC_DIE( myThid )
189            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
190          ENDIF
191  C Record number must be >= 1  C Record number must be >= 1
192          IF (irecord .LT. 1) THEN        IF (irecord .LT. 1) THEN
193           WRITE(msgBuf,'(A,I9.8)')          WRITE(msgBuf,'(3A,I10)')
194       &     ' MDS_WRITE_FIELD: argument irecord = ',irecord       &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
195           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
196       &                       SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT, myThid )
197           WRITE(msgBuf,'(A)')          WRITE(msgBuf,'(A,I9.8)')
198       &     ' MDS_WRITE_FIELD: invalid value for irecord'       &    ' MDS_WRITE_FIELD: argument irecord = ',irecord
199           CALL PRINT_ERROR( msgBuf, myThid )          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
200           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'       &                      SQUEEZE_RIGHT, myThid )
201          ENDIF          WRITE(msgBuf,'(A)')
202         &    ' MDS_WRITE_FIELD: invalid value for irecord'
203            CALL PRINT_ERROR( msgBuf, myThid )
204            CALL ALL_PROC_DIE( myThid )
205            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
206          ENDIF
207  C check for valid sub-set of levels:  C check for valid sub-set of levels:
208          IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN        IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN
209           WRITE(msgBuf,'(3(A,I6))')          WRITE(msgBuf,'(3A,I10)')
210       &     ' MDS_WRITE_FIELD: arguments kSize=', kSize,       &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
211       &     ' , kLo=', kLo, ' , kHi=', kHi          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
212           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,       &                      SQUEEZE_RIGHT, myThid )
213       &                       SQUEEZE_RIGHT , myThid)          WRITE(msgBuf,'(3(A,I6))')
214           WRITE(msgBuf,'(A)')       &    ' MDS_WRITE_FIELD: arguments kSize=', kSize,
215       &     ' MDS_WRITE_FIELD: invalid sub-set of levels'       &    ' , kLo=', kLo, ' , kHi=', kHi
216           CALL PRINT_ERROR( msgBuf, myThid )          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
217           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'       &                      SQUEEZE_RIGHT, myThid )
218          ENDIF          WRITE(msgBuf,'(A)')
219         &    ' MDS_WRITE_FIELD: invalid sub-set of levels'
220            CALL PRINT_ERROR( msgBuf, myThid )
221            CALL ALL_PROC_DIE( myThid )
222            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
223          ENDIF
224    C check for 3-D Buffer size:
225          IF ( .NOT.useSingleCpuIO .AND. nNz.GT.size3dBuf ) THEN
226            WRITE(msgBuf,'(3A,I10)')
227         &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
228            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
229         &                      SQUEEZE_RIGHT, myThid )
230            WRITE(msgBuf,'(3(A,I6))')
231         &    ' MDS_WRITE_FIELD: Nb Lev to write =', nNz,
232         &    ' >', size3dBuf, ' = buffer 3rd Dim'
233            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
234         &                      SQUEEZE_RIGHT, myThid )
235            WRITE(msgBuf,'(A)')
236         &    ' MDS_WRITE_FIELD: buffer 3rd Dim. too small'
237            CALL PRINT_ERROR( msgBuf, myThid )
238            WRITE(msgBuf,'(A)')
239         &    ' increase "size3dBuf" in "MDSIO_BUFF_3D.h" and recompile'
240            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
241         &                      SQUEEZE_RIGHT, myThid)
242            CALL ALL_PROC_DIE( myThid )
243            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
244          ENDIF
245    
246    C Only do I/O if I am the master thread
247          IF ( iAmDoingIO ) THEN
248    
249  C Assign special directory  C Assign special directory
250          IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN          IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN
# Line 187  C Assign special directory Line 253  C Assign special directory
253           WRITE(pfName,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL)           WRITE(pfName,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL)
254          ENDIF          ENDIF
255          pIL=ILNBLNK( pfName )          pIL=ILNBLNK( pfName )
256            IF ( debugLevel .GE. debLevC ) THEN
257              WRITE(msgBuf,'(A,I8,I6,3I4,2A)')
258         &      ' MDS_WRITE_FIELD: it,rec,kS,kL,kH=', myIter, jrecord,
259         &      kSize, kLo, kHi, ' file=', pfName(1:pIL)
260              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
261         &                        SQUEEZE_RIGHT, myThid )
262            ENDIF
263    
264  C Assign a free unit number as the I/O channel for this routine  C Assign a free unit number as the I/O channel for this routine
265          CALL MDSFINDUNIT( dUnit, myThid )          CALL MDSFINDUNIT( dUnit, myThid )
# Line 211  C Master thread of process 0, only, open Line 284  C Master thread of process 0, only, open
284           ENDIF           ENDIF
285         ENDIF         ENDIF
286    
287  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
288         DO k=kLo,kHi         DO k=kLo,kHi
289          zeroBuff = k.EQ.kLo          zeroBuff = k.EQ.kLo
290  C-      copy from arr(level=k) to 2-D "local":  C-      copy from fldRL/RS(level=k) to 2-D "local":
291          IF ( filePrec.EQ.precFloat32 ) THEN          IF ( filePrec.EQ.precFloat32 ) THEN
292            IF ( arrType.EQ.'RS' ) THEN            IF ( arrType.EQ.'RS' ) THEN
293              CALL MDS_PASS_R4toRS( sharedLocBuf_r4, arr,              CALL MDS_PASS_R4toRS( sharedLocBuf_r4, fldRS,
294       I                            k, kSize, 0,0, .FALSE., myThid )       I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
295            ELSEIF ( arrType.EQ.'RL' ) THEN            ELSEIF ( arrType.EQ.'RL' ) THEN
296              CALL MDS_PASS_R4toRL( sharedLocBuf_r4, arr,              CALL MDS_PASS_R4toRL( sharedLocBuf_r4, fldRL,
297       I                            k, kSize, 0,0, .FALSE., myThid )       I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
298            ELSE            ELSE
299              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(2A)')
300       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
301              CALL PRINT_ERROR( msgBuf, myThid )              CALL PRINT_ERROR( msgBuf, myThid )
302                CALL ALL_PROC_DIE( myThid )
303              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
304            ENDIF            ENDIF
305    C Wait for all threads to finish filling shared buffer
306              CALL BAR2( myThid )
307            CALL GATHER_2D_R4(            CALL GATHER_2D_R4(
308       O                       xy_buffer_r4,       O                       xy_buffer_r4,
309       I                       sharedLocBuf_r4,       I                       sharedLocBuf_r4,
# Line 235  C-      copy from arr(level=k) to 2-D "l Line 311  C-      copy from arr(level=k) to 2-D "l
311       I                       useExch2ioLayOut, zeroBuff, myThid )       I                       useExch2ioLayOut, zeroBuff, myThid )
312          ELSEIF ( filePrec.EQ.precFloat64 ) THEN          ELSEIF ( filePrec.EQ.precFloat64 ) THEN
313            IF ( arrType.EQ.'RS' ) THEN            IF ( arrType.EQ.'RS' ) THEN
314              CALL MDS_PASS_R8toRS( sharedLocBuf_r8, arr,              CALL MDS_PASS_R8toRS( sharedLocBuf_r8, fldRS,
315       I                            k, kSize, 0,0, .FALSE., myThid )       I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
316            ELSEIF ( arrType.EQ.'RL' ) THEN            ELSEIF ( arrType.EQ.'RL' ) THEN
317              CALL MDS_PASS_R8toRL( sharedLocBuf_r8, arr,              CALL MDS_PASS_R8toRL( sharedLocBuf_r8, fldRL,
318       I                            k, kSize, 0,0, .FALSE., myThid )       I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
319            ELSE            ELSE
320              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(2A)')
321       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
322              CALL PRINT_ERROR( msgBuf, myThid )              CALL PRINT_ERROR( msgBuf, myThid )
323                CALL ALL_PROC_DIE( myThid )
324              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
325            ENDIF            ENDIF
326    C Wait for all threads to finish filling shared buffer
327              CALL BAR2( myThid )
328            CALL GATHER_2D_R8(            CALL GATHER_2D_R8(
329       O                       xy_buffer_r8,       O                       xy_buffer_r8,
330       I                       sharedLocBuf_r8,       I                       sharedLocBuf_r8,
331       I                       xSize, ySize,       I                       xSize, ySize,
332       I                       useExch2ioLayOut, zeroBuff, myThid )       I                       useExch2ioLayOut, zeroBuff, myThid )
333          ELSE          ELSE
334             WRITE(msgBuf,'(A)')            WRITE(msgBuf,'(A,I6)')
335       &       ' MDS_WRITE_FIELD: illegal value for filePrec'       &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
336             CALL PRINT_ERROR( msgBuf, myThid )            CALL PRINT_ERROR( msgBuf, myThid )
337             STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'            CALL ALL_PROC_DIE( myThid )
338              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
339          ENDIF          ENDIF
340    C Make other threads wait for "gather" completion so that after this,
341    C  shared buffer can again be modified by any thread
342            CALL BAR2( myThid )
343    
344          IF ( iAmDoingIO ) THEN          IF ( iAmDoingIO ) THEN
345            irec = 1 + k-kLo + (irecord-1)*nNz            irec = 1 + k-kLo + (irecord-1)*nNz
346            IF (filePrec .EQ. precFloat32) THEN            IF ( filePrec.EQ.precFloat32 ) THEN
347  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
348             CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )             CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )
349  #endif  #endif
350             WRITE(dUnit,rec=irec) ( xy_buffer_r4(i),i=1,xSize*ySize )             WRITE(dUnit,rec=irec) ( xy_buffer_r4(i),i=1,xSize*ySize )
351            ELSEIF (filePrec .EQ. precFloat64) THEN            ELSE
352  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
353             CALL MDS_BYTESWAPR8( xSize*ySize, xy_buffer_r8 )             CALL MDS_BYTESWAPR8( xSize*ySize, xy_buffer_r8 )
354  #endif  #endif
355             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'  
356            ENDIF            ENDIF
357  C-      end if iAmDoingIO  C-      end if iAmDoingIO
358          ENDIF          ENDIF
# Line 290  C---+----1----+----2----+----3----+----4 Line 368  C---+----1----+----2----+----3----+----4
368  C---  else .NOT.useSingleCpuIO  C---  else .NOT.useSingleCpuIO
369        ELSE        ELSE
370    
371    C Wait for all thread to finish. This prevents other threads (e.g., master)
372    C  to continue to acces 3-D buffer while this thread is filling it.
373            CALL BAR2( myThid )
374    
375    C---    Copy from fldRL/RS to 3-D buffer (multi-threads):
376            IF ( filePrec.EQ.precFloat32 ) THEN
377              IF ( arrType.EQ.'RS' ) THEN
378                CALL MDS_PASS_R4toRS( shared3dBuf_r4, fldRS,
379         I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
380              ELSEIF ( arrType.EQ.'RL' ) THEN
381                CALL MDS_PASS_R4toRL( shared3dBuf_r4, fldRL,
382         I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
383              ELSE
384                WRITE(msgBuf,'(2A)')
385         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
386                CALL PRINT_ERROR( msgBuf, myThid )
387                CALL ALL_PROC_DIE( myThid )
388                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
389              ENDIF
390            ELSEIF ( filePrec.EQ.precFloat64 ) THEN
391              IF ( arrType.EQ.'RS' ) THEN
392                CALL MDS_PASS_R8toRS( shared3dBuf_r8, fldRS,
393         I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
394              ELSEIF ( arrType.EQ.'RL' ) THEN
395                CALL MDS_PASS_R8toRL( shared3dBuf_r8, fldRL,
396         I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
397              ELSE
398                WRITE(msgBuf,'(2A)')
399         &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
400                CALL PRINT_ERROR( msgBuf, myThid )
401                CALL ALL_PROC_DIE( myThid )
402                STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
403              ENDIF
404            ELSE
405              WRITE(msgBuf,'(A,I6)')
406         &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
407              CALL PRINT_ERROR( msgBuf, myThid )
408              CALL ALL_PROC_DIE( myThid )
409              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
410            ENDIF
411    
412    C Wait for all threads to finish filling shared buffer
413           CALL BAR2( myThid )
414    
415  C Only do I/O if I am the master thread  C Only do I/O if I am the master thread
416         IF ( iAmDoingIO ) THEN         IF ( iAmDoingIO ) THEN
417    
418    #ifdef _BYTESWAPIO
419            IF ( filePrec.EQ.precFloat32 ) THEN
420              CALL MDS_BYTESWAPR4( sNx*sNy*nNz*nSx*nSy, shared3dBuf_r4 )
421            ELSE
422              CALL MDS_BYTESWAPR8( sNx*sNy*nNz*nSx*nSy, shared3dBuf_r8 )
423            ENDIF
424    #endif
425    
426  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
427          IF (globalFile) THEN          IF (globalFile) THEN
428           WRITE(dataFName,'(2a)') fName(1:IL),'.data'            WRITE(dataFName,'(2a)') fName(1:IL),'.data'
429           length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )            length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
430           IF (irecord .EQ. 1) THEN            IF (irecord .EQ. 1) THEN
431            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,             OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
432       &            access='direct', recl=length_of_rec )       &             access='direct', recl=length_of_rec )
433           ELSE            ELSE
434            OPEN( dUnit, file=dataFName, status=_OLD_STATUS,             OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
435       &            access='direct', recl=length_of_rec )       &             access='direct', recl=length_of_rec )
436           ENDIF            ENDIF
437           fileIsOpen=.TRUE.            fileIsOpen=.TRUE.
438          ENDIF          ENDIF
439    
440  C Loop over all tiles  C Loop over all tiles
441          DO bj=1,nSy          DO bj=1,nSy
442           DO bi=1,nSx           DO bi=1,nSx
443              bBij = sNx*sNy*nNz*( bi-1 + (bj-1)*nSx )
444    
445            tNx = sNx            tNx = sNx
446            tNy = sNy            tNy = sNy
# Line 318  C Loop over all tiles Line 449  C Loop over all tiles
449            tBy = myYGlobalLo-1 + (bj-1)*sNy            tBy = myYGlobalLo-1 + (bj-1)*sNy
450  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
451            IF ( useExch2ioLayOut ) THEN            IF ( useExch2ioLayOut ) THEN
452              tN = W2_myTileList(bi)              tN = W2_myTileList(bi,bj)
453  c           tNx = exch2_tNx(tN)  c           tNx = exch2_tNx(tN)
454  c           tNy = exch2_tNy(tN)  c           tNy = exch2_tNy(tN)
455  c           global_nTx = exch2_global_Nx/tNx  c           global_nTx = exch2_global_Nx/tNx
# Line 348  C--- Case of 1 Global file: Line 479  C--- Case of 1 Global file:
479               irec = 1 + ( tBx + (j-1)*iGjLoc )/tNx               irec = 1 + ( tBx + (j-1)*iGjLoc )/tNx
480       &                + ( tBy + (j-1)*jGjLoc )*global_nTx       &                + ( tBy + (j-1)*jGjLoc )*global_nTx
481       &            +( k-kLo + (irecord-1)*nNz )*global_nTx*ySize       &            +( k-kLo + (irecord-1)*nNz )*global_nTx*ySize
482               IF (filePrec .EQ. precFloat32) THEN               i1 = bBij + 1 + (j-1)*sNx + (k-kLo)*sNx*sNy
483                IF (arrType .EQ. 'RS') THEN               i2 = bBij +         j*sNx + (k-kLo)*sNx*sNy
484                 CALL MDS_SEG4toRS( j,bi,bj,k,kSize, r4seg,.FALSE.,arr )               IF ( filePrec.EQ.precFloat32 ) THEN
485                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  
486               ELSE               ELSE
487                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'  
488               ENDIF               ENDIF
489  C End of j loop  C End of j,k loops
490              ENDDO              ENDDO
 C End of k loop  
491             ENDDO             ENDDO
492    
493            ELSE            ELSE
# Line 396  C If we are writing to a tiled MDS file Line 497  C If we are writing to a tiled MDS file
497             iG=bi+(myXGlobalLo-1)/sNx             iG=bi+(myXGlobalLo-1)/sNx
498             jG=bj+(myYGlobalLo-1)/sNy             jG=bj+(myYGlobalLo-1)/sNy
499             WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')             WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
500       &              pfName(1:pIL),'.',iG,'.',jG,'.data'       &            pfName(1:pIL),'.',iG,'.',jG,'.data'
501             length_of_rec = MDS_RECLEN( filePrec, sNx*sNy, myThid )             length_of_rec = MDS_RECLEN( filePrec, sNx*sNy*nNz, myThid )
502             IF (irecord .EQ. 1) THEN             IF (irecord .EQ. 1) THEN
503              OPEN( dUnit, file=dataFName, status=_NEW_STATUS,              OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
504       &            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 508  C If we are writing to a tiled MDS file
508             ENDIF             ENDIF
509             fileIsOpen=.TRUE.             fileIsOpen=.TRUE.
510    
511             DO k=kLo,kHi             irec = irecord
512               i1 = bBij + 1
513               irec = 1 + k-kLo + (irecord-1)*nNz             i2 = bBij + sNx*sNy*nNz
514               IF (filePrec .EQ. precFloat32) THEN             IF ( filePrec.EQ.precFloat32 ) THEN
515                IF ( arrType.EQ.'RS' ) THEN               WRITE(dUnit,rec=irec) (shared3dBuf_r4(i),i=i1,i2)
516                 CALL MDS_PASS_R4toRS( r4loc, arr,             ELSE
517       I                           k, kSize, bi,bj,.FALSE., myThid )               WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
518                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  
519    
520  C here We close the tiled MDS file  C here We close the tiled MDS file
521             IF ( fileIsOpen ) THEN             IF ( fileIsOpen ) THEN
522              CLOSE( dUnit )               CLOSE( dUnit )
523              fileIsOpen = .FALSE.               fileIsOpen = .FALSE.
524             ENDIF             ENDIF
525    
526  C--- End Global File / tile-file cases  C--- End Global File / tile-file cases
# Line 487  c          dimList(3,3) = kHi Line 550  c          dimList(3,3) = kHi
550             map2gl(2) = jGjLoc             map2gl(2) = jGjLoc
551             CALL MDS_WRITE_META(             CALL MDS_WRITE_META(
552       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
553       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims, dimList, map2gl, 0, blank8c,
554       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, dummyRL, oneRL, irecord, myIter, myThid )
555            ENDIF            ENDIF
556    
557  C End of bi,bj loops  C End of bi,bj loops
# Line 497  C End of bi,bj loops Line 560  C End of bi,bj loops
560    
561  C If global file was opened then close it  C If global file was opened then close it
562          IF (fileIsOpen .AND. globalFile) THEN          IF (fileIsOpen .AND. globalFile) THEN
563           CLOSE( dUnit )            CLOSE( dUnit )
564           fileIsOpen = .FALSE.            fileIsOpen = .FALSE.
565          ENDIF          ENDIF
566    
567  C- endif iAmDoingIO  C- endif iAmDoingIO
568         ENDIF         ENDIF
569    
570    C Make other threads wait for I/O completion so that after this,
571    C  3-D buffer can again be modified by any thread
572    c      CALL BAR2( myThid )
573    
574  C     if useSingleCpuIO / else / end  C     if useSingleCpuIO / else / end
575        ENDIF        ENDIF
576    
# Line 529  c        dimList(3,3) = kHi Line 596  c        dimList(3,3) = kHi
596           map2gl(2) = 1           map2gl(2) = 1
597           CALL MDS_WRITE_META(           CALL MDS_WRITE_META(
598       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
599       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims, dimList, map2gl, 0, blank8c,
600       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, dummyRL, oneRL, irecord, myIter, myThid )
601  c    I              metaFName, dataFName, the_run_name, titleLine,  c    I              metaFName, dataFName, the_run_name, titleLine,
602  c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,  c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,
603  c    I              nTimRec, timList, irecord, myIter, myThid )  c    I              nTimRec, timList, misVal, irecord, myIter, myThid )
604        ENDIF        ENDIF
605    
 C To be safe, make other processes wait for I/O completion  
       _BARRIER  
   
606  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
607        RETURN        RETURN
608        END        END
Legend:
Removed from v.1.10  
changed lines
  Added in v.1.20
  ViewVC Help
Powered by ViewVC 1.1.22