Back to home page

MITgcm
 
 

    

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

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
94ed53b781 Jean*0001 #include "MDSIO_OPTIONS.h"
                0002 
7d0a27ce7b Jean*0003 CBOP
                0004 C !ROUTINE: MDS_WRITEVEC_LOC
                0005 C !INTERFACE:
bcb25246f8 Jean*0006       SUBROUTINE MDS_WRITEVEC_LOC(
94ed53b781 Jean*0007      I   fName,
                0008      I   filePrec,
7d0a27ce7b Jean*0009      U   ioUnit,
bcb25246f8 Jean*0010      I   arrType,
608f4af3c8 Jean*0011      I   nSize,
                0012      I   fldRL, fldRS,
94ed53b781 Jean*0013      I   bi, bj,
                0014      I   irecord,
                0015      I   myIter,
                0016      I   myThid )
bcb25246f8 Jean*0017 
7d0a27ce7b Jean*0018 C !DESCRIPTION:
94ed53b781 Jean*0019 C Arguments:
                0020 C
7d0a27ce7b Jean*0021 C fName    string  :: base name for file to written
bcb25246f8 Jean*0022 C filePrec integer :: number of bits per word in file (32 or 64)
7d0a27ce7b Jean*0023 C ioUnit   integer :: fortran file IO unit
608f4af3c8 Jean*0024 C nSize    integer :: number of elements from input array "fldRL/RS" to be written
                0025 C arrType  char(2) :: which array (fldRL/RS) to write, either "RL" or "RS"
                0026 C fldRL    ( RL )  :: array to write if arrType="RL", fldRL(nSize)
                0027 C fldRS    ( RS )  :: array to write if arrType="RS", fldRS(nSize)
bcb25246f8 Jean*0028 C bi,bj    integer :: tile indices (if tiled array) or 0,0 if not a tiled array
7d0a27ce7b Jean*0029 C irecord  integer :: record number to WRITE =|irecord|
bcb25246f8 Jean*0030 C myIter   integer :: time step number
                0031 C myThid   integer :: my Thread Id number
94ed53b781 Jean*0032 C
7d0a27ce7b Jean*0033 C MDS_WRITEVEC_LOC according to ioUnit:
                0034 C  ioUnit = 0 : open file, write and close the file (return ioUnit=0).
                0035 C  ioUnit =-1 : open file, write and leave it open (return IO unit in ioUnit)
                0036 C  ioUnit > 0 : assume file "ioUnit" is open, and write to it.
                0037 C MDS_WRITEVEC_LOC writes either to a file of the form "fName.data" and
608f4af3c8 Jean*0038 C "fName.meta" if bi=bj=0. Otherwise it writes to MDS tiled files of the
94ed53b781 Jean*0039 C form "fName.xxx.yyy.data" and "fName.xxx.yyy.meta".
7d0a27ce7b Jean*0040 C If irecord>0, a meta-file is created (skipped if irecord<0).
608f4af3c8 Jean*0041 C The precision of the file is described by filePrec, set either
94ed53b781 Jean*0042 C to floatPrec32 or floatPrec64.
7d0a27ce7b Jean*0043 C |irecord|=iRec is the record number to be written and must be >=1.
94ed53b781 Jean*0044 
7d0a27ce7b Jean*0045 C !USES:
94ed53b781 Jean*0046       IMPLICIT NONE
7d0a27ce7b Jean*0047 
94ed53b781 Jean*0048 C Global variables / common blocks
                0049 #include "SIZE.h"
                0050 #include "EEPARAMS.h"
                0051 #include "PARAMS.h"
63bf71414d Jean*0052 #ifdef ALLOW_FIZHI
                0053 # include "fizhi_SIZE.h"
                0054 #endif /* ALLOW_FIZHI */
1a7eba5cb1 Jean*0055 #include "MDSIO_BUFF_3D.h"
94ed53b781 Jean*0056 
7d0a27ce7b Jean*0057 C !INPUT/OUTPUT PARAMETERS:
94ed53b781 Jean*0058       CHARACTER*(*) fName
7d0a27ce7b Jean*0059       INTEGER ioUnit
94ed53b781 Jean*0060       INTEGER filePrec
bcb25246f8 Jean*0061       CHARACTER*(2) arrType
608f4af3c8 Jean*0062       INTEGER nSize
                0063       _RL     fldRL(*)
                0064       _RS     fldRS(*)
94ed53b781 Jean*0065       INTEGER bi,bj
                0066       INTEGER irecord
                0067       INTEGER myIter
                0068       INTEGER myThid
7d0a27ce7b Jean*0069 
                0070 C !FUNCTIONS:
94ed53b781 Jean*0071       INTEGER ILNBLNK
                0072       INTEGER MDS_RECLEN
bcb25246f8 Jean*0073       EXTERNAL ILNBLNK
                0074       EXTERNAL MDS_RECLEN
7d0a27ce7b Jean*0075 
                0076 C !LOCAL VARIABLES:
94ed53b781 Jean*0077       CHARACTER*(MAX_LEN_FNAM) dataFName, metaFName, pfName
                0078       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0079       LOGICAL fileIsOpen
608f4af3c8 Jean*0080       INTEGER iG,jG,iRec,dUnit,IL,pIL
bcb25246f8 Jean*0081       INTEGER dimList(3,3), nDims, map2gl(2)
94ed53b781 Jean*0082       INTEGER length_of_rec
1a7eba5cb1 Jean*0083       INTEGER buffSize
fbc6fb65d0 Jean*0084       _RL dummyRL(1)
                0085       CHARACTER*8 blank8c
7d0a27ce7b Jean*0086 CEOP
94ed53b781 Jean*0087 
fbc6fb65d0 Jean*0088       DATA dummyRL(1) / 0. _d 0 /
                0089       DATA blank8c / '        ' /
                0090       DATA map2gl  / 0, 1 /
bcb25246f8 Jean*0091 
7d0a27ce7b Jean*0092 C We write a non-tiled array (bi=bj=0) only 1 time (if ProcId=0):
                0093       IF ( myProcId.EQ.0 .OR. bi.NE.0 .OR. bj.NE.0 ) THEN
                0094 
94ed53b781 Jean*0095 C Only DO I/O IF I am the master thread
7d0a27ce7b Jean*0096         _BEGIN_MASTER( myThid )
                0097 
                0098 C Assume nothing
                0099         fileIsOpen = .FALSE.
                0100         IL  = ILNBLNK( fName )
                0101         iRec = ABS(irecord)
94ed53b781 Jean*0102 
                0103 C Record number must be >= 1
7d0a27ce7b Jean*0104         IF ( iRec.LT.1 ) THEN
bcb25246f8 Jean*0105           WRITE(msgBuf,'(A,I9)')
                0106      &      ' MDS_WRITEVEC_LOC: argument irecord = ',irecord
94ed53b781 Jean*0107           CALL PRINT_ERROR( msgBuf, myThid )
                0108           WRITE(msgBuf,'(A)')
bcb25246f8 Jean*0109      &     ' MDS_WRITEVEC_LOC: invalid value for irecord'
94ed53b781 Jean*0110           CALL PRINT_ERROR( msgBuf, myThid )
bcb25246f8 Jean*0111           STOP 'ABNORMAL END: S/R MDS_WRITEVEC_LOC'
94ed53b781 Jean*0112         ENDIF
                0113 
bcb25246f8 Jean*0114 C Check buffer size
1a7eba5cb1 Jean*0115         buffSize = sNx*sNy*size3dBuf*nSx*nSy
                0116         IF ( nSize.GT.buffSize ) THEN
bcb25246f8 Jean*0117           WRITE(msgBuf,'(3A)')
                0118      &     ' MDS_WRITEVEC_LOC: writing to file "', fName(1:IL), '":'
                0119           CALL PRINT_ERROR( msgBuf, myThid )
                0120           WRITE(msgBuf,'(A,I9)')
608f4af3c8 Jean*0121      &      ' MDS_WRITEVEC_LOC: dim of array to write=', nSize
bcb25246f8 Jean*0122           CALL PRINT_ERROR( msgBuf, myThid )
                0123           WRITE(msgBuf,'(A,I9)')
1a7eba5cb1 Jean*0124      &      ' MDS_WRITEVEC_LOC: exceeds buffer size=', buffSize
                0125           CALL PRINT_ERROR( msgBuf, myThid )
                0126           WRITE(msgBuf,'(A)')
                0127      &    ' increase "size3dBuf" in "MDSIO_BUFF_3D.h" and recompile'
bcb25246f8 Jean*0128           CALL PRINT_ERROR( msgBuf, myThid )
                0129           STOP 'ABNORMAL END: S/R MDS_WRITEVEC_LOC'
                0130         ENDIF
94ed53b781 Jean*0131 
                0132 C Assign special directory
                0133         IF ( mdsioLocalDir .NE. ' ' ) THEN
                0134          pIL = ILNBLNK( mdsioLocalDir )
                0135          WRITE(pFname,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL)
                0136          pIL = IL + pIL
                0137         ELSE
                0138          WRITE(pFname,'(A)') fName(1:IL)
                0139          pIL = IL
                0140         ENDIF
                0141 
7d0a27ce7b Jean*0142         IF ( ioUnit.GT.0 ) THEN
                0143 C- Assume file Unit is already open with correct Rec-Length & Precision
                0144           fileIsOpen = .TRUE.
                0145           dUnit = ioUnit
94ed53b781 Jean*0146         ELSE
7d0a27ce7b Jean*0147 C- Need to open file IO unit with File-name, Rec-Length & Precision
                0148 
                0149 C     Assign a free unit number as the I/O channel for this routine
                0150           CALL MDSFINDUNIT( dUnit, myThid )
                0151 
                0152 C--   Set the file Name:
                0153           IF ( bi.EQ.0 .AND. bj.EQ.0 ) THEN
                0154 C-    we are writing a non-tiled array (bi=bj=0):
                0155             WRITE(dataFname,'(2A)') fName(1:IL),'.data'
                0156           ELSE
                0157 C-    we are writing a tiled array (bi>0,bj>0):
                0158             iG=bi+(myXGlobalLo-1)/sNx
                0159             jG=bj+(myYGlobalLo-1)/sNy
                0160             WRITE(dataFname,'(2A,I3.3,A,I3.3,A)')
94ed53b781 Jean*0161      &             pfName(1:pIL),'.',iG,'.',jG,'.data'
7d0a27ce7b Jean*0162           ENDIF
94ed53b781 Jean*0163 
7d0a27ce7b Jean*0164 C--   Open the file:
608f4af3c8 Jean*0165           length_of_rec=MDS_RECLEN( filePrec, nSize, myThid )
7d0a27ce7b Jean*0166           IF (iRec .EQ. 1) THEN
                0167             OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
                0168      &            access='direct', recl=length_of_rec )
                0169             fileIsOpen=.TRUE.
                0170           ELSE
                0171             OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
                0172      &            access='direct', recl=length_of_rec )
                0173             fileIsOpen=.TRUE.
                0174           ENDIF
ae605e558b Jean*0175           IF ( debugLevel.GE.debLevC ) THEN
7d0a27ce7b Jean*0176             WRITE(msgBuf,'(2A)')
bcb25246f8 Jean*0177      &      ' MDS_WRITEVEC_LOC: open file: ',dataFname(1:pIL+13)
7d0a27ce7b Jean*0178             CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0179      &                          SQUEEZE_RIGHT , 1)
                0180           ENDIF
                0181 C- End if block: File Unit is already open / Need to open it
94ed53b781 Jean*0182         ENDIF
                0183 
                0184         IF (fileIsOpen) THEN
bcb25246f8 Jean*0185           IF ( arrType.EQ.'RS' ) THEN
1a7eba5cb1 Jean*0186             CALL MDS_WR_REC_RS( fldRS, shared3dBuf_r4, shared3dBuf_r8,
608f4af3c8 Jean*0187      I                          filePrec, dUnit, iRec, nSize, myThid )
bcb25246f8 Jean*0188           ELSEIF ( arrType.EQ.'RL' ) THEN
1a7eba5cb1 Jean*0189             CALL MDS_WR_REC_RL( fldRL, shared3dBuf_r4, shared3dBuf_r8,
608f4af3c8 Jean*0190      I                          filePrec, dUnit, iRec, nSize, myThid )
94ed53b781 Jean*0191           ELSE
                0192             WRITE(msgBuf,'(A)')
bcb25246f8 Jean*0193      &          ' MDS_WRITEVEC_LOC: illegal value for arrType'
94ed53b781 Jean*0194             CALL PRINT_ERROR( msgBuf, myThid )
bcb25246f8 Jean*0195             STOP 'ABNORMAL END: S/R MDS_WRITEVEC_LOC'
94ed53b781 Jean*0196           ENDIF
                0197         ELSE
                0198           WRITE(msgBuf,'(A)')
bcb25246f8 Jean*0199      &      ' MDS_WRITEVEC_LOC: should never reach this point'
94ed53b781 Jean*0200           CALL PRINT_ERROR( msgBuf, myThid )
bcb25246f8 Jean*0201           STOP 'ABNORMAL END: S/R MDS_WRITEVEC_LOC'
94ed53b781 Jean*0202         ENDIF
                0203 
                0204 C If we were writing to a tiled MDS file then we close it here
7d0a27ce7b Jean*0205         IF ( fileIsOpen .AND. ioUnit.EQ.0 ) THEN
94ed53b781 Jean*0206           CLOSE( dUnit )
                0207           fileIsOpen = .FALSE.
                0208         ENDIF
7d0a27ce7b Jean*0209         IF ( ioUnit.EQ.-1 ) ioUnit = dUnit
94ed53b781 Jean*0210 
7d0a27ce7b Jean*0211         IF ( irecord.GT.0 ) THEN
94ed53b781 Jean*0212 C Create meta-file for each tile IF we are tiling
7d0a27ce7b Jean*0213           IF ( bi.EQ.0 .AND. bj.EQ.0 ) THEN
                0214 C--   we are writing a non-tiled array (bi=bj=0):
                0215             WRITE(metaFname,'(2A)') fName(1:IL),'.meta'
                0216             dimList(1,1)=1
                0217             dimList(2,1)=1
                0218             dimList(3,1)=1
                0219             dimList(1,2)=1
                0220             dimList(2,2)=1
                0221             dimList(3,2)=1
                0222           ELSE
                0223 C--   we are writing a tiled array (bi>0,bj>0):
                0224             iG=bi+(myXGlobalLo-1)/sNx
                0225             jG=bj+(myYGlobalLo-1)/sNy
                0226             WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')
94ed53b781 Jean*0227      &             pfName(1:pIL),'.',iG,'.',jG,'.meta'
7d0a27ce7b Jean*0228             dimList(1,1)=nSx*nPx
                0229             dimList(2,1)=iG
                0230             dimList(3,1)=iG
                0231             dimList(1,2)=nSy*nPy
                0232             dimList(2,2)=jG
                0233             dimList(3,2)=jG
                0234           ENDIF
608f4af3c8 Jean*0235           dimList(1,3)=nSize
7d0a27ce7b Jean*0236           dimList(2,3)=1
608f4af3c8 Jean*0237           dimList(3,3)=nSize
7d0a27ce7b Jean*0238           nDims=3
608f4af3c8 Jean*0239           IF ( nSize.EQ.1 ) nDims=2
7d0a27ce7b Jean*0240           CALL MDS_WRITE_META(
bcb25246f8 Jean*0241      I              metaFName, dataFName, the_run_name, ' ',
fbc6fb65d0 Jean*0242      I              filePrec, nDims, dimList, map2gl, 0, blank8c,
a50692f9cd Jean*0243      I              0, dummyRL, oneRL, irecord, myIter, myThid )
7d0a27ce7b Jean*0244         ENDIF
94ed53b781 Jean*0245 
7d0a27ce7b Jean*0246         _END_MASTER( myThid )
94ed53b781 Jean*0247       ENDIF
                0248 
                0249       RETURN
                0250       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!