/[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.11 by jmc, Mon Jun 8 03:32:33 2009 UTC revision 1.16 by jmc, Tue Sep 1 19:08:27 2009 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 71  C Global variables / common blocks Line 71  C Global variables / common blocks
71  #include "EEPARAMS.h"  #include "EEPARAMS.h"
72  #include "PARAMS.h"  #include "PARAMS.h"
73  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
74  #include "W2_EXCH2_SIZE.h"  # 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 "EEBUFF_SCPU.h"  #include "EEBUFF_SCPU.h"
79    #ifdef ALLOW_FIZHI
80    # include "fizhi_SIZE.h"
81    #endif /* ALLOW_FIZHI */
82  #include "MDSIO_BUFF_3D.h"  #include "MDSIO_BUFF_3D.h"
83    
84  C !INPUT PARAMETERS:  C !INPUT PARAMETERS:
# Line 85  C !INPUT PARAMETERS: Line 88  C !INPUT PARAMETERS:
88        LOGICAL useCurrentDir        LOGICAL useCurrentDir
89        CHARACTER*(2) arrType        CHARACTER*(2) arrType
90        INTEGER kSize, kLo, kHi        INTEGER kSize, kLo, kHi
91  cph(        _RL fldRL(*)
92  cph      Real arr(*)        _RS fldRS(*)
       _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,kSize,nSx,nSy)  
 cph)  
93        INTEGER jrecord        INTEGER jrecord
94        INTEGER myIter        INTEGER myIter
95        INTEGER myThid        INTEGER myThid
# Line 124  C     bBij  :: base shift in Buffer inde Line 125  C     bBij  :: base shift in Buffer inde
125  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
126        INTEGER tN        INTEGER tN
127  #endif /* ALLOW_EXCH2 */  #endif /* ALLOW_EXCH2 */
128          _RL dummyRL(1)
129          CHARACTER*8 blank8c
130    
131          DATA dummyRL(1) / 0. _d 0 /
132          DATA blank8c / '        ' /
133    
134  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
135  C Set dimensions:  C Set dimensions:
# Line 155  C Only do I/O if I am the master thread Line 161  C Only do I/O if I am the master thread
161    
162  C Record number must be >= 1  C Record number must be >= 1
163        IF (irecord .LT. 1) THEN        IF (irecord .LT. 1) THEN
164            WRITE(msgBuf,'(3A,I10)')
165         &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
166            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
167         &                      SQUEEZE_RIGHT , myThid )
168          WRITE(msgBuf,'(A,I9.8)')          WRITE(msgBuf,'(A,I9.8)')
169       &    ' MDS_WRITE_FIELD: argument irecord = ',irecord       &    ' MDS_WRITE_FIELD: argument irecord = ',irecord
170          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
171       &                      SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid )
172           WRITE(msgBuf,'(A)')           WRITE(msgBuf,'(A)')
173       &    ' MDS_WRITE_FIELD: invalid value for irecord'       &    ' MDS_WRITE_FIELD: invalid value for irecord'
174          CALL PRINT_ERROR( msgBuf, myThid )          CALL PRINT_ERROR( msgBuf, myThid )
# Line 167  C Record number must be >= 1 Line 177  C Record number must be >= 1
177        ENDIF        ENDIF
178  C check for valid sub-set of levels:  C check for valid sub-set of levels:
179        IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN        IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN
180            WRITE(msgBuf,'(3A,I10)')
181         &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
182            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
183         &                      SQUEEZE_RIGHT , myThid )
184          WRITE(msgBuf,'(3(A,I6))')          WRITE(msgBuf,'(3(A,I6))')
185       &    ' MDS_WRITE_FIELD: arguments kSize=', kSize,       &    ' MDS_WRITE_FIELD: arguments kSize=', kSize,
186       &    ' , kLo=', kLo, ' , kHi=', kHi       &    ' , kLo=', kLo, ' , kHi=', kHi
187          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
188       &                      SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid )
189          WRITE(msgBuf,'(A)')          WRITE(msgBuf,'(A)')
190       &    ' MDS_WRITE_FIELD: invalid sub-set of levels'       &    ' MDS_WRITE_FIELD: invalid sub-set of levels'
191          CALL PRINT_ERROR( msgBuf, myThid )          CALL PRINT_ERROR( msgBuf, myThid )
# Line 180  C check for valid sub-set of levels: Line 194  C check for valid sub-set of levels:
194        ENDIF        ENDIF
195  C check for 3-D Buffer size:  C check for 3-D Buffer size:
196        IF ( .NOT.useSingleCpuIO .AND. nNz.GT.size3dBuf ) THEN        IF ( .NOT.useSingleCpuIO .AND. nNz.GT.size3dBuf ) THEN
197            WRITE(msgBuf,'(3A,I10)')
198         &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
199            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
200         &                      SQUEEZE_RIGHT , myThid )
201          WRITE(msgBuf,'(3(A,I6))')          WRITE(msgBuf,'(3(A,I6))')
202       &    ' MDS_WRITE_FIELD: Nb Lev to write =', nNz,       &    ' MDS_WRITE_FIELD: Nb Lev to write =', nNz,
203       &    ' >', size3dBuf, ' = buffer 3rd Dim'       &    ' >', size3dBuf, ' = buffer 3rd Dim'
204          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
205       &                      SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid )
206          WRITE(msgBuf,'(A)')          WRITE(msgBuf,'(A)')
207       &    ' MDS_WRITE_FIELD: buffer 3rd Dim. too small'       &    ' MDS_WRITE_FIELD: buffer 3rd Dim. too small'
208          CALL PRINT_ERROR( msgBuf, myThid )          CALL PRINT_ERROR( msgBuf, myThid )
# Line 233  C Master thread of process 0, only, open Line 251  C Master thread of process 0, only, open
251  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
252         DO k=kLo,kHi         DO k=kLo,kHi
253          zeroBuff = k.EQ.kLo          zeroBuff = k.EQ.kLo
254  C-      copy from arr(level=k) to 2-D "local":  C-      copy from fldRL/RS(level=k) to 2-D "local":
255          IF ( filePrec.EQ.precFloat32 ) THEN          IF ( filePrec.EQ.precFloat32 ) THEN
256            IF ( arrType.EQ.'RS' ) THEN            IF ( arrType.EQ.'RS' ) THEN
257              CALL MDS_PASS_R4toRS( sharedLocBuf_r4, arr,              CALL MDS_PASS_R4toRS( sharedLocBuf_r4, fldRS,
258       I                       1, k, kSize, 0, 0, .FALSE., myThid )       I                       1, k, kSize, 0, 0, .FALSE., myThid )
259            ELSEIF ( arrType.EQ.'RL' ) THEN            ELSEIF ( arrType.EQ.'RL' ) THEN
260              CALL MDS_PASS_R4toRL( sharedLocBuf_r4, arr,              CALL MDS_PASS_R4toRL( sharedLocBuf_r4, fldRL,
261       I                       1, k, kSize, 0, 0, .FALSE., myThid )       I                       1, k, kSize, 0, 0, .FALSE., myThid )
262            ELSE            ELSE
263              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(2A)')
264       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
265              CALL PRINT_ERROR( msgBuf, myThid )              CALL PRINT_ERROR( msgBuf, myThid )
266              CALL ALL_PROC_DIE( myThid )              CALL ALL_PROC_DIE( myThid )
267              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
# Line 257  C Wait for all threads to finish filling Line 275  C Wait for all threads to finish filling
275       I                       useExch2ioLayOut, zeroBuff, myThid )       I                       useExch2ioLayOut, zeroBuff, myThid )
276          ELSEIF ( filePrec.EQ.precFloat64 ) THEN          ELSEIF ( filePrec.EQ.precFloat64 ) THEN
277            IF ( arrType.EQ.'RS' ) THEN            IF ( arrType.EQ.'RS' ) THEN
278              CALL MDS_PASS_R8toRS( sharedLocBuf_r8, arr,              CALL MDS_PASS_R8toRS( sharedLocBuf_r8, fldRS,
279       I                       1, k, kSize, 0, 0, .FALSE., myThid )       I                       1, k, kSize, 0, 0, .FALSE., myThid )
280    
281            ELSEIF ( arrType.EQ.'RL' ) THEN            ELSEIF ( arrType.EQ.'RL' ) THEN
282              CALL MDS_PASS_R8toRL( sharedLocBuf_r8, arr,              CALL MDS_PASS_R8toRL( sharedLocBuf_r8, fldRL,
283       I                       1, k, kSize, 0, 0, .FALSE., myThid )       I                       1, k, kSize, 0, 0, .FALSE., myThid )
284            ELSE            ELSE
285              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(2A)')
286       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
287              CALL PRINT_ERROR( msgBuf, myThid )              CALL PRINT_ERROR( msgBuf, myThid )
288              CALL ALL_PROC_DIE( myThid )              CALL ALL_PROC_DIE( myThid )
289              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
# Line 278  C Wait for all threads to finish filling Line 296  C Wait for all threads to finish filling
296       I                       xSize, ySize,       I                       xSize, ySize,
297       I                       useExch2ioLayOut, zeroBuff, myThid )       I                       useExch2ioLayOut, zeroBuff, myThid )
298          ELSE          ELSE
299             WRITE(msgBuf,'(A)')            WRITE(msgBuf,'(A,I6)')
300       &       ' MDS_WRITE_FIELD: illegal value for filePrec'       &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
301             CALL PRINT_ERROR( msgBuf, myThid )            CALL PRINT_ERROR( msgBuf, myThid )
302             CALL ALL_PROC_DIE( myThid )            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 Make other threads wait for "gather" completion so that after this,  C Make other threads wait for "gather" completion so that after this,
306  C  shared buffer can again be modified by any thread  C  shared buffer can again be modified by any thread
# Line 315  C---+----1----+----2----+----3----+----4 Line 333  C---+----1----+----2----+----3----+----4
333  C---  else .NOT.useSingleCpuIO  C---  else .NOT.useSingleCpuIO
334        ELSE        ELSE
335    
336  C---    Copy from arr to 3-D buffer (multi-threads):  C---    Copy from fldRL/RS to 3-D buffer (multi-threads):
337          IF ( filePrec.EQ.precFloat32 ) THEN          IF ( filePrec.EQ.precFloat32 ) THEN
338            IF ( arrType.EQ.'RS' ) THEN            IF ( arrType.EQ.'RS' ) THEN
339              CALL MDS_PASS_R4toRS( shared3dBuf_r4, arr,              CALL MDS_PASS_R4toRS( shared3dBuf_r4, fldRS,
340       I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )       I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
341            ELSEIF ( arrType.EQ.'RL' ) THEN            ELSEIF ( arrType.EQ.'RL' ) THEN
342              CALL MDS_PASS_R4toRL( shared3dBuf_r4, arr,              CALL MDS_PASS_R4toRL( shared3dBuf_r4, fldRL,
343       I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )       I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
344            ELSE            ELSE
345              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(2A)')
346       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
347              CALL PRINT_ERROR( msgBuf, myThid )              CALL PRINT_ERROR( msgBuf, myThid )
348              CALL ALL_PROC_DIE( myThid )              CALL ALL_PROC_DIE( myThid )
349              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
350            ENDIF            ENDIF
351          ELSEIF ( filePrec.EQ.precFloat64 ) THEN          ELSEIF ( filePrec.EQ.precFloat64 ) THEN
352            IF ( arrType.EQ.'RS' ) THEN            IF ( arrType.EQ.'RS' ) THEN
353              CALL MDS_PASS_R8toRS( shared3dBuf_r8, arr,              CALL MDS_PASS_R8toRS( shared3dBuf_r8, fldRS,
354       I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )       I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
355            ELSEIF ( arrType.EQ.'RL' ) THEN            ELSEIF ( arrType.EQ.'RL' ) THEN
356              CALL MDS_PASS_R8toRL( shared3dBuf_r8, arr,              CALL MDS_PASS_R8toRL( shared3dBuf_r8, fldRL,
357       I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )       I                    nNz, kLo, kSize, 0,0, .FALSE., myThid )
358            ELSE            ELSE
359              WRITE(msgBuf,'(A)')              WRITE(msgBuf,'(2A)')
360       &         ' MDS_WRITE_FIELD: illegal value for arrType'       &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
361              CALL PRINT_ERROR( msgBuf, myThid )              CALL PRINT_ERROR( msgBuf, myThid )
362              CALL ALL_PROC_DIE( myThid )              CALL ALL_PROC_DIE( myThid )
363              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'              STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
364            ENDIF            ENDIF
365          ELSE          ELSE
366            WRITE(msgBuf,'(A)')            WRITE(msgBuf,'(A,I6)')
367       &         ' MDS_WRITE_FIELD: illegal value for filePrec'       &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
368            CALL PRINT_ERROR( msgBuf, myThid )            CALL PRINT_ERROR( msgBuf, myThid )
369            CALL ALL_PROC_DIE( myThid )            CALL ALL_PROC_DIE( myThid )
370            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'            STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
# Line 392  C Loop over all tiles Line 410  C Loop over all tiles
410            tBy = myYGlobalLo-1 + (bj-1)*sNy            tBy = myYGlobalLo-1 + (bj-1)*sNy
411  #ifdef ALLOW_EXCH2  #ifdef ALLOW_EXCH2
412            IF ( useExch2ioLayOut ) THEN            IF ( useExch2ioLayOut ) THEN
413              tN = W2_myTileList(bi)              tN = W2_myTileList(bi,bj)
414  c           tNx = exch2_tNx(tN)  c           tNx = exch2_tNx(tN)
415  c           tNy = exch2_tNy(tN)  c           tNy = exch2_tNy(tN)
416  c           global_nTx = exch2_global_Nx/tNx  c           global_nTx = exch2_global_Nx/tNx
# Line 493  c          dimList(3,3) = kHi Line 511  c          dimList(3,3) = kHi
511             map2gl(2) = jGjLoc             map2gl(2) = jGjLoc
512             CALL MDS_WRITE_META(             CALL MDS_WRITE_META(
513       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
514       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims, dimList, map2gl, 0, blank8c,
515       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, dummyRL, irecord, myIter, myThid )
516            ENDIF            ENDIF
517    
518  C End of bi,bj loops  C End of bi,bj loops
# Line 539  c        dimList(3,3) = kHi Line 557  c        dimList(3,3) = kHi
557           map2gl(2) = 1           map2gl(2) = 1
558           CALL MDS_WRITE_META(           CALL MDS_WRITE_META(
559       I              metaFName, dataFName, the_run_name, ' ',       I              metaFName, dataFName, the_run_name, ' ',
560       I              filePrec, nDims,dimList,map2gl, 0,  ' ',       I              filePrec, nDims, dimList, map2gl, 0, blank8c,
561       I              0, UNSET_RL, irecord, myIter, myThid )       I              0, dummyRL, irecord, myIter, myThid )
562  c    I              metaFName, dataFName, the_run_name, titleLine,  c    I              metaFName, dataFName, the_run_name, titleLine,
563  c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,  c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,
564  c    I              nTimRec, timList, irecord, myIter, myThid )  c    I              nTimRec, timList, irecord, myIter, myThid )
Legend:
Removed from v.1.11  
changed lines
  Added in v.1.16
  ViewVC Help
Powered by ViewVC 1.1.22