C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_read_tape.F,v 1.1 2013/10/17 00:30:46 jmc Exp $
C $Name: $
#include "MDSIO_OPTIONS.h"
CBOP
C !ROUTINE: MDS_READ_TAPE
C !INTERFACE:
SUBROUTINE MDS_READ_TAPE(
I fName,
I filePrec,
I arrType,
I nSize,
O fldR8, fldR4,
I singleCpuIO,
I iRec,
I myThid )
C !DESCRIPTION:
C MDS_READ_TAPE: load an array (treated as vector) for a tape-file
C (renamed from MDSREADVECTOR with 2 explicit output array typest)
C
C Arguments:
C fName string :: base name for file to read
C filePrec integer :: number of bits per word in file (32 or 64)
C arrType char(2) :: which array (fldR8/R4) to read, either "R8" or "R4"
C nSize integer :: number of elements of input array "fldR8/R4" to read
C fldR8 ( R8 ) :: array to read if arrType="R8", fldR8(nSize)
C fldR4 ( R4 ) :: array to read if arrType="R4", fldR4(nSize)
C singleCpuIO ( L ) :: only proc 0 do IO and send data to other procs
C iRec integer :: record number to read
C myThid integer :: my Thread Id number
C !USES:
IMPLICIT NONE
C-- Global variables --
#include "SIZE.h"
#include "EEPARAMS.h"
#include "PARAMS.h"
C !INPUT/OUTPUT PARAMETERS:
CHARACTER*(*) fName
INTEGER filePrec
CHARACTER*(2) arrType
INTEGER nSize
_R8 fldR8(*)
_R4 fldR4(*)
LOGICAL singleCpuIO
INTEGER iRec
INTEGER myThid
#ifdef ALLOW_AUTODIFF
C !FUNCTIONS:
INTEGER ILNBLNK
INTEGER MDS_RECLEN
EXTERNAL
EXTERNAL
C !LOCAL VARIABLES:
CHARACTER*(MAX_LEN_FNAM) dataFName, pfName
INTEGER iG, jG, jRec, dUnit, IL, pIL
LOGICAL exst
LOGICAL globalFile, fileIsOpen
INTEGER length_of_rec
CHARACTER*(MAX_LEN_MBUF) msgBuf
C simple implementation of singleCpuIO without any specific EXCH2
C feature (should work as long as reading and writing match)
INTEGER j
INTEGER vec_size
C Note: would be better to use explicit (allocate/delocate) dynamical
C allocation instead of this implicit form:
_R8 gl_buffer_r8(nSize*nPx*nPy)
_R4 gl_buffer_r4(nSize*nPx*nPy)
_R8 local_r8 (nSize)
_R4 local_r4 (nSize)
CEOP
vec_size = nSize*nPx*nPy
C-- Only do I/O if I am the master thread
_BEGIN_MASTER( myThid )
C- Record number must be >= 1
IF ( iRec.LT.1 ) THEN
WRITE(msgBuf,'(A,I10)')
& ' MDS_READ_TAPE: argument iRec =',iRec
CALL PRINT_ERROR( msgBuf, myThid )
WRITE(msgBuf,'(A)')
& ' MDS_READ_TAPE: invalid value for iRec'
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
ENDIF
C- Assume nothing
globalFile = .FALSE.
fileIsOpen = .FALSE.
IL = ILNBLNK( fName )
pIL = ILNBLNK( mdsioLocalDir )
C- Assign special directory
IF ( mdsioLocalDir .NE. ' ' ) THEN
WRITE(pfName,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL)
ELSE
pfName = fName
ENDIF
pIL = ILNBLNK( pfName )
C- Assign a free unit number as the I/O channel for this routine
CALL MDSFINDUNIT( dUnit, myThid )
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
IF ( singleCpuIO ) THEN
IF ( myProcId .EQ. 0 ) THEN
C-- Master thread of process 0, only, opens a global file
C- Check first for global file with with MDS name (ie. fName.data)
WRITE(dataFName,'(2A)') fName(1:IL),'.data'
INQUIRE( file=dataFName, exist=exst )
IF (exst) globalFile = .TRUE.
C- If global file is visible to process 0, then open it here.
IF ( globalFile ) THEN
IF ( debugLevel .GE. debLevB ) THEN
WRITE(msgBuf,'(A,A)')
& ' MDS_READ_TAPE: opening global file: ',dataFName(1:IL+5)
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
& SQUEEZE_RIGHT, myThid )
ENDIF
length_of_rec = MDS_RECLEN( filePrec, vec_size, myThid )
OPEN( dUnit, file=dataFName, status='old',
& access='direct', recl=length_of_rec )
ELSE
C Otherwise stop program.
WRITE(msgBuf,'(2A)')
& ' MDS_READ_TAPE: filename: ',dataFName(1:IL)
C-jmc: why double print (stdout + stderr) ?
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
& SQUEEZE_RIGHT, myThid )
CALL PRINT_ERROR( msgBuf, myThid )
WRITE(msgBuf,'(A)')
& ' MDS_READ_TAPE: File does not exist'
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
& SQUEEZE_RIGHT, myThid )
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
ENDIF
C- Read into global buffer:
IF ( filePrec.EQ.precFloat32 ) THEN
READ(dUnit,rec=iRec) gl_buffer_r4
#ifdef _BYTESWAPIO
CALL MDS_BYTESWAPR4( vec_size, gl_buffer_r4 )
#endif
ELSEIF ( filePrec.EQ.precFloat64 ) THEN
READ(dUnit,rec=iRec) gl_buffer_r8
#ifdef _BYTESWAPIO
CALL MDS_BYTESWAPR8( vec_size, gl_buffer_r8 )
#endif
ENDIF
C- Close data-file
CLOSE( dUnit )
C-- end if myProcId=0
ENDIF
IF ( filePrec.EQ.precFloat32 ) THEN
CALL SCATTER_VEC_R4( gl_buffer_r4, local_r4, nSize, myThid )
ELSEIF ( filePrec.EQ.precFloat64 ) THEN
CALL SCATTER_VEC_R8( gl_buffer_r8, local_r8, nSize, myThid )
ELSE
WRITE(msgBuf,'(A)')
& ' MDS_READ_TAPE: illegal value for filePrec'
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
ENDIF
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C if ( singleCpuIO ), else
ELSEIF ( .NOT. singleCpuIO ) THEN
C- Check first for global file with with MDS name (ie. fName.data)
WRITE(dataFName,'(2A)') fName(1:IL),'.data'
INQUIRE( file=dataFName, exist=exst )
IF (exst) THEN
IF ( debugLevel .GE. debLevB ) THEN
WRITE(msgBuf,'(A,A)')
& ' MDS_READ_TAPE: opening global file: ',dataFName(1:IL+5)
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
& SQUEEZE_RIGHT, myThid )
ENDIF
globalFile = .TRUE.
C- And open it here
length_of_rec = MDS_RECLEN( filePrec, nSize, myThid )
OPEN( dUnit, file=dataFName, status='old',
& access='direct', recl=length_of_rec )
fileIsOpen=.TRUE.
ENDIF
C- If we are reading from a tiled MDS file then we open each one here
IF ( .NOT.globalFile ) THEN
iG = 1 + (myXGlobalLo-1)/sNx
jG = 1 + (myYGlobalLo-1)/sNy
WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
& pfName(1:pIL),'.',iG,'.',jG,'.data'
INQUIRE( file=dataFName, exist=exst )
IF (exst) THEN
IF ( debugLevel .GE. debLevB ) THEN
WRITE(msgBuf,'(A,A)')
& ' MDS_READ_TAPE: opening file: ',dataFName(1:pIL+13)
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
& SQUEEZE_RIGHT, myThid )
ENDIF
length_of_rec = MDS_RECLEN( filePrec, nSize, myThid )
OPEN( dUnit, file=dataFName, status='old',
& access='direct', recl=length_of_rec )
fileIsOpen=.TRUE.
ELSE
fileIsOpen=.FALSE.
WRITE(msgBuf,'(4A)')
& ' MDS_READ_TAPE: missing file: ',fName(1:IL),
& ' , ',dataFName(1:pIL+13)
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
ENDIF
ENDIF
IF ( fileIsOpen ) THEN
IF ( globalFile ) THEN
C- read the same way it was written:
jRec = 1 + myProcId + (iRec-1)*nPx*nPy
ELSE
jRec = iRec
ENDIF
IF ( filePrec.EQ.precFloat32 ) THEN
READ(dUnit,rec=jRec) local_r4
#ifdef _BYTESWAPIO
CALL MDS_BYTESWAPR4( nSize, local_r4 )
#endif
ELSEIF ( filePrec.EQ.precFloat64 ) THEN
READ(dUnit,rec=jRec) local_r8
#ifdef _BYTESWAPIO
CALL MDS_BYTESWAPR8( nSize, local_r8 )
#endif
ELSE
WRITE(msgBuf,'(A)')
& ' MDS_READ_TAPE: illegal value for filePrec'
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
ENDIF
C-- If file was opened then close it
CLOSE( dUnit )
fileIsOpen = .FALSE.
ENDIF
C end-if ( .not. singleCpuIO )
ENDIF
_END_MASTER( myThid )
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C-- Copy local buffer into output array
IF ( arrType.EQ.'R4' ) THEN
IF ( filePrec.EQ.precFloat32 ) THEN
DO j=1,nSize
fldR4(j) = local_r4(j)
ENDDO
ELSE
DO j=1,nSize
fldR4(j) = local_r8(j)
ENDDO
ENDIF
ELSEIF ( arrType.EQ.'R8' ) THEN
IF ( filePrec.EQ.precFloat32 ) THEN
DO j=1,nSize
fldR8(j) = local_r4(j)
ENDDO
ELSE
DO j=1,nSize
fldR8(j) = local_r8(j)
ENDDO
ENDIF
ELSE
WRITE(msgBuf,'(A)')
& ' MDS_READ_TAPE: illegal value for arrType'
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R MDS_READ_TAPE'
ENDIF
#else /* ALLOW_AUTODIFF */
STOP 'ABNORMAL END: S/R MDS_READ_TAPE is empty'
#endif /* ALLOW_AUTODIFF */
RETURN
END