C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_write_tape.F,v 1.1 2013/10/17 00:30:46 jmc Exp $
C $Name: $
#include "MDSIO_OPTIONS.h"
CBOP
C !ROUTINE: MDS_WRITE_TAPE
C !INTERFACE:
SUBROUTINE MDS_WRITE_TAPE(
I fName,
I filePrec,
I globalfile,
I arrType,
I nSize,
I fldR8, fldR4,
I singleCpuIO,
I iRec,
I myIter,
I myThid )
C !DESCRIPTION:
C MDS_WRITE_TAPE: write an array (treated as vector) to a tape-file
C (renamed from MDSWRITEVECTOR with 2 explicit input array types)
C
C Arguments:
C fName string :: base name for file to write
C filePrec integer :: number of bits per word in file (32 or 64)
C globalFile logical :: selects between writing a global or tiled file
C arrType char(2) :: which array (fldR8/R4) to write, either "R8" or "R4"
C nSize integer :: number of elements of input array "fldR8/R4" to write
C fldR8 ( R8 ) :: array to write if arrType="R8", fldR8(nSize)
C fldR4 ( R4 ) :: array to write if arrType="R4", fldR4(nSize)
C bi,bj integer :: tile indices (if tiled array)
C singleCpuIO ( L ) :: only proc 0 do IO and collect data from other procs
C iRec integer :: record number to write
C myIter integer :: time step number
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
LOGICAL globalfile
CHARACTER*(2) arrType
INTEGER nSize
_R8 fldR8(*)
_R4 fldR4(*)
LOGICAL singleCpuIO
INTEGER iRec
INTEGER myIter
INTEGER myThid
#ifdef ALLOW_AUTODIFF
C !FUNCTIONS:
INTEGER ILNBLNK
INTEGER MDS_RECLEN
EXTERNAL
EXTERNAL
C !LOCAL VARIABLES:
CHARACTER*(MAX_LEN_FNAM) dataFName, metaFName, pfName
INTEGER iG, jG, jRec, dUnit, IL, pIL
INTEGER dimList(3,1), nDims, map2gl(2)
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)
_RL dummyRL(1)
CHARACTER*8 blank8c
CEOP
DATA dummyRL(1) / 0. _d 0 /
DATA blank8c / ' ' /
DATA map2gl / 0, 1 /
vec_size = nSize*nPx*nPy
C-- Copy input array to local buffer
IF ( arrType.EQ.'R4' ) THEN
IF ( filePrec.EQ.precFloat32 ) THEN
DO j=1,nSize
local_r4(j) = fldR4(j)
ENDDO
ELSE
DO j=1,nSize
local_r8(j) = fldR4(j)
ENDDO
ENDIF
ELSEIF ( arrType.EQ.'R8' ) THEN
IF ( filePrec.EQ.precFloat32 ) THEN
DO j=1,nSize
local_r4(j) = fldR8(j)
ENDDO
ELSE
DO j=1,nSize
local_r8(j) = fldR8(j)
ENDDO
ENDIF
ELSE
WRITE(msgBuf,'(A)')
& ' MDS_WRITE_TAPE: illegal value for arrType'
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R MDS_WRITE_TAPE'
ENDIF
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
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_WRITE_TAPE: argument iRec =',iRec
CALL PRINT_ERROR( msgBuf, myThid )
WRITE(msgBuf,'(A)')
& ' MDS_WRITE_TAPE: invalid value for iRec'
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R MDS_WRITE_TAPE'
ENDIF
C- Assume nothing
IL = ILNBLNK( fName )
pIL = ILNBLNK( mdsioLocalDir )
C- Assign special directory
IF ( pIL.EQ.0 ) THEN
pfName = fName
ELSE
WRITE(pfName,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL)
ENDIF
pIL = ILNBLNK( pfName )
IF ( debugLevel.GE.debLevC .AND.
& ( .NOT.singleCpuIO .OR. myProcId.EQ.0 ) ) THEN
WRITE(msgBuf,'(A,I8,2A)')
& ' MDS_WRITE_TAPE: iRec=', iRec, ', file=', pfName(1:pIL)
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
& SQUEEZE_RIGHT, myThid )
ENDIF
C- Assign a free unit number as the I/O channel for this routine
CALL MDSFINDUNIT( dUnit, myThid )
C If option globalFile is desired but does not work or if
C globalFile is too slow, then try using single-CPU I/O.
IF ( singleCpuIO ) THEN
C- Gather array from all procs
IF ( filePrec.EQ.precFloat32 ) THEN
CALL GATHER_VEC_R4( gl_buffer_r4, local_r4, nSize, myThid )
ELSEIF ( filePrec.EQ.precFloat64 ) THEN
CALL GATHER_VEC_R8( gl_buffer_r8, local_r8, nSize, myThid )
ELSE
WRITE(msgBuf,'(A)')
& ' MDS_WRITE_TAPE: illegal value for filePrec'
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R MDS_WRITE_TAPE'
ENDIF
IF ( myProcId .EQ. 0 ) THEN
C-- Master thread of process 0, only, opens a global file
WRITE(dataFName,'(2a)') fName(1:IL),'.data'
length_of_rec = MDS_RECLEN( filePrec, vec_size, myThid )
IF (iRec .EQ. 1) THEN
OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
& access='direct', recl=length_of_rec )
ELSE
OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
& access='direct', recl=length_of_rec )
ENDIF
C- Write global buffer to file:
IF ( filePrec.EQ.precFloat32 ) THEN
#ifdef _BYTESWAPIO
CALL MDS_BYTESWAPR4( vec_size, gl_buffer_r4 )
#endif
WRITE(dUnit,rec=iRec) gl_buffer_r4
ELSEIF ( filePrec.EQ.precFloat64 ) THEN
#ifdef _BYTESWAPIO
CALL MDS_BYTESWAPR8( vec_size, gl_buffer_r8 )
#endif
WRITE(dUnit,rec=iRec) gl_buffer_r8
ENDIF
C- Close data-file and create meta-file
CLOSE( dUnit )
WRITE(metaFName,'(2a)') fName(1:IL),'.meta'
dimList(1,1) = vec_size
dimList(2,1) = 1
dimList(3,1) = vec_size
nDims = 1
CALL MDS_WRITE_META(
I metaFName, dataFName, the_run_name, ' ',
I filePrec, nDims, dimList, map2gl, 0, blank8c,
I 0, dummyRL, oneRL, iRec, myIter, myThid )
C- end if myProcId=0
ENDIF
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C if ( singleCpuIO ), else
ELSEIF ( .NOT. singleCpuIO ) THEN
IF ( globalFile ) THEN
C- If we are writing to a global file then we open it here
WRITE(dataFName,'(2A)') fName(1:IL),'.data'
length_of_rec = MDS_RECLEN( filePrec, nSize, myThid )
IF ( iRec.EQ.1 ) THEN
OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
& access='direct', recl=length_of_rec )
ELSE
OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
& access='direct', recl=length_of_rec )
ENDIF
ELSE
C- If we are writing to a tiled MDS file then we open each one here
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'
length_of_rec = MDS_RECLEN( filePrec, nSize, myThid )
IF (iRec .EQ. 1) THEN
OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
& access='direct', recl=length_of_rec )
ELSE
OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
& access='direct', recl=length_of_rec )
ENDIF
ENDIF
C- Write local buffer to file:
IF (globalFile) THEN
C-- Original: nPy=2, nSx=2 -> produces too large file (1.5 x normal size)
c iG = myXGlobalLo-1+(bi-1)*sNx
c jG = myYGlobalLo-1+(bj-1)*sNy
c jRec = 1 + int(iG/sNx) + (jG/sNy)*nSx*nPx +
c & (iRec-1)*nSx*nPx*nSy*nPy
C-- Alternative: same layout as in scatter/gather_vector (for singleCpuIO)
C problem: nPx=2, nSx=2, writing a global (i.e., with bi,bj dim);
C- 2nd proc get iG=3 -> badly placed data over nPx*nPy*nSize range
C that will be overwritten by next record
c iG = 1 + (myXGlobalLo-1)/sNx
c jG = 1 + (myYGlobalLo-1)/sNy
c jRec = iG + (jG-1)*nPx + (iRec-1)*nPx*nPy
C-- Simpler: should work (but hard to interpret the sequence of data in file)
jRec = 1 + myProcId + (iRec-1)*nPx*nPy
ELSE
jRec = iRec
ENDIF
IF ( filePrec.EQ.precFloat32 ) THEN
#ifdef _BYTESWAPIO
CALL MDS_BYTESWAPR4( nSize, local_r4 )
#endif
WRITE(dUnit,rec=jRec) local_r4
ELSEIF ( filePrec.EQ.precFloat64 ) THEN
#ifdef _BYTESWAPIO
CALL MDS_BYTESWAPR8( nSize, local_r8 )
#endif
WRITE(dUnit,rec=jRec) local_r8
ELSE
WRITE(msgBuf,'(A)')
& ' MDS_WRITE_TAPE: illegal value for filePrec'
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R MDS_WRITE_TAPE'
ENDIF
C- Close data-file and create meta-file
CLOSE( dUnit )
IF ( globalFile ) THEN
C meta-file for global file
WRITE(metaFName,'(2A)') fName(1:IL),'.meta'
dimList(1,1) = vec_size
dimList(2,1) = 1
dimList(3,1) = vec_size
nDims = 1
ELSE
C meta-file for tiled file
iG = 1 + (myXGlobalLo-1)/sNx
jG = 1 + (myYGlobalLo-1)/sNy
WRITE(metaFName,'(2A,I3.3,A,I3.3,A)')
& pfName(1:pIL),'.',iG,'.',jG,'.meta'
dimList(1,1) = nPx*nPy*nSize
dimList(2,1) = 1 + myProcId*nSize
dimList(3,1) = (1+myProcId)*nSize
nDims = 1
ENDIF
C- write meta-file
CALL MDS_WRITE_META(
I metaFName, dataFName, the_run_name, ' ',
I filePrec, nDims, dimList, map2gl, 0, blank8c,
I 0, dummyRL, oneRL, iRec, myIter, myThid )
c I metaFName, dataFName, the_run_name, titleLine,
c I filePrec, nDims, dimList, map2gl, nFlds, fldList,
c I nTimRec, timList, misVal, iRec, myIter, myThid )
C end-if ( .not. singleCpuIO )
ENDIF
_END_MASTER( myThid )
#else /* ALLOW_AUTODIFF */
STOP 'ABNORMAL END: S/R MDS_WRITE_TAPE is empty'
#endif /* ALLOW_AUTODIFF */
RETURN
END