Back to home page

MITgcm
 
 

    

File indexing completed on 2018-03-02 18:41:56 UTC

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
a9590e7718 Jean*0001 #include "MDSIO_OPTIONS.h"
                0002 
                0003 CBOP
                0004 C !ROUTINE: MDS_WRITE_FIELD
                0005 C !INTERFACE:
                0006       SUBROUTINE MDS_WRITE_FIELD(
                0007      I   fName,
                0008      I   filePrec,
                0009      I   globalFile,
                0010      I   useCurrentDir,
                0011      I   arrType,
c0c8c1b5a1 Jean*0012      I   kSize,kLo,kHi,
608f4af3c8 Jean*0013      I   fldRL, fldRS,
a9590e7718 Jean*0014      I   jrecord,
                0015      I   myIter,
                0016      I   myThid )
                0017 
                0018 C !DESCRIPTION:
                0019 C Arguments:
                0020 C
                0021 C fName     (string)  :: base name for file to write
                0022 C filePrec  (integer) :: number of bits per word in file (32 or 64)
                0023 C globalFile (logical):: selects between writing a global or tiled file
                0024 C useCurrentDir(logic):: always write to the current directory (even if
                0025 C                        "mdsioLocalDir" is set)
608f4af3c8 Jean*0026 C arrType   (char(2)) :: which array (fldRL/RS) to write, either "RL" or "RS"
c0c8c1b5a1 Jean*0027 C kSize     (integer) :: size of third dimension: normally either 1 or Nr
608f4af3c8 Jean*0028 C kLo       (integer) :: 1rst vertical level (of array fldRL/RS) to write
                0029 C kHi       (integer) :: last vertical level (of array fldRL/RS) to write
                0030 C fldRL       ( RL )  :: array to write if arrType="RL", fldRL(:,:,kSize,:,:)
                0031 C fldRS       ( RS )  :: array to write if arrType="RS", fldRS(:,:,kSize,:,:)
a9590e7718 Jean*0032 C irecord   (integer) :: record number to write
                0033 C myIter    (integer) :: time step number
                0034 C myThid    (integer) :: thread identifier
                0035 C
                0036 C MDS_WRITE_FIELD creates either a file of the form "fName.data" and
c0c8c1b5a1 Jean*0037 C  "fName.meta" if the logical flag "globalFile" is set true. Otherwise
                0038 C  it creates MDS tiled files of the form "fName.xxx.yyy.data" and
                0039 C  "fName.xxx.yyy.meta". If jrecord > 0, a meta-file is created.
a9590e7718 Jean*0040 C Currently, the meta-files are not read because it is difficult
c0c8c1b5a1 Jean*0041 C  to parse files in fortran. We should read meta information before
                0042 C  adding records to an existing multi-record file.
db324b9278 Jean*0043 C The precision of the file is described by filePrec, set either
608f4af3c8 Jean*0044 C  to floatPrec32 or floatPrec64. The char*(2) string arrType, either
                0045 C  "RL" or "RS", selects which array is written, either fldRL or fldRS.
c0c8c1b5a1 Jean*0046 C (kSize,kLo,kHi) allows for both 2-D and 3-D arrays to be handled, with
                0047 C  the option to only write a sub-set of consecutive vertical levels (from
                0048 C  kLo to kHi); (kSize,kLo,kHi)=(1,1,1) implies a 2-D model field and
                0049 C  (kSize,kLo,kHi)=(Nr,1,Nr) implies a 3-D model field.
                0050 C irecord=|jrecord| is the record number to be written and must be >= 1.
                0051 C NOTE: It is currently assumed that the highest record number in the file
                0052 C  was the last record written. Nor is there a consistency check between the
                0053 C  routine arguments and file, i.e., if you write record 2 after record 4
                0054 C  the meta information will record the number of records to be 2. This,
                0055 C  again, is because we have read the meta information. To be fixed.
a9590e7718 Jean*0056 C
2186fe42a7 Jean*0057 C- Multi-threaded: Only Master thread does IO (and MPI calls) and get data
                0058 C   from a shared buffer that any thread can copy to.
                0059 C- Convention regarding thread synchronisation (BARRIER):
                0060 C  A per-thread (or per tile) partition of the 2-D shared-buffer (sharedLocBuf_r4/r8)
                0061 C   is readily available => any access (e.g., by master-thread) to a portion
                0062 C   owned by an other thread is put between BARRIER (protected).
                0063 C  No thread partition exist for the 3-D shared buffer (shared3dBuf_r4/r8);
                0064 C   Therefore, the 3-D buffer is considered to be owned by master-thread and
                0065 C   any access by other than master thread is put between BARRIER (protected).
                0066 C
a9590e7718 Jean*0067 C Created: 03/16/99 adcroft@mit.edu
                0068 C Changed: 01/06/02 menemenlis@jpl.nasa.gov
                0069 C          added useSingleCpuIO hack
                0070 C changed:  1/23/04 afe@ocean.mit.edu
                0071 C          added exch2 handling -- yes, the globalfile logic is nuts
                0072 CEOP
                0073 
                0074 C !USES:
                0075       IMPLICIT NONE
                0076 C Global variables / common blocks
                0077 #include "SIZE.h"
                0078 #include "EEPARAMS.h"
                0079 #include "PARAMS.h"
                0080 #ifdef ALLOW_EXCH2
d24daa2c55 Jean*0081 # include "W2_EXCH2_SIZE.h"
                0082 # include "W2_EXCH2_TOPOLOGY.h"
                0083 # include "W2_EXCH2_PARAMS.h"
a9590e7718 Jean*0084 #endif /* ALLOW_EXCH2 */
f7508ac42d Jean*0085 #include "EEBUFF_SCPU.h"
d24daa2c55 Jean*0086 #ifdef ALLOW_FIZHI
                0087 # include "fizhi_SIZE.h"
                0088 #endif /* ALLOW_FIZHI */
8decba0243 Jean*0089 #include "MDSIO_BUFF_3D.h"
a9590e7718 Jean*0090 
                0091 C !INPUT PARAMETERS:
                0092       CHARACTER*(*) fName
                0093       INTEGER filePrec
                0094       LOGICAL globalFile
                0095       LOGICAL useCurrentDir
                0096       CHARACTER*(2) arrType
c0c8c1b5a1 Jean*0097       INTEGER kSize, kLo, kHi
608f4af3c8 Jean*0098       _RL fldRL(*)
                0099       _RS fldRS(*)
a9590e7718 Jean*0100       INTEGER jrecord
                0101       INTEGER myIter
                0102       INTEGER myThid
                0103 C !OUTPUT PARAMETERS:
                0104 
                0105 C !FUNCTIONS
                0106       INTEGER  ILNBLNK
                0107       INTEGER  MDS_RECLEN
                0108       LOGICAL  MASTER_CPU_IO
                0109       EXTERNAL ILNBLNK
                0110       EXTERNAL MDS_RECLEN
                0111       EXTERNAL MASTER_CPU_IO
                0112 
                0113 C !LOCAL VARIABLES:
8decba0243 Jean*0114 C     bBij  :: base shift in Buffer index for tile bi,bj
a9590e7718 Jean*0115       CHARACTER*(MAX_LEN_FNAM) dataFName,metaFName,pfName
                0116       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0117       LOGICAL fileIsOpen
                0118       LOGICAL iAmDoingIO
                0119       LOGICAL writeMetaF
f7508ac42d Jean*0120       LOGICAL useExch2ioLayOut
e039218b63 Jean*0121       LOGICAL zeroBuff
                0122       INTEGER xSize, ySize
a9590e7718 Jean*0123       INTEGER irecord
8decba0243 Jean*0124       INTEGER iG,jG,bi,bj
                0125       INTEGER i1,i2,i,j,k,nNz
c0c8c1b5a1 Jean*0126       INTEGER irec,dUnit,IL,pIL
20b1679b8a Jean*0127       INTEGER dimList(3,3), nDims, map2gl(2)
e546f6387c Oliv*0128       INTEGER length_of_rec
8decba0243 Jean*0129       INTEGER bBij
f7508ac42d Jean*0130       INTEGER tNx, tNy, global_nTx
                0131       INTEGER tBx, tBy, iGjLoc, jGjLoc
a9590e7718 Jean*0132 #ifdef ALLOW_EXCH2
f7508ac42d Jean*0133       INTEGER tN
a9590e7718 Jean*0134 #endif /* ALLOW_EXCH2 */
fbc6fb65d0 Jean*0135       _RL dummyRL(1)
                0136       CHARACTER*8 blank8c
                0137 
                0138       DATA dummyRL(1) / 0. _d 0 /
                0139       DATA blank8c / '        ' /
a9590e7718 Jean*0140 
                0141 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e039218b63 Jean*0142 C Set dimensions:
                0143       xSize = Nx
                0144       ySize = Ny
f7508ac42d Jean*0145       useExch2ioLayOut = .FALSE.
                0146 #ifdef ALLOW_EXCH2
                0147       IF ( W2_useE2ioLayOut ) THEN
                0148         xSize = exch2_global_Nx
                0149         ySize = exch2_global_Ny
                0150         useExch2ioLayOut = .TRUE.
                0151       ENDIF
                0152 #endif /* ALLOW_EXCH2 */
a9590e7718 Jean*0153 
20b1679b8a Jean*0154 C-    default:
                0155       iGjLoc = 0
                0156       jGjLoc = 1
                0157 
a9590e7718 Jean*0158 C Assume nothing
                0159       fileIsOpen = .FALSE.
                0160       IL  = ILNBLNK( fName )
                0161       pIL = ILNBLNK( mdsioLocalDir )
c0c8c1b5a1 Jean*0162       nNz = 1 + kHi - kLo
a9590e7718 Jean*0163       irecord = ABS(jrecord)
                0164       writeMetaF = jrecord.GT.0
                0165 
                0166 C Only do I/O if I am the master thread (and mpi process 0 IF useSingleCpuIO):
                0167       iAmDoingIO = MASTER_CPU_IO(myThid)
                0168 
a0e387243c Jean*0169 C File name should not be too long:
                0170 C    IL(+pIL if not useCurrentDir)(+5: '.data')(+8: bi,bj) =< MAX_LEN_FNAM
                0171 C    and shorter enough to be written to msgBuf with other informations
                0172       IF ( useCurrentDir .AND. (90+IL).GT.MAX_LEN_MBUF ) THEN
                0173         WRITE(msgBuf,'(2A,2(I4,A))') 'MDS_WRITE_FIELD: ',
                0174      &   'Too long (IL=',IL,') file name:'
                0175         CALL PRINT_ERROR( msgBuf, myThid )
                0176         WRITE(errorMessageUnit,'(3A)')'file: >',fName(1:IL),'<'
                0177         CALL ALL_PROC_DIE( myThid )
                0178         STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
                0179       ELSEIF ( (90+IL+pIL).GT.MAX_LEN_MBUF ) THEN
                0180         WRITE(msgBuf,'(2A,2(I4,A))') 'MDS_WRITE_FIELD: ',
                0181      &   'Too long (pIL=',pIL,', IL=',IL,') pfix + file name:'
                0182         CALL PRINT_ERROR( msgBuf, myThid )
                0183         WRITE(errorMessageUnit,'(3A)')'pfix: >',mdsioLocalDir(1:pIL),'<'
                0184         WRITE(errorMessageUnit,'(3A)')'file: >',fName(1:IL),'<'
                0185         CALL ALL_PROC_DIE( myThid )
                0186         STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
                0187       ENDIF
a9590e7718 Jean*0188 C Record number must be >= 1
8decba0243 Jean*0189       IF (irecord .LT. 1) THEN
e5df3a82bd Jean*0190         WRITE(msgBuf,'(3A,I10)')
d24daa2c55 Jean*0191      &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
                0192         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
a0e387243c Jean*0193      &                      SQUEEZE_RIGHT, myThid )
8decba0243 Jean*0194         WRITE(msgBuf,'(A,I9.8)')
                0195      &    ' MDS_WRITE_FIELD: argument irecord = ',irecord
                0196         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
a0e387243c Jean*0197      &                      SQUEEZE_RIGHT, myThid )
                0198         WRITE(msgBuf,'(A)')
8decba0243 Jean*0199      &    ' MDS_WRITE_FIELD: invalid value for irecord'
                0200         CALL PRINT_ERROR( msgBuf, myThid )
                0201         CALL ALL_PROC_DIE( myThid )
                0202         STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
                0203       ENDIF
c0c8c1b5a1 Jean*0204 C check for valid sub-set of levels:
8decba0243 Jean*0205       IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN
e5df3a82bd Jean*0206         WRITE(msgBuf,'(3A,I10)')
d24daa2c55 Jean*0207      &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
                0208         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
a0e387243c Jean*0209      &                      SQUEEZE_RIGHT, myThid )
8decba0243 Jean*0210         WRITE(msgBuf,'(3(A,I6))')
                0211      &    ' MDS_WRITE_FIELD: arguments kSize=', kSize,
                0212      &    ' , kLo=', kLo, ' , kHi=', kHi
                0213         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
a0e387243c Jean*0214      &                      SQUEEZE_RIGHT, myThid )
8decba0243 Jean*0215         WRITE(msgBuf,'(A)')
                0216      &    ' MDS_WRITE_FIELD: invalid sub-set of levels'
                0217         CALL PRINT_ERROR( msgBuf, myThid )
                0218         CALL ALL_PROC_DIE( myThid )
                0219         STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
                0220       ENDIF
                0221 C check for 3-D Buffer size:
                0222       IF ( .NOT.useSingleCpuIO .AND. nNz.GT.size3dBuf ) THEN
e5df3a82bd Jean*0223         WRITE(msgBuf,'(3A,I10)')
d24daa2c55 Jean*0224      &    ' MDS_WRITE_FIELD: file="', fName(1:IL), '" , iter=', myIter
                0225         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
a0e387243c Jean*0226      &                      SQUEEZE_RIGHT, myThid )
8decba0243 Jean*0227         WRITE(msgBuf,'(3(A,I6))')
                0228      &    ' MDS_WRITE_FIELD: Nb Lev to write =', nNz,
                0229      &    ' >', size3dBuf, ' = buffer 3rd Dim'
                0230         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
a0e387243c Jean*0231      &                      SQUEEZE_RIGHT, myThid )
8decba0243 Jean*0232         WRITE(msgBuf,'(A)')
                0233      &    ' MDS_WRITE_FIELD: buffer 3rd Dim. too small'
                0234         CALL PRINT_ERROR( msgBuf, myThid )
                0235         WRITE(msgBuf,'(A)')
                0236      &    ' increase "size3dBuf" in "MDSIO_BUFF_3D.h" and recompile'
                0237         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
a0e387243c Jean*0238      &                      SQUEEZE_RIGHT, myThid)
8decba0243 Jean*0239         CALL ALL_PROC_DIE( myThid )
                0240         STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
                0241       ENDIF
                0242 
                0243 C Only do I/O if I am the master thread
                0244       IF ( iAmDoingIO ) THEN
a9590e7718 Jean*0245 
                0246 C Assign special directory
                0247         IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN
                0248          pfName = fName
                0249         ELSE
                0250          WRITE(pfName,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL)
                0251         ENDIF
                0252         pIL=ILNBLNK( pfName )
db324b9278 Jean*0253         IF ( debugLevel .GE. debLevC ) THEN
                0254           WRITE(msgBuf,'(A,I8,I6,3I4,2A)')
                0255      &      ' MDS_WRITE_FIELD: it,rec,kS,kL,kH=', myIter, jrecord,
                0256      &      kSize, kLo, kHi, ' file=', pfName(1:pIL)
                0257           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0258      &                        SQUEEZE_RIGHT, myThid )
                0259         ENDIF
a9590e7718 Jean*0260 
                0261 C Assign a free unit number as the I/O channel for this routine
                0262         CALL MDSFINDUNIT( dUnit, myThid )
                0263 
                0264 C- endif iAmDoingIO
                0265       ENDIF
                0266 
                0267 C If option globalFile is desired but does not work or if
                0268 C globalFile is too slow, then try using single-CPU I/O.
                0269       IF (useSingleCpuIO) THEN
                0270 
                0271 C Master thread of process 0, only, opens a global file
                0272        IF ( iAmDoingIO ) THEN
                0273          WRITE(dataFName,'(2a)') fName(1:IL),'.data'
9a33636256 Jean*0274          length_of_rec = MDS_RECLEN( filePrec, xSize*ySize, myThid )
a9590e7718 Jean*0275          IF (irecord .EQ. 1) THEN
                0276           OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
                0277      &        access='direct', recl=length_of_rec )
                0278          ELSE
                0279           OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
                0280      &        access='direct', recl=length_of_rec )
                0281          ENDIF
                0282        ENDIF
                0283 
8decba0243 Jean*0284 C Gather array and write it to file, one vertical level at a time
c0c8c1b5a1 Jean*0285        DO k=kLo,kHi
08e96a842a Jean*0286         zeroBuff = k.EQ.kLo
608f4af3c8 Jean*0287 C-      copy from fldRL/RS(level=k) to 2-D "local":
08e96a842a Jean*0288         IF ( filePrec.EQ.precFloat32 ) THEN
                0289           IF ( arrType.EQ.'RS' ) THEN
608f4af3c8 Jean*0290             CALL MDS_PASS_R4toRS( sharedLocBuf_r4, fldRS,
2186fe42a7 Jean*0291      I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
08e96a842a Jean*0292           ELSEIF ( arrType.EQ.'RL' ) THEN
608f4af3c8 Jean*0293             CALL MDS_PASS_R4toRL( sharedLocBuf_r4, fldRL,
2186fe42a7 Jean*0294      I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
08e96a842a Jean*0295           ELSE
d24daa2c55 Jean*0296             WRITE(msgBuf,'(2A)')
                0297      &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
08e96a842a Jean*0298             CALL PRINT_ERROR( msgBuf, myThid )
8decba0243 Jean*0299             CALL ALL_PROC_DIE( myThid )
08e96a842a Jean*0300             STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
                0301           ENDIF
8decba0243 Jean*0302 C Wait for all threads to finish filling shared buffer
                0303           CALL BAR2( myThid )
08e96a842a Jean*0304           CALL GATHER_2D_R4(
f7508ac42d Jean*0305      O                       xy_buffer_r4,
                0306      I                       sharedLocBuf_r4,
08e96a842a Jean*0307      I                       xSize, ySize,
f7508ac42d Jean*0308      I                       useExch2ioLayOut, zeroBuff, myThid )
08e96a842a Jean*0309         ELSEIF ( filePrec.EQ.precFloat64 ) THEN
                0310           IF ( arrType.EQ.'RS' ) THEN
608f4af3c8 Jean*0311             CALL MDS_PASS_R8toRS( sharedLocBuf_r8, fldRS,
2186fe42a7 Jean*0312      I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
08e96a842a Jean*0313           ELSEIF ( arrType.EQ.'RL' ) THEN
608f4af3c8 Jean*0314             CALL MDS_PASS_R8toRL( sharedLocBuf_r8, fldRL,
2186fe42a7 Jean*0315      I                 0, 0, 1, k, kSize, 0, 0, .FALSE., myThid )
08e96a842a Jean*0316           ELSE
d24daa2c55 Jean*0317             WRITE(msgBuf,'(2A)')
                0318      &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
08e96a842a Jean*0319             CALL PRINT_ERROR( msgBuf, myThid )
8decba0243 Jean*0320             CALL ALL_PROC_DIE( myThid )
08e96a842a Jean*0321             STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
                0322           ENDIF
8decba0243 Jean*0323 C Wait for all threads to finish filling shared buffer
                0324           CALL BAR2( myThid )
08e96a842a Jean*0325           CALL GATHER_2D_R8(
f7508ac42d Jean*0326      O                       xy_buffer_r8,
                0327      I                       sharedLocBuf_r8,
08e96a842a Jean*0328      I                       xSize, ySize,
f7508ac42d Jean*0329      I                       useExch2ioLayOut, zeroBuff, myThid )
08e96a842a Jean*0330         ELSE
d24daa2c55 Jean*0331           WRITE(msgBuf,'(A,I6)')
                0332      &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
                0333           CALL PRINT_ERROR( msgBuf, myThid )
                0334           CALL ALL_PROC_DIE( myThid )
                0335           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
a9590e7718 Jean*0336         ENDIF
8decba0243 Jean*0337 C Make other threads wait for "gather" completion so that after this,
                0338 C  shared buffer can again be modified by any thread
                0339         CALL BAR2( myThid )
a9590e7718 Jean*0340 
                0341         IF ( iAmDoingIO ) THEN
9a33636256 Jean*0342           irec = 1 + k-kLo + (irecord-1)*nNz
8decba0243 Jean*0343           IF ( filePrec.EQ.precFloat32 ) THEN
20b1679b8a Jean*0344 #ifdef _BYTESWAPIO
e039218b63 Jean*0345            CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )
20b1679b8a Jean*0346 #endif
e039218b63 Jean*0347            WRITE(dUnit,rec=irec) ( xy_buffer_r4(i),i=1,xSize*ySize )
8decba0243 Jean*0348           ELSE
a9590e7718 Jean*0349 #ifdef _BYTESWAPIO
e039218b63 Jean*0350            CALL MDS_BYTESWAPR8( xSize*ySize, xy_buffer_r8 )
a9590e7718 Jean*0351 #endif
e039218b63 Jean*0352            WRITE(dUnit,rec=irec) ( xy_buffer_r8(i),i=1,xSize*ySize )
a9590e7718 Jean*0353           ENDIF
20b1679b8a Jean*0354 C-      end if iAmDoingIO
a9590e7718 Jean*0355         ENDIF
20b1679b8a Jean*0356 C-     end of k loop
a9590e7718 Jean*0357        ENDDO
                0358 
                0359 C Close data-file
                0360        IF ( iAmDoingIO ) THEN
                0361          CLOSE( dUnit )
                0362        ENDIF
                0363 
                0364 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0365 C---  else .NOT.useSingleCpuIO
                0366       ELSE
                0367 
2186fe42a7 Jean*0368 C Wait for all thread to finish. This prevents other threads (e.g., master)
                0369 C  to continue to acces 3-D buffer while this thread is filling it.
                0370         CALL BAR2( myThid )
                0371 
608f4af3c8 Jean*0372 C---    Copy from fldRL/RS to 3-D buffer (multi-threads):
8decba0243 Jean*0373         IF ( filePrec.EQ.precFloat32 ) THEN
                0374           IF ( arrType.EQ.'RS' ) THEN
608f4af3c8 Jean*0375             CALL MDS_PASS_R4toRS( shared3dBuf_r4, fldRS,
2186fe42a7 Jean*0376      I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
8decba0243 Jean*0377           ELSEIF ( arrType.EQ.'RL' ) THEN
608f4af3c8 Jean*0378             CALL MDS_PASS_R4toRL( shared3dBuf_r4, fldRL,
2186fe42a7 Jean*0379      I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
8decba0243 Jean*0380           ELSE
d24daa2c55 Jean*0381             WRITE(msgBuf,'(2A)')
                0382      &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
8decba0243 Jean*0383             CALL PRINT_ERROR( msgBuf, myThid )
                0384             CALL ALL_PROC_DIE( myThid )
                0385             STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
                0386           ENDIF
                0387         ELSEIF ( filePrec.EQ.precFloat64 ) THEN
                0388           IF ( arrType.EQ.'RS' ) THEN
608f4af3c8 Jean*0389             CALL MDS_PASS_R8toRS( shared3dBuf_r8, fldRS,
2186fe42a7 Jean*0390      I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
8decba0243 Jean*0391           ELSEIF ( arrType.EQ.'RL' ) THEN
608f4af3c8 Jean*0392             CALL MDS_PASS_R8toRL( shared3dBuf_r8, fldRL,
2186fe42a7 Jean*0393      I              0, 0, nNz, kLo, kSize, 0,0, .FALSE., myThid )
8decba0243 Jean*0394           ELSE
d24daa2c55 Jean*0395             WRITE(msgBuf,'(2A)')
                0396      &      ' MDS_WRITE_FIELD: illegal value for arrType=', arrType
8decba0243 Jean*0397             CALL PRINT_ERROR( msgBuf, myThid )
                0398             CALL ALL_PROC_DIE( myThid )
                0399             STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
                0400           ENDIF
                0401         ELSE
d24daa2c55 Jean*0402           WRITE(msgBuf,'(A,I6)')
                0403      &      ' MDS_WRITE_FIELD: illegal value for filePrec=',filePrec
8decba0243 Jean*0404           CALL PRINT_ERROR( msgBuf, myThid )
                0405           CALL ALL_PROC_DIE( myThid )
                0406           STOP 'ABNORMAL END: S/R MDS_WRITE_FIELD'
                0407         ENDIF
                0408 
                0409 C Wait for all threads to finish filling shared buffer
                0410        CALL BAR2( myThid )
                0411 
a9590e7718 Jean*0412 C Only do I/O if I am the master thread
                0413        IF ( iAmDoingIO ) THEN
                0414 
8decba0243 Jean*0415 #ifdef _BYTESWAPIO
                0416         IF ( filePrec.EQ.precFloat32 ) THEN
                0417           CALL MDS_BYTESWAPR4( sNx*sNy*nNz*nSx*nSy, shared3dBuf_r4 )
                0418         ELSE
                0419           CALL MDS_BYTESWAPR8( sNx*sNy*nNz*nSx*nSy, shared3dBuf_r8 )
                0420         ENDIF
                0421 #endif
                0422 
a9590e7718 Jean*0423 C If we are writing to a global file then we open it here
                0424         IF (globalFile) THEN
8decba0243 Jean*0425           WRITE(dataFName,'(2a)') fName(1:IL),'.data'
                0426           length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
                0427           IF (irecord .EQ. 1) THEN
                0428            OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
                0429      &             access='direct', recl=length_of_rec )
                0430           ELSE
                0431            OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
                0432      &             access='direct', recl=length_of_rec )
                0433           ENDIF
                0434           fileIsOpen=.TRUE.
a9590e7718 Jean*0435         ENDIF
                0436 
                0437 C Loop over all tiles
                0438         DO bj=1,nSy
                0439          DO bi=1,nSx
8decba0243 Jean*0440           bBij = sNx*sNy*nNz*( bi-1 + (bj-1)*nSx )
20b1679b8a Jean*0441 
9a33636256 Jean*0442           tNx = sNx
                0443           tNy = sNy
                0444           global_nTx = xSize/sNx
                0445           tBx = myXGlobalLo-1 + (bi-1)*sNx
                0446           tBy = myYGlobalLo-1 + (bj-1)*sNy
a9590e7718 Jean*0447 #ifdef ALLOW_EXCH2
9a33636256 Jean*0448           IF ( useExch2ioLayOut ) THEN
c424ee7cc7 Jean*0449             tN = W2_myTileList(bi,bj)
9a33636256 Jean*0450 c           tNx = exch2_tNx(tN)
                0451 c           tNy = exch2_tNy(tN)
                0452 c           global_nTx = exch2_global_Nx/tNx
                0453             tBx = exch2_txGlobalo(tN) - 1
                0454             tBy = exch2_tyGlobalo(tN) - 1
                0455             IF   ( exch2_mydNx(tN) .GT. xSize ) THEN
                0456 C-          face x-size larger than glob-size : fold it
                0457               iGjLoc = 0
                0458               jGjLoc = exch2_mydNx(tN) / xSize
                0459             ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
                0460 C-          tile y-size larger than glob-size : make a long line
                0461               iGjLoc = exch2_mydNx(tN)
                0462               jGjLoc = 0
                0463             ELSE
                0464 C-          default (face fit into global-IO-array)
                0465               iGjLoc = 0
                0466               jGjLoc = 1
                0467             ENDIF
                0468           ENDIF
a9590e7718 Jean*0469 #endif /* ALLOW_EXCH2 */
9a33636256 Jean*0470 
                0471           IF (globalFile) THEN
                0472 C--- Case of 1 Global file:
                0473 
                0474            DO k=kLo,kHi
a9590e7718 Jean*0475             DO j=1,tNy
9a33636256 Jean*0476              irec = 1 + ( tBx + (j-1)*iGjLoc )/tNx
                0477      &                + ( tBy + (j-1)*jGjLoc )*global_nTx
                0478      &            +( k-kLo + (irecord-1)*nNz )*global_nTx*ySize
8decba0243 Jean*0479              i1 = bBij + 1 + (j-1)*sNx + (k-kLo)*sNx*sNy
                0480              i2 = bBij +         j*sNx + (k-kLo)*sNx*sNy
                0481              IF ( filePrec.EQ.precFloat32 ) THEN
                0482               WRITE(dUnit,rec=irec) (shared3dBuf_r4(i),i=i1,i2)
a9590e7718 Jean*0483              ELSE
8decba0243 Jean*0484               WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
a9590e7718 Jean*0485              ENDIF
8decba0243 Jean*0486 C End of j,k loops
a9590e7718 Jean*0487             ENDDO
                0488            ENDDO
9a33636256 Jean*0489 
a9590e7718 Jean*0490           ELSE
9a33636256 Jean*0491 C--- Case of 1 file per tile (globalFile=F):
                0492 
                0493 C If we are writing to a tiled MDS file then we open each one here
                0494            iG=bi+(myXGlobalLo-1)/sNx
                0495            jG=bj+(myYGlobalLo-1)/sNy
                0496            WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
8decba0243 Jean*0497      &            pfName(1:pIL),'.',iG,'.',jG,'.data'
                0498            length_of_rec = MDS_RECLEN( filePrec, sNx*sNy*nNz, myThid )
9a33636256 Jean*0499            IF (irecord .EQ. 1) THEN
                0500             OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
                0501      &            access='direct', recl=length_of_rec )
                0502            ELSE
                0503             OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
                0504      &            access='direct', recl=length_of_rec )
                0505            ENDIF
                0506            fileIsOpen=.TRUE.
                0507 
8decba0243 Jean*0508            irec = irecord
                0509            i1 = bBij + 1
                0510            i2 = bBij + sNx*sNy*nNz
                0511            IF ( filePrec.EQ.precFloat32 ) THEN
                0512              WRITE(dUnit,rec=irec) (shared3dBuf_r4(i),i=i1,i2)
                0513            ELSE
                0514              WRITE(dUnit,rec=irec) (shared3dBuf_r8(i),i=i1,i2)
                0515            ENDIF
9a33636256 Jean*0516 
                0517 C here We close the tiled MDS file
                0518            IF ( fileIsOpen ) THEN
8decba0243 Jean*0519              CLOSE( dUnit )
                0520              fileIsOpen = .FALSE.
9a33636256 Jean*0521            ENDIF
                0522 
                0523 C--- End Global File / tile-file cases
a9590e7718 Jean*0524           ENDIF
9a33636256 Jean*0525 
a9590e7718 Jean*0526 C Create meta-file for each tile if we are tiling
                0527           IF ( .NOT.globalFile .AND. writeMetaF ) THEN
                0528            iG=bi+(myXGlobalLo-1)/sNx
                0529            jG=bj+(myYGlobalLo-1)/sNy
                0530            WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')
                0531      &              pfName(1:pIL),'.',iG,'.',jG,'.meta'
e039218b63 Jean*0532            dimList(1,1) = xSize
f7508ac42d Jean*0533            dimList(2,1) = tBx + 1
                0534            dimList(3,1) = tBx + tNx
e039218b63 Jean*0535            dimList(1,2) = ySize
f7508ac42d Jean*0536            dimList(2,2) = tBy + 1
                0537            dimList(3,2) = tBy + tNy
e039218b63 Jean*0538            dimList(1,3) = nNz
                0539            dimList(2,3) = 1
                0540            dimList(3,3) = nNz
9a33636256 Jean*0541 c          dimList(1,3) = kSize
                0542 c          dimList(2,3) = kLo
                0543 c          dimList(3,3) = kHi
e039218b63 Jean*0544            nDims = 3
                0545            IF ( nNz.EQ.1 ) nDims = 2
20b1679b8a Jean*0546            map2gl(1) = iGjLoc
                0547            map2gl(2) = jGjLoc
a9590e7718 Jean*0548            CALL MDS_WRITE_META(
                0549      I              metaFName, dataFName, the_run_name, ' ',
fbc6fb65d0 Jean*0550      I              filePrec, nDims, dimList, map2gl, 0, blank8c,
a50692f9cd Jean*0551      I              0, dummyRL, oneRL, irecord, myIter, myThid )
a9590e7718 Jean*0552           ENDIF
9a33636256 Jean*0553 
a9590e7718 Jean*0554 C End of bi,bj loops
                0555          ENDDO
                0556         ENDDO
                0557 
                0558 C If global file was opened then close it
                0559         IF (fileIsOpen .AND. globalFile) THEN
8decba0243 Jean*0560           CLOSE( dUnit )
                0561           fileIsOpen = .FALSE.
a9590e7718 Jean*0562         ENDIF
                0563 
                0564 C- endif iAmDoingIO
                0565        ENDIF
                0566 
8decba0243 Jean*0567 C Make other threads wait for I/O completion so that after this,
                0568 C  3-D buffer can again be modified by any thread
2186fe42a7 Jean*0569 c      CALL BAR2( myThid )
8decba0243 Jean*0570 
a9590e7718 Jean*0571 C     if useSingleCpuIO / else / end
                0572       ENDIF
                0573 
                0574 C Create meta-file for the global-file (also if useSingleCpuIO)
                0575       IF ( writeMetaF .AND. iAmDoingIO .AND.
                0576      &    (globalFile .OR. useSingleCpuIO) ) THEN
                0577          WRITE(metaFName,'(2A)') fName(1:IL),'.meta'
e039218b63 Jean*0578          dimList(1,1) = xSize
                0579          dimList(2,1) = 1
                0580          dimList(3,1) = xSize
                0581          dimList(1,2) = ySize
                0582          dimList(2,2) = 1
                0583          dimList(3,2) = ySize
                0584          dimList(1,3) = nNz
                0585          dimList(2,3) = 1
                0586          dimList(3,3) = nNz
9a33636256 Jean*0587 c        dimList(1,3) = kSize
                0588 c        dimList(2,3) = kLo
                0589 c        dimList(3,3) = kHi
e039218b63 Jean*0590          nDims = 3
                0591          IF ( nNz.EQ.1 ) nDims = 2
ade0dcb979 Jean*0592          map2gl(1) = 0
                0593          map2gl(2) = 1
a9590e7718 Jean*0594          CALL MDS_WRITE_META(
                0595      I              metaFName, dataFName, the_run_name, ' ',
fbc6fb65d0 Jean*0596      I              filePrec, nDims, dimList, map2gl, 0, blank8c,
a50692f9cd Jean*0597      I              0, dummyRL, oneRL, irecord, myIter, myThid )
a9590e7718 Jean*0598 c    I              metaFName, dataFName, the_run_name, titleLine,
20b1679b8a Jean*0599 c    I              filePrec, nDims, dimList, map2gl, nFlds,  fldList,
a50692f9cd Jean*0600 c    I              nTimRec, timList, misVal, irecord, myIter, myThid )
a9590e7718 Jean*0601       ENDIF
                0602 
                0603 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0604       RETURN
                0605       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!