Back to home page

MITgcm
 
 

    

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

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
bc94cbd36f Jean*0001 #include "MDSIO_OPTIONS.h"
                0002 
                0003 CBOP
                0004 C !ROUTINE: MDS_WRITE_TAPE
                0005 C !INTERFACE:
                0006       SUBROUTINE MDS_WRITE_TAPE(
                0007      I   fName,
                0008      I   filePrec,
                0009      I   globalfile,
                0010      I   arrType,
                0011      I   nSize,
                0012      I   fldR8, fldR4,
                0013      I   singleCpuIO,
                0014      I   iRec,
                0015      I   myIter,
                0016      I   myThid )
                0017 
                0018 C !DESCRIPTION:
                0019 C MDS_WRITE_TAPE: write an array (treated as vector) to a tape-file
                0020 C  (renamed from MDSWRITEVECTOR with 2 explicit input array types)
                0021 C
                0022 C Arguments:
                0023 C fName      string  :: base name for file to write
                0024 C filePrec   integer :: number of bits per word in file (32 or 64)
                0025 C globalFile logical :: selects between writing a global or tiled file
                0026 C arrType    char(2) :: which array (fldR8/R4) to write, either "R8" or "R4"
                0027 C nSize      integer :: number of elements of input array "fldR8/R4" to write
                0028 C fldR8      ( R8 )  :: array to write if arrType="R8", fldR8(nSize)
                0029 C fldR4      ( R4 )  :: array to write if arrType="R4", fldR4(nSize)
                0030 C bi,bj      integer :: tile indices (if tiled array)
                0031 C singleCpuIO ( L )  :: only proc 0 do IO and collect data from other procs
                0032 C iRec       integer :: record number to write
                0033 C myIter     integer :: time step number
                0034 C myThid     integer :: my Thread Id number
                0035 
                0036 C !USES:
                0037       IMPLICIT NONE
                0038 
                0039 C-- Global variables --
                0040 #include "SIZE.h"
                0041 #include "EEPARAMS.h"
                0042 #include "PARAMS.h"
                0043 
                0044 C !INPUT/OUTPUT PARAMETERS:
                0045       CHARACTER*(*) fName
                0046       INTEGER filePrec
                0047       LOGICAL globalfile
                0048       CHARACTER*(2) arrType
                0049       INTEGER nSize
                0050       _R8     fldR8(*)
                0051       _R4     fldR4(*)
                0052       LOGICAL singleCpuIO
                0053       INTEGER iRec
                0054       INTEGER myIter
                0055       INTEGER myThid
                0056 
                0057 #ifdef ALLOW_AUTODIFF
                0058 
                0059 C !FUNCTIONS:
                0060       INTEGER ILNBLNK
                0061       INTEGER MDS_RECLEN
                0062       EXTERNAL ILNBLNK
                0063       EXTERNAL MDS_RECLEN
                0064 
                0065 C !LOCAL VARIABLES:
                0066       CHARACTER*(MAX_LEN_FNAM) dataFName, metaFName, pfName
                0067       INTEGER iG, jG, jRec, dUnit, IL, pIL
                0068       INTEGER dimList(3,1), nDims, map2gl(2)
                0069       INTEGER length_of_rec
                0070       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0071 
                0072 C simple implementation of singleCpuIO without any specific EXCH2
                0073 C feature (should work as long as reading and writing match)
                0074       INTEGER j
                0075       INTEGER vec_size
                0076 C Note: would be better to use explicit (allocate/delocate) dynamical
                0077 C       allocation instead of this implicit form:
                0078       _R8    gl_buffer_r8(nSize*nPx*nPy)
                0079       _R4    gl_buffer_r4(nSize*nPx*nPy)
                0080       _R8    local_r8    (nSize)
                0081       _R4    local_r4    (nSize)
                0082       _RL dummyRL(1)
                0083       CHARACTER*8 blank8c
                0084 CEOP
                0085 
                0086       DATA dummyRL(1) / 0. _d 0 /
                0087       DATA blank8c / '        ' /
                0088       DATA map2gl  / 0, 1 /
                0089 
                0090       vec_size = nSize*nPx*nPy
                0091 
                0092 C--   Copy input array to local buffer
                0093         IF ( arrType.EQ.'R4' ) THEN
                0094           IF ( filePrec.EQ.precFloat32 ) THEN
                0095             DO j=1,nSize
                0096               local_r4(j) = fldR4(j)
                0097             ENDDO
                0098           ELSE
                0099             DO j=1,nSize
                0100               local_r8(j) = fldR4(j)
                0101             ENDDO
                0102           ENDIF
                0103         ELSEIF ( arrType.EQ.'R8' ) THEN
                0104           IF ( filePrec.EQ.precFloat32 ) THEN
                0105             DO j=1,nSize
                0106               local_r4(j) = fldR8(j)
                0107             ENDDO
                0108           ELSE
                0109             DO j=1,nSize
                0110               local_r8(j) = fldR8(j)
                0111             ENDDO
                0112           ENDIF
                0113         ELSE
                0114           WRITE(msgBuf,'(A)')
                0115      &         ' MDS_WRITE_TAPE: illegal value for arrType'
                0116           CALL PRINT_ERROR( msgBuf, myThid )
                0117           STOP 'ABNORMAL END: S/R MDS_WRITE_TAPE'
                0118         ENDIF
                0119 
                0120 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0121 
                0122 C--   Only do I/O if I am the master thread
                0123       _BEGIN_MASTER( myThid )
                0124 
                0125 C-    Record number must be >= 1
                0126       IF ( iRec.LT.1 ) THEN
                0127        WRITE(msgBuf,'(A,I10)')
                0128      &   ' MDS_WRITE_TAPE: argument iRec =',iRec
                0129        CALL PRINT_ERROR( msgBuf, myThid )
                0130        WRITE(msgBuf,'(A)')
                0131      &   ' MDS_WRITE_TAPE: invalid value for iRec'
                0132        CALL PRINT_ERROR( msgBuf, myThid )
                0133        STOP 'ABNORMAL END: S/R MDS_WRITE_TAPE'
                0134       ENDIF
                0135 
                0136 C-    Assume nothing
                0137       IL  = ILNBLNK( fName )
                0138       pIL = ILNBLNK( mdsioLocalDir )
                0139 
                0140 C-    Assign special directory
                0141       IF ( pIL.EQ.0 ) THEN
                0142         pfName = fName
                0143       ELSE
                0144         WRITE(pfName,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL)
                0145       ENDIF
                0146       pIL = ILNBLNK( pfName )
                0147       IF ( debugLevel.GE.debLevC .AND.
                0148      &     ( .NOT.singleCpuIO .OR. myProcId.EQ.0 ) ) THEN
                0149         WRITE(msgBuf,'(A,I8,2A)')
                0150      &      ' MDS_WRITE_TAPE: iRec=', iRec, ', file=', pfName(1:pIL)
                0151         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0152      &                      SQUEEZE_RIGHT, myThid )
                0153       ENDIF
                0154 
                0155 C-    Assign a free unit number as the I/O channel for this routine
                0156       CALL MDSFINDUNIT( dUnit, myThid )
                0157 
                0158 C     If option globalFile is desired but does not work or if
                0159 C     globalFile is too slow, then try using single-CPU I/O.
                0160       IF ( singleCpuIO ) THEN
                0161 
                0162 C-    Gather array from all procs
                0163         IF ( filePrec.EQ.precFloat32 ) THEN
                0164           CALL GATHER_VEC_R4( gl_buffer_r4, local_r4, nSize, myThid )
                0165         ELSEIF ( filePrec.EQ.precFloat64 ) THEN
                0166           CALL GATHER_VEC_R8( gl_buffer_r8, local_r8, nSize, myThid )
                0167         ELSE
                0168           WRITE(msgBuf,'(A)')
                0169      &            ' MDS_WRITE_TAPE: illegal value for filePrec'
                0170           CALL PRINT_ERROR( msgBuf, myThid )
                0171           STOP 'ABNORMAL END: S/R MDS_WRITE_TAPE'
                0172         ENDIF
                0173 
                0174         IF ( myProcId .EQ. 0 ) THEN
                0175 C--   Master thread of process 0, only, opens a global file
                0176 
                0177          WRITE(dataFName,'(2a)') fName(1:IL),'.data'
                0178          length_of_rec = MDS_RECLEN( filePrec, vec_size, myThid )
                0179          IF (iRec .EQ. 1) THEN
                0180           OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
                0181      &          access='direct', recl=length_of_rec )
                0182          ELSE
                0183           OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
                0184      &          access='direct', recl=length_of_rec )
                0185          ENDIF
                0186 
                0187 C-    Write global buffer to file:
                0188          IF ( filePrec.EQ.precFloat32 ) THEN
                0189 #ifdef _BYTESWAPIO
                0190            CALL MDS_BYTESWAPR4( vec_size, gl_buffer_r4 )
                0191 #endif
                0192            WRITE(dUnit,rec=iRec) gl_buffer_r4
                0193          ELSEIF ( filePrec.EQ.precFloat64 ) THEN
                0194 #ifdef _BYTESWAPIO
                0195            CALL MDS_BYTESWAPR8( vec_size, gl_buffer_r8 )
                0196 #endif
                0197            WRITE(dUnit,rec=iRec) gl_buffer_r8
                0198          ENDIF
                0199 
                0200 C-    Close data-file and create meta-file
                0201          CLOSE( dUnit )
                0202          WRITE(metaFName,'(2a)') fName(1:IL),'.meta'
                0203          dimList(1,1) = vec_size
                0204          dimList(2,1) = 1
                0205          dimList(3,1) = vec_size
                0206          nDims = 1
                0207          CALL MDS_WRITE_META(
                0208      I              metaFName, dataFName, the_run_name, ' ',
                0209      I              filePrec, nDims, dimList, map2gl, 0, blank8c,
                0210      I              0, dummyRL, oneRL, iRec, myIter, myThid )
                0211 
                0212 C-    end if myProcId=0
                0213         ENDIF
                0214 
                0215 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0216 C     if ( singleCpuIO ), else
                0217       ELSEIF ( .NOT. singleCpuIO ) THEN
                0218 
                0219         IF ( globalFile ) THEN
                0220 C-    If we are writing to a global file then we open it here
                0221          WRITE(dataFName,'(2A)') fName(1:IL),'.data'
                0222          length_of_rec = MDS_RECLEN( filePrec, nSize, myThid )
                0223          IF ( iRec.EQ.1 ) THEN
                0224           OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
                0225      &          access='direct', recl=length_of_rec )
                0226          ELSE
                0227           OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
                0228      &          access='direct', recl=length_of_rec )
                0229          ENDIF
                0230 
                0231         ELSE
                0232 C-    If we are writing to a tiled MDS file then we open each one here
                0233          iG = 1 + (myXGlobalLo-1)/sNx
                0234          jG = 1 + (myYGlobalLo-1)/sNy
                0235          WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
                0236      &              pfName(1:pIL),'.',iG,'.',jG,'.data'
                0237          length_of_rec = MDS_RECLEN( filePrec, nSize, myThid )
                0238          IF (iRec .EQ. 1) THEN
                0239           OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
                0240      &          access='direct', recl=length_of_rec )
                0241          ELSE
                0242           OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
                0243      &          access='direct', recl=length_of_rec )
                0244          ENDIF
                0245         ENDIF
                0246 
                0247 C-    Write local buffer to file:
                0248         IF (globalFile) THEN
                0249 C-- Original: nPy=2, nSx=2 -> produces too large file (1.5 x normal size)
                0250 c          iG   = myXGlobalLo-1+(bi-1)*sNx
                0251 c          jG   = myYGlobalLo-1+(bj-1)*sNy
                0252 c          jRec = 1 + int(iG/sNx) + (jG/sNy)*nSx*nPx +
                0253 c    &            (iRec-1)*nSx*nPx*nSy*nPy
                0254 C-- Alternative: same layout as in scatter/gather_vector (for singleCpuIO)
                0255 C   problem: nPx=2, nSx=2, writing a global (i.e., with bi,bj dim);
                0256 C-         2nd proc get iG=3 -> badly placed data over nPx*nPy*nSize range
                0257 C                               that will be overwritten by next record
                0258 c          iG   = 1 + (myXGlobalLo-1)/sNx
                0259 c          jG   = 1 + (myYGlobalLo-1)/sNy
                0260 c          jRec = iG + (jG-1)*nPx + (iRec-1)*nPx*nPy
                0261 C-- Simpler: should work (but hard to interpret the sequence of data in file)
                0262            jRec = 1 + myProcId + (iRec-1)*nPx*nPy
                0263         ELSE
                0264            jRec = iRec
                0265         ENDIF
                0266         IF ( filePrec.EQ.precFloat32 ) THEN
                0267 #ifdef _BYTESWAPIO
                0268            CALL MDS_BYTESWAPR4( nSize, local_r4 )
                0269 #endif
                0270            WRITE(dUnit,rec=jRec) local_r4
                0271         ELSEIF ( filePrec.EQ.precFloat64 ) THEN
                0272 #ifdef _BYTESWAPIO
                0273            CALL MDS_BYTESWAPR8( nSize, local_r8 )
                0274 #endif
                0275            WRITE(dUnit,rec=jRec) local_r8
                0276         ELSE
                0277            WRITE(msgBuf,'(A)')
                0278      &           ' MDS_WRITE_TAPE: illegal value for filePrec'
                0279            CALL PRINT_ERROR( msgBuf, myThid )
                0280            STOP 'ABNORMAL END: S/R MDS_WRITE_TAPE'
                0281         ENDIF
                0282 
                0283 C-    Close data-file and create meta-file
                0284         CLOSE( dUnit )
                0285         IF ( globalFile ) THEN
                0286 C     meta-file for global file
                0287           WRITE(metaFName,'(2A)') fName(1:IL),'.meta'
                0288           dimList(1,1) = vec_size
                0289           dimList(2,1) = 1
                0290           dimList(3,1) = vec_size
                0291           nDims = 1
                0292         ELSE
                0293 C     meta-file for tiled file
                0294           iG = 1 + (myXGlobalLo-1)/sNx
                0295           jG = 1 + (myYGlobalLo-1)/sNy
                0296           WRITE(metaFName,'(2A,I3.3,A,I3.3,A)')
                0297      &             pfName(1:pIL),'.',iG,'.',jG,'.meta'
                0298           dimList(1,1) = nPx*nPy*nSize
                0299           dimList(2,1) = 1 + myProcId*nSize
                0300           dimList(3,1) = (1+myProcId)*nSize
                0301           nDims = 1
                0302         ENDIF
                0303 C-    write meta-file
                0304         CALL MDS_WRITE_META(
                0305      I              metaFName, dataFName, the_run_name, ' ',
                0306      I              filePrec, nDims, dimList, map2gl, 0, blank8c,
                0307      I              0, dummyRL, oneRL, iRec, myIter, myThid )
                0308 c    I              metaFName, dataFName, the_run_name, titleLine,
                0309 c    I              filePrec, nDims, dimList, map2gl, nFlds, fldList,
                0310 c    I              nTimRec, timList, misVal, iRec, myIter, myThid )
                0311 
                0312 C     end-if ( .not. singleCpuIO )
                0313       ENDIF
                0314 
                0315       _END_MASTER( myThid )
                0316 
                0317 #else /* ALLOW_AUTODIFF */
                0318       STOP 'ABNORMAL END: S/R MDS_WRITE_TAPE is empty'
                0319 #endif /* ALLOW_AUTODIFF */
                0320 
                0321       RETURN
                0322       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!