Back to home page

MITgcm
 
 

    

File indexing completed on 2022-04-14 05:09:28 UTC

view on githubraw file Latest commit 3d93c0a0 on 2022-04-13 15:21:38 UTC
bc94cbd36f Jean*0001 #include "MDSIO_OPTIONS.h"
                0002 
                0003 CBOP
                0004 C !ROUTINE: MDS_READ_TAPE
                0005 C !INTERFACE:
                0006       SUBROUTINE MDS_READ_TAPE(
                0007      I   fName,
                0008      I   filePrec,
                0009      I   arrType,
                0010      I   nSize,
                0011      O   fldR8, fldR4,
                0012      I   singleCpuIO,
                0013      I   iRec,
                0014      I   myThid )
                0015 
                0016 C !DESCRIPTION:
                0017 C MDS_READ_TAPE: load an array (treated as vector) for a tape-file
                0018 C  (renamed from MDSREADVECTOR with 2 explicit output array typest)
                0019 C
                0020 C Arguments:
                0021 C fName      string  :: base name for file to read
                0022 C filePrec   integer :: number of bits per word in file (32 or 64)
                0023 C arrType    char(2) :: which array (fldR8/R4) to read, either "R8" or "R4"
                0024 C nSize      integer :: number of elements of input array "fldR8/R4" to read
                0025 C fldR8      ( R8 )  :: array to read if arrType="R8", fldR8(nSize)
                0026 C fldR4      ( R4 )  :: array to read if arrType="R4", fldR4(nSize)
                0027 C singleCpuIO ( L )  :: only proc 0 do IO and send data to other procs
                0028 C iRec       integer :: record number to read
                0029 C myThid     integer :: my Thread Id number
                0030 
                0031 C !USES:
                0032       IMPLICIT NONE
                0033 
                0034 C-- Global variables --
                0035 #include "SIZE.h"
                0036 #include "EEPARAMS.h"
                0037 #include "PARAMS.h"
                0038 
                0039 C !INPUT/OUTPUT PARAMETERS:
                0040       CHARACTER*(*) fName
                0041       INTEGER filePrec
                0042       CHARACTER*(2) arrType
                0043       INTEGER nSize
                0044       _R8     fldR8(*)
                0045       _R4     fldR4(*)
                0046       LOGICAL singleCpuIO
                0047       INTEGER iRec
                0048       INTEGER myThid
                0049 
                0050 #ifdef ALLOW_AUTODIFF
                0051 
                0052 C !FUNCTIONS:
                0053       INTEGER ILNBLNK
                0054       INTEGER MDS_RECLEN
                0055       EXTERNAL ILNBLNK
                0056       EXTERNAL MDS_RECLEN
                0057 
                0058 C !LOCAL VARIABLES:
                0059       CHARACTER*(MAX_LEN_FNAM) dataFName, pfName
                0060       INTEGER iG, jG, jRec, dUnit, IL, pIL
                0061       LOGICAL exst
                0062       LOGICAL globalFile, fileIsOpen
                0063       INTEGER length_of_rec
                0064       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0065 
                0066 C simple implementation of singleCpuIO without any specific EXCH2
                0067 C feature (should work as long as reading and writing match)
                0068       INTEGER j
                0069       INTEGER vec_size
                0070 C Note: would be better to use explicit (allocate/delocate) dynamical
                0071 C       allocation instead of this implicit form:
                0072       _R8    gl_buffer_r8(nSize*nPx*nPy)
                0073       _R4    gl_buffer_r4(nSize*nPx*nPy)
                0074       _R8    local_r8    (nSize)
                0075       _R4    local_r4    (nSize)
                0076 CEOP
                0077 
                0078       vec_size = nSize*nPx*nPy
                0079 
                0080 C--   Only do I/O if I am the master thread
                0081       _BEGIN_MASTER( myThid )
                0082 
                0083 C-    Record number must be >= 1
                0084       IF ( iRec.LT.1 ) THEN
                0085        WRITE(msgBuf,'(A,I10)')
                0086      &   ' MDS_READ_TAPE: argument iRec =',iRec
                0087        CALL PRINT_ERROR( msgBuf, myThid )
                0088        WRITE(msgBuf,'(A)')
                0089      &   ' MDS_READ_TAPE: invalid value for iRec'
                0090        CALL PRINT_ERROR( msgBuf, myThid )
                0091        STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
                0092       ENDIF
                0093 
                0094 C-    Assume nothing
                0095       globalFile = .FALSE.
                0096       fileIsOpen = .FALSE.
                0097       IL  = ILNBLNK( fName )
                0098       pIL = ILNBLNK( mdsioLocalDir )
                0099 
                0100 C-    Assign special directory
                0101       IF ( mdsioLocalDir .NE. ' ' ) THEN
                0102        WRITE(pfName,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL)
                0103       ELSE
                0104        pfName = fName
                0105       ENDIF
                0106       pIL = ILNBLNK( pfName )
                0107 
                0108 C-    Assign a free unit number as the I/O channel for this routine
                0109       CALL MDSFINDUNIT( dUnit, myThid )
                0110 
                0111 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0112       IF ( singleCpuIO ) THEN
                0113 
                0114         IF ( myProcId .EQ. 0 ) THEN
                0115 C--   Master thread of process 0, only, opens a global file
                0116 
                0117 C-    Check first for global file with with MDS name (ie. fName.data)
                0118          WRITE(dataFName,'(2A)') fName(1:IL),'.data'
                0119          INQUIRE( file=dataFName, exist=exst )
                0120          IF (exst) globalFile = .TRUE.
                0121 
                0122 C-    If global file is visible to process 0, then open it here.
                0123          IF ( globalFile ) THEN
                0124           IF ( debugLevel .GE. debLevB ) THEN
                0125            WRITE(msgBuf,'(A,A)')
                0126      &     ' MDS_READ_TAPE: opening global file: ',dataFName(1:IL+5)
                0127            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0128      &                         SQUEEZE_RIGHT, myThid )
                0129           ENDIF
                0130           length_of_rec = MDS_RECLEN( filePrec, vec_size, myThid )
3d93c0a01e Ou W*0131           OPEN( dUnit, file=dataFName, status='old', _READONLY_ACTION
bc94cbd36f Jean*0132      &          access='direct', recl=length_of_rec )
                0133          ELSE
                0134 C     Otherwise stop program.
                0135           WRITE(msgBuf,'(2A)')
                0136      &      ' MDS_READ_TAPE: filename: ',dataFName(1:IL)
                0137 C-jmc: why double print (stdout + stderr) ?
                0138           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0139      &                        SQUEEZE_RIGHT, myThid )
                0140           CALL PRINT_ERROR( msgBuf, myThid )
                0141           WRITE(msgBuf,'(A)')
                0142      &      ' MDS_READ_TAPE: File does not exist'
                0143           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0144      &                        SQUEEZE_RIGHT, myThid )
                0145           CALL PRINT_ERROR( msgBuf, myThid )
                0146           STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
                0147          ENDIF
                0148 
                0149 C-    Read into global buffer:
                0150          IF ( filePrec.EQ.precFloat32 ) THEN
                0151            READ(dUnit,rec=iRec) gl_buffer_r4
                0152 #ifdef _BYTESWAPIO
                0153            CALL MDS_BYTESWAPR4( vec_size, gl_buffer_r4 )
                0154 #endif
                0155          ELSEIF ( filePrec.EQ.precFloat64 ) THEN
                0156            READ(dUnit,rec=iRec) gl_buffer_r8
                0157 #ifdef _BYTESWAPIO
                0158            CALL MDS_BYTESWAPR8( vec_size, gl_buffer_r8 )
                0159 #endif
                0160          ENDIF
                0161 
                0162 C-    Close data-file
                0163          CLOSE( dUnit )
                0164 
                0165 C--   end if myProcId=0
                0166         ENDIF
                0167 
                0168         IF ( filePrec.EQ.precFloat32 ) THEN
                0169           CALL SCATTER_VEC_R4( gl_buffer_r4, local_r4, nSize, myThid )
                0170         ELSEIF ( filePrec.EQ.precFloat64 ) THEN
                0171           CALL SCATTER_VEC_R8( gl_buffer_r8, local_r8, nSize, myThid )
                0172         ELSE
                0173           WRITE(msgBuf,'(A)')
                0174      &            ' MDS_READ_TAPE: illegal value for filePrec'
                0175           CALL PRINT_ERROR( msgBuf, myThid )
                0176           STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
                0177         ENDIF
                0178 
                0179 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0180 C     if ( singleCpuIO ), else
                0181       ELSEIF ( .NOT. singleCpuIO ) THEN
                0182 
                0183 C-    Check first for global file with with MDS name (ie. fName.data)
                0184         WRITE(dataFName,'(2A)') fName(1:IL),'.data'
                0185         INQUIRE( file=dataFName, exist=exst )
                0186         IF (exst) THEN
                0187           IF ( debugLevel .GE. debLevB ) THEN
                0188            WRITE(msgBuf,'(A,A)')
                0189      &     ' MDS_READ_TAPE: opening global file: ',dataFName(1:IL+5)
                0190            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0191      &                         SQUEEZE_RIGHT, myThid )
                0192           ENDIF
                0193           globalFile = .TRUE.
                0194 C-    And open it here
                0195           length_of_rec = MDS_RECLEN( filePrec, nSize, myThid )
3d93c0a01e Ou W*0196           OPEN( dUnit, file=dataFName, status='old',_READONLY_ACTION 
bc94cbd36f Jean*0197      &          access='direct', recl=length_of_rec )
                0198           fileIsOpen=.TRUE.
                0199         ENDIF
                0200 
                0201 C-    If we are reading from a tiled MDS file then we open each one here
                0202         IF ( .NOT.globalFile ) THEN
                0203          iG = 1 + (myXGlobalLo-1)/sNx
                0204          jG = 1 + (myYGlobalLo-1)/sNy
                0205          WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
                0206      &              pfName(1:pIL),'.',iG,'.',jG,'.data'
                0207          INQUIRE( file=dataFName, exist=exst )
                0208          IF (exst) THEN
                0209           IF ( debugLevel .GE. debLevB ) THEN
                0210            WRITE(msgBuf,'(A,A)')
                0211      &      ' MDS_READ_TAPE: opening file: ',dataFName(1:pIL+13)
                0212            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0213      &                         SQUEEZE_RIGHT, myThid )
                0214           ENDIF
                0215           length_of_rec = MDS_RECLEN( filePrec, nSize, myThid )
3d93c0a01e Ou W*0216           OPEN( dUnit, file=dataFName, status='old',_READONLY_ACTION 
bc94cbd36f Jean*0217      &          access='direct', recl=length_of_rec )
                0218           fileIsOpen=.TRUE.
                0219          ELSE
                0220           fileIsOpen=.FALSE.
                0221           WRITE(msgBuf,'(4A)')
                0222      &      ' MDS_READ_TAPE: missing file: ',fName(1:IL),
                0223      &                                 ' , ',dataFName(1:pIL+13)
                0224           CALL PRINT_ERROR( msgBuf, myThid )
                0225           STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
                0226          ENDIF
                0227         ENDIF
                0228 
                0229         IF ( fileIsOpen ) THEN
                0230           IF ( globalFile ) THEN
                0231 C-    read the same way it was written:
                0232             jRec = 1 + myProcId + (iRec-1)*nPx*nPy
                0233           ELSE
                0234             jRec = iRec
                0235           ENDIF
                0236           IF ( filePrec.EQ.precFloat32 ) THEN
                0237            READ(dUnit,rec=jRec) local_r4
                0238 #ifdef _BYTESWAPIO
                0239            CALL MDS_BYTESWAPR4( nSize, local_r4 )
                0240 #endif
                0241           ELSEIF ( filePrec.EQ.precFloat64 ) THEN
                0242            READ(dUnit,rec=jRec) local_r8
                0243 #ifdef _BYTESWAPIO
                0244            CALL MDS_BYTESWAPR8( nSize, local_r8 )
                0245 #endif
                0246           ELSE
                0247            WRITE(msgBuf,'(A)')
                0248      &            ' MDS_READ_TAPE: illegal value for filePrec'
                0249            CALL PRINT_ERROR( msgBuf, myThid )
                0250            STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
                0251           ENDIF
                0252 C--   If file was opened then close it
                0253           CLOSE( dUnit )
                0254           fileIsOpen = .FALSE.
                0255         ENDIF
                0256 
                0257 C     end-if ( .not. singleCpuIO )
                0258       ENDIF
                0259 
                0260       _END_MASTER( myThid )
                0261 
                0262 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0263 
                0264 C--   Copy local buffer into output array
                0265         IF ( arrType.EQ.'R4' ) THEN
                0266           IF ( filePrec.EQ.precFloat32 ) THEN
                0267             DO j=1,nSize
                0268               fldR4(j) = local_r4(j)
                0269             ENDDO
                0270           ELSE
                0271             DO j=1,nSize
                0272               fldR4(j) = local_r8(j)
                0273             ENDDO
                0274           ENDIF
                0275         ELSEIF ( arrType.EQ.'R8' ) THEN
                0276           IF ( filePrec.EQ.precFloat32 ) THEN
                0277             DO j=1,nSize
                0278               fldR8(j) = local_r4(j)
                0279             ENDDO
                0280           ELSE
                0281             DO j=1,nSize
                0282               fldR8(j) = local_r8(j)
                0283             ENDDO
                0284           ENDIF
                0285         ELSE
                0286           WRITE(msgBuf,'(A)')
                0287      &          ' MDS_READ_TAPE: illegal value for arrType'
                0288           CALL PRINT_ERROR( msgBuf, myThid )
                0289           STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
                0290         ENDIF
                0291 
                0292 #else /* ALLOW_AUTODIFF */
                0293       STOP 'ABNORMAL END: S/R MDS_READ_TAPE is empty'
                0294 #endif /* ALLOW_AUTODIFF */
                0295 
                0296       RETURN
                0297       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!