Back to home page

MITgcm
 
 

    

File indexing completed on 2018-03-02 18:43:07 UTC

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
8be8fc53ab Jean*0001 #include "RW_OPTIONS.h"
                0002 
                0003 C--  File read_mflds.F: Routines to handle reading Multi-Fields File (+ meta file)
                0004 C--   Contents
                0005 C--   o READ_MFLDS_INIT
                0006 C--   o READ_MFLDS_SET
                0007 C--   o READ_MFLDS_3D_RL
79bad69582 Jean*0008 C--   o READ_MFLDS_LEV_RL
5bc5177bde Jean*0009 C--   o READ_MFLDS_LEV_RS
8be8fc53ab Jean*0010 C--   o READ_MFLDS_CHECK
1596008957 Jean*0011 C--   o READ_MFLDS_RENAME
8be8fc53ab Jean*0012 
                0013 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0014 CBOP
                0015 C     !ROUTINE: READ_MFLDS_INIT
                0016 C     !INTERFACE:
                0017       SUBROUTINE READ_MFLDS_INIT(
                0018      I                            myThid )
                0019 
                0020 C     !DESCRIPTION:
                0021 C     Initialise Multi-Fields read variables in common block
                0022 
                0023 C     !USES:
                0024       IMPLICIT NONE
                0025 c#include "SIZE.h"
                0026 #include "EEPARAMS.h"
                0027 #include "RW_MFLDS.h"
                0028 
                0029 C     !INPUT/OUTPUT PARAMETERS:
                0030 C     myThid   :: my Thread Id. number
                0031       INTEGER myThid
                0032 CEOP
                0033 
                0034 C     !LOCAL VARIABLES:
                0035 C     i        :: loop counter
                0036       INTEGER i
                0037 C-    for debug print:
                0038 c     CHARACTER*(MAX_LEN_MBUF) msgBuf
                0039 C-----
                0040 
                0041 C-    Initialise variables in common block:
                0042       thirdDim = 0
                0043       nFl3D    = 0
                0044       nFlds    = 0
                0045       nMissFld = 0
                0046       mFldsFile = ' '
                0047       DO i=1,sizFldList
                0048         fldList(i) = ' '
                0049         fldMiss(i) = ' '
                0050       ENDDO
                0051 
                0052       RETURN
                0053       END
                0054 
                0055 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0056 CBOP
                0057 C     !ROUTINE: READ_MFLDS_SET
                0058 C     !INTERFACE:
                0059       SUBROUTINE READ_MFLDS_SET(
                0060      I                      fName,
                0061      O                      nbFields, filePrec,
                0062      I                      fileDim3, myIter, myThid )
                0063 
                0064 C     !DESCRIPTION:
                0065 C     This is the controlling routine for preparing Multi-Fields read
                0066 C     by reading the corresponding meta file.
                0067 C     the meta-file content is stored in common block (header: RW_MFLDS.h)
                0068 C     to be reachable by all threads
                0069 
59b782c2b9 Jean*0070 C Note: 1) Output arguments should not be shared variables (= not in common block)
                0071 C       2) Only master-thread returns a valid filePrec (others just return 0)
                0072 
8be8fc53ab Jean*0073 C     !USES:
                0074       IMPLICIT NONE
                0075 #include "SIZE.h"
                0076 #include "EEPARAMS.h"
                0077 #include "PARAMS.h"
                0078 #include "RW_MFLDS.h"
                0079 
                0080 C     !INPUT/OUTPUT PARAMETERS:
                0081 C     fName    :: current MFLDS file name (prefix) to read
                0082 C     nbFields :: Number of fields in current MFLDS file
                0083 C     filePrec :: data-precision in current MFLDS file
                0084 C     fileDim3 :: 3rd dimension of fields in current MFLDS file
                0085 C     myIter   :: Iteration number
                0086 C     myThid   :: my Thread Id. number
                0087       CHARACTER*(MAX_LEN_FNAM) fName
                0088       INTEGER nbFields
                0089       INTEGER filePrec
                0090       INTEGER fileDim3
                0091       INTEGER myIter
                0092       INTEGER myThid
                0093 CEOP
                0094 
                0095 C !FUNCTIONS
                0096       INTEGER  ILNBLNK
                0097       EXTERNAL ILNBLNK
                0098 
                0099 C     !LOCAL VARIABLES:
                0100 C-    do change dir. (using mdsioLocalDir):
                0101       LOGICAL  useCurrentDir
                0102 C-    output of MDS_READ_META :
                0103       INTEGER  nSizD, nSizT
                0104       PARAMETER( nSizD = 5 , nSizT = 20 )
                0105       CHARACTER*(MAX_LEN_PREC/2) simulName
                0106       CHARACTER*(MAX_LEN_MBUF/2) titleLine
                0107       INTEGER nDims, nTimRec
                0108       INTEGER dimList(3,nSizD)
                0109       _RL     timList(nSizT)
115890d202 Jean*0110       _RL     misVal
8be8fc53ab Jean*0111       INTEGER nRecords, fileIter
                0112 C-    for debug print:
                0113       INTEGER i, j, ioUnit
                0114       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0115 C-----
                0116 
59b782c2b9 Jean*0117 C-    Initialise output arguments:
                0118       nbFields = 0
                0119       filePrec = 0
                0120 
8be8fc53ab Jean*0121 #ifdef RW_SAFE_MFLDS
                0122       i = ILNBLNK(mFldsFile)
                0123       IF ( i.NE.0 ) THEN
                0124         i = MIN(i, MAX_LEN_MBUF-48-34 )
                0125         WRITE(msgBuf,'(4A)') 'READ_MFLDS_SET: ',
                0126      &    'MFLDS file-name already set to: ',mFldsFile(1:i)
                0127         CALL PRINT_ERROR( msgBuf, myThid )
b445337786 Jean*0128         CALL ALL_PROC_DIE( myThid )
8be8fc53ab Jean*0129         STOP 'ABNORMAL END: S/R READ_MFLDS_SET (fileName)'
                0130       ENDIF
                0131       _BARRIER
                0132 #endif /* RW_SAFE_MFLDS */
                0133       _BEGIN_MASTER( myThid )
                0134 
                0135 C-    Initialise variables in common block:
                0136       thirdDim = fileDim3
                0137       nFl3D    = 0
                0138       nFlds    = 0
                0139       nMissFld = 0
                0140       mFldsFile = fName
                0141       DO i=1,sizFldList
                0142         fldList(i) = ' '
                0143         fldMiss(i) = ' '
                0144       ENDDO
                0145 
                0146 #ifdef ALLOW_MDSIO
                0147        useCurrentDir = .FALSE.
                0148        nDims = nSizD
                0149        nFlds = sizFldList
                0150        nTimRec = nSizT
                0151        CALL MDS_READ_META(
                0152      I               fName,
                0153      O               simulName,
                0154      O               titleLine,
                0155      O               filePrec,
                0156      U               nDims,   nFlds,   nTimRec,
                0157      O               dimList, fldList, timList,
115890d202 Jean*0158      O               misVal, nRecords, fileIter,
8be8fc53ab Jean*0159      I               useCurrentDir, myThid )
                0160 #endif /* ALLOW_MDSIO */
                0161 
                0162 C-    evaluate Nb of 3.D fields (used if mix 3-D & 2-D fields in file):
                0163       nFl3D = 0
                0164       IF ( nFlds.GE.1 ) THEN
                0165         IF ( nDims.EQ.2 .AND. thirdDim.GT.1
                0166      &                   .AND. nFlds.LT.nRecords ) THEN
                0167           IF ( MOD( nRecords-nFlds , thirdDim-1 ) .EQ. 0 )
                0168      &       nFl3D = (nRecords-nFlds)/(thirdDim-1)
                0169         ENDIF
                0170         IF ( nFlds.NE.nRecords .AND. nFl3D.EQ.0 ) THEN
                0171 C-    here we have a problem
                0172           WRITE(msgBuf,'(A,I5,A,I4,A)')
                0173      &     'READ_MFLDS_SET: Pb with Nb of records=', nRecords,
                0174      &     ' (3rd-Dim=', thirdDim,')'
                0175           CALL PRINT_ERROR( msgBuf, myThid )
                0176           WRITE(msgBuf,'(A,I5,A,I4,A)')
                0177      &     ' does not match Nb of flds=', nFlds
                0178           CALL PRINT_ERROR( msgBuf, myThid )
b445337786 Jean*0179           CALL ALL_PROC_DIE( 0 )
8be8fc53ab Jean*0180           STOP 'ABNORMAL END: S/R READ_MFLDS_SET (Nb-records Pb)'
                0181         ENDIF
                0182 c       IF ( nFl3D.EQ.0 ) nFl3D = nFlds
                0183       ENDIF
                0184 
                0185 C-    write to Standard Output
                0186       IF ( debugLevel.GE.debLevA ) THEN
                0187         ioUnit = standardMessageUnit
                0188         i = ILNBLNK(simulName)
                0189         IF ( i.GE.1 ) THEN
                0190          WRITE(msgBuf,'(3A)') ' simulName=>', simulName(1:i), '<'
                0191          CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0192         ENDIF
                0193         i = ILNBLNK(titleLine)
                0194         IF ( i.GE.1 ) THEN
                0195          WRITE(msgBuf,'(3A)') ' titleLine=>', titleLine(1:i), '<'
                0196          CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0197         ENDIF
                0198         WRITE(msgBuf,'(2(A,I4),A,I10)')
                0199      &    ' nRecords =', nRecords, ' ; filePrec =', filePrec,
                0200      &    ' ; fileIter =', fileIter
                0201         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0202         WRITE(msgBuf,'(A,I4,A)') '    nDims =', nDims, ' , dims:'
                0203         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0204         DO j=1,nDims
                0205          WRITE(msgBuf,'(I4,A,3I4)') j,':',(dimList(i,j),i=1,3)
                0206          CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0207         ENDDO
                0208         WRITE(msgBuf,'(3(A,I4))')
                0209      &    '    nFlds =', nFlds, ' , nFl3D =', nFl3D, ' , fields:'
                0210         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0211         DO j=1,nFlds,20
                0212          WRITE(msgBuf,'(20(A2,A8,A))')
                0213      &     (' >', fldList(i), '<', i=j,MIN(j+19,nFlds) )
                0214          CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0215         ENDDO
5bc5177bde Jean*0216         WRITE(msgBuf,'(A,1PE22.14,A,I4,A)') 'missingVal=', misVal,
115890d202 Jean*0217      &                           ' ; nTimRec =',nTimRec,' , timeList:'
8be8fc53ab Jean*0218         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0219         IF ( nTimRec.GE.1 ) THEN
                0220          WRITE(msgBuf,'(1P20E20.12)') (timList(i),i=1,nTimRec)
                0221          CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0222         ENDIF
                0223       ENDIF
                0224 
                0225       _END_MASTER( myThid )
                0226       _BARRIER
                0227 
59b782c2b9 Jean*0228 C-    set output arguments:
                0229       nbFields = nFlds
                0230 
8be8fc53ab Jean*0231       RETURN
                0232       END
                0233 
                0234 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0235 CBOP
                0236 C     !ROUTINE: READ_MFLDS_3D_RL
                0237 C     !INTERFACE:
                0238       SUBROUTINE READ_MFLDS_3D_RL(
                0239      I                fldName,
                0240      O                field,
                0241      U                nj,
                0242      I                fPrec, nNz, myIter, myThid )
                0243 
                0244 C     !DESCRIPTION:
                0245 C     Read, from a Multi-Fields binary file, field "fldName" into array "field"
                0246 C     record Nb "nj" is search through the field-list (from meta-file) which
                0247 C     has been set before (calling READ_MFLDS_SET).
                0248 C     In case nFlds is <=0 , by-pass the search and directly read record number "nj"
                0249 
                0250 C     !USES:
                0251       IMPLICIT NONE
                0252 #include "SIZE.h"
                0253 #include "EEPARAMS.h"
                0254 #include "PARAMS.h"
                0255 #include "RW_MFLDS.h"
                0256 
                0257 C     !INPUT/OUTPUT PARAMETERS:
                0258 C     fldName :: Name of the field to read
                0259 C     field   :: Output array to read in
                0260 C     nj (in) :: number of the record (in file) just before the one to read
                0261 C     nj (out):: number of the record (from current file) which was read in
                0262 C     fPrec   :: File precision (number of bits per word, = 32 or 64)
                0263 C     nNz     :: Number of levels to read in
                0264 C     myIter  :: Iteration number
                0265 C     myThid  :: My Thread Id number
                0266       CHARACTER*(8) fldName
                0267       _RL     field(*)
                0268       INTEGER nj
                0269       INTEGER fPrec
                0270       INTEGER nNz
                0271       INTEGER myIter
                0272       INTEGER myThid
                0273 CEOP
                0274 
                0275 C     !FUNCTIONS
                0276       INTEGER  ILNBLNK
                0277       EXTERNAL ILNBLNK
                0278 
                0279 C     !LOCAL VARIABLES:
                0280       INTEGER j, iL, ioUnit
b445337786 Jean*0281       LOGICAL prtMsg
db485ffb38 Jean*0282       LOGICAL useCurrentDir
1ab8368700 Jean*0283       _RS     dummyRS(1)
8be8fc53ab Jean*0284       CHARACTER*(2) fType
                0285       CHARACTER*(MAX_LEN_FNAM) fName
                0286       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0287 C-----
                0288 
                0289       iL = ILNBLNK(mFldsFile)
                0290 #ifdef RW_SAFE_MFLDS
                0291       IF ( iL.EQ.0 ) THEN
                0292         WRITE(msgBuf,'(2A,I4)') 'READ_MFLDS_3D_RL: ',
                0293      &    'empty MFLDS file-name'
                0294         CALL PRINT_ERROR( msgBuf, myThid )
b445337786 Jean*0295         CALL ALL_PROC_DIE( myThid )
8be8fc53ab Jean*0296         STOP 'ABNORMAL END: S/R READ_MFLDS_3D_RL (fileName)'
                0297       ENDIF
                0298 #endif /* RW_SAFE_MFLDS */
                0299 
                0300       ioUnit = standardMessageUnit
b445337786 Jean*0301       prtMsg = debugLevel.GE.debLevA .AND. myThid.EQ.1
8be8fc53ab Jean*0302       IF ( nFlds.GE.1 ) THEN
                0303 C--   Search for "fldName" in list of field-names:
                0304         nj = 0
                0305         DO j=1,nFlds
                0306           IF ( fldName.EQ.fldList(j) .AND. nj.EQ.0 ) nj = j
                0307         ENDDO
                0308         IF ( nj.EQ.0 ) THEN
                0309 C-      record unsuccessful search:
                0310           _BEGIN_MASTER( myThid )
                0311           nMissFld = nMissFld + 1
                0312           j = MIN(nMissFld,sizFldList)
                0313           fldMiss(j) = fldName
                0314           _END_MASTER( myThid )
b445337786 Jean*0315           IF ( prtMsg ) THEN
8be8fc53ab Jean*0316             iL = ILNBLNK(mFldsFile)
                0317             iL = MIN(iL,MAX_LEN_MBUF-54-20)
                0318             WRITE(msgBuf,'(5A)') 'READ_MFLDS_3D_RL: ',
                0319      &       'field: "',fldName,'" missing in file: ',mFldsFile(1:iL)
                0320             CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0321           ENDIF
                0322         ELSE
                0323 C-      convert from field Number to record number (if mix of 3D & 2D flds)
                0324           j = nj
                0325           IF ( nj.GT.nFl3D ) nj = nj + nFl3D*(thirdDim-1)
b445337786 Jean*0326           IF ( prtMsg ) THEN
8be8fc53ab Jean*0327             WRITE(msgBuf,'(3A,2(A,I4))') 'READ_MFLDS_3D_RL: ',
                0328      &       'read field: "',fldName,'", #',j,' in fldList, rec=',nj
                0329             CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0330           ENDIF
                0331         ENDIF
                0332       ELSEIF ( nj.GE.0 ) THEN
                0333 C-      increment record number
                0334         nj = nj + 1
b445337786 Jean*0335         IF ( prtMsg ) THEN
8be8fc53ab Jean*0336             WRITE(msgBuf,'(3A,2(A,I4))') 'READ_MFLDS_3D_RL: ',
                0337      &       'no fldList, try to read field "',fldName, '", rec=',nj
                0338             CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0339         ENDIF
                0340       ENDIF
                0341 
                0342       IF ( nj.GE.1 ) THEN
                0343 C--   read in array "field"
                0344         fName = mFldsFile
db485ffb38 Jean*0345         useCurrentDir = .FALSE.
8be8fc53ab Jean*0346         fType = 'RL'
                0347 #ifdef ALLOW_MDSIO
db485ffb38 Jean*0348         CALL MDS_READ_FIELD(
                0349      I                       fName, fPrec, useCurrentDir,
                0350      I                       fType, nNz, 1, nNz,
1ab8368700 Jean*0351      O                       field, dummyRS,
db485ffb38 Jean*0352      I                       nj, myThid )
                0353 
8be8fc53ab Jean*0354 #endif
                0355       ENDIF
                0356 
                0357       RETURN
                0358       END
                0359 
                0360 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0361 CBOP
79bad69582 Jean*0362 C     !ROUTINE: READ_MFLDS_LEV_RL
                0363 C     !INTERFACE:
                0364       SUBROUTINE READ_MFLDS_LEV_RL(
                0365      I                fldName,
                0366      O                field,
                0367      U                nj,
                0368      I                fPrec, kSiz, kLo, kHi, myIter, myThid )
                0369 
                0370 C     !DESCRIPTION:
                0371 C     Read, from a Multi-Fields binary file, field "fldName", a set of
5bc5177bde Jean*0372 C     consecutive levels (from kLo to kHi) into 3D RL array "field" (size: kSiz)
79bad69582 Jean*0373 C     record Nb "nj" is search through the field-list (from meta-file) which
                0374 C     has been set before (calling READ_MFLDS_SET).
5bc5177bde Jean*0375 C     In case nFlds is <=0, by-pass the search and directly read record number "nj"
79bad69582 Jean*0376 
                0377 C     !USES:
                0378       IMPLICIT NONE
                0379 #include "SIZE.h"
                0380 #include "EEPARAMS.h"
                0381 #include "PARAMS.h"
                0382 #include "RW_MFLDS.h"
                0383 
                0384 C     !INPUT/OUTPUT PARAMETERS:
                0385 C     fldName :: Name of the field to read
5bc5177bde Jean*0386 C     field   :: Output array (RL type) to read in
79bad69582 Jean*0387 C     nj (in) :: number of the record (in file) just before the one to read
                0388 C     nj (out):: number of the record (from current file) which was read in
                0389 C     fPrec   :: File precision (number of bits per word, = 32 or 64)
                0390 C     kSiz    :: size of third dimension of array "field" to read-in
                0391 C     kLo     :: 1rst vertical level (of array "field") to read-in
                0392 C     kHi     :: last vertical level (of array "field") to read-in
                0393 C     myIter  :: Iteration number
                0394 C     myThid  :: My Thread Id number
                0395       CHARACTER*(8) fldName
                0396       _RL     field(*)
                0397       INTEGER nj
                0398       INTEGER fPrec
                0399       INTEGER kSiz, kLo, kHi
                0400       INTEGER myIter
                0401       INTEGER myThid
                0402 CEOP
                0403 
                0404 C     !FUNCTIONS
                0405       INTEGER  ILNBLNK
                0406       EXTERNAL ILNBLNK
                0407 
                0408 C     !LOCAL VARIABLES:
                0409       INTEGER j, iL, ioUnit
b445337786 Jean*0410       LOGICAL prtMsg
79bad69582 Jean*0411       LOGICAL useCurrentDir
1ab8368700 Jean*0412       _RS     dummyRS(1)
79bad69582 Jean*0413       CHARACTER*(2) fType
                0414       CHARACTER*(MAX_LEN_FNAM) fName
                0415       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0416 C-----
                0417 
                0418       iL = ILNBLNK(mFldsFile)
                0419 #ifdef RW_SAFE_MFLDS
                0420       IF ( iL.EQ.0 ) THEN
                0421         WRITE(msgBuf,'(2A,I4)') 'READ_MFLDS_LEV_RL: ',
                0422      &    'empty MFLDS file-name'
                0423         CALL PRINT_ERROR( msgBuf, myThid )
b445337786 Jean*0424         CALL ALL_PROC_DIE( myThid )
79bad69582 Jean*0425         STOP 'ABNORMAL END: S/R READ_MFLDS_LEV_RL (fileName)'
                0426       ENDIF
                0427 #endif /* RW_SAFE_MFLDS */
                0428 
                0429       ioUnit = standardMessageUnit
b445337786 Jean*0430       prtMsg = debugLevel.GE.debLevA .AND. myThid.EQ.1
79bad69582 Jean*0431       IF ( nFlds.GE.1 ) THEN
                0432 C--   Search for "fldName" in list of field-names:
                0433         nj = 0
                0434         DO j=1,nFlds
                0435           IF ( fldName.EQ.fldList(j) .AND. nj.EQ.0 ) nj = j
                0436         ENDDO
                0437         IF ( nj.EQ.0 ) THEN
                0438 C-      record unsuccessful search:
                0439           _BEGIN_MASTER( myThid )
                0440           nMissFld = nMissFld + 1
                0441           j = MIN(nMissFld,sizFldList)
                0442           fldMiss(j) = fldName
                0443           _END_MASTER( myThid )
b445337786 Jean*0444           IF ( prtMsg ) THEN
79bad69582 Jean*0445             iL = ILNBLNK(mFldsFile)
                0446             iL = MIN(iL,MAX_LEN_MBUF-54-20)
                0447             WRITE(msgBuf,'(5A)') 'READ_MFLDS_LEV_RL: ',
                0448      &       'field: "',fldName,'" missing in file: ',mFldsFile(1:iL)
                0449             CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0450           ENDIF
                0451         ELSE
                0452 C-      convert from field Number to record number (if mix of 3D & 2D flds)
                0453           j = nj
                0454           IF ( nj.GT.nFl3D ) nj = nj + nFl3D*(thirdDim-1)
b445337786 Jean*0455           IF ( prtMsg ) THEN
79bad69582 Jean*0456             WRITE(msgBuf,'(3A,2(A,I4))') 'READ_MFLDS_LEV_RL: ',
                0457      &       'read field: "',fldName,'", #',j,' in fldList, rec=',nj
                0458             CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0459           ENDIF
                0460         ENDIF
                0461       ELSEIF ( nj.GE.0 ) THEN
                0462 C-      increment record number
                0463         nj = nj + 1
b445337786 Jean*0464         IF ( prtMsg ) THEN
79bad69582 Jean*0465             WRITE(msgBuf,'(3A,2(A,I4))') 'READ_MFLDS_LEV_RL: ',
                0466      &       'no fldList, try to read field "',fldName, '", rec=',nj
                0467             CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0468         ENDIF
                0469       ENDIF
                0470 
                0471       IF ( nj.GE.1 ) THEN
                0472 C--   read in array "field"
                0473         fName = mFldsFile
                0474         useCurrentDir = .FALSE.
                0475         fType = 'RL'
                0476 #ifdef ALLOW_MDSIO
                0477         CALL MDS_READ_FIELD(
                0478      I                       fName, fPrec, useCurrentDir,
                0479      I                       fType, kSiz, kLo, kHi,
1ab8368700 Jean*0480      O                       field, dummyRS,
79bad69582 Jean*0481      I                       nj, myThid )
5bc5177bde Jean*0482 
                0483 #endif
                0484       ENDIF
                0485 
                0486       RETURN
                0487       END
                0488 
                0489 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0490 CBOP
                0491 C     !ROUTINE: READ_MFLDS_LEV_RS
                0492 C     !INTERFACE:
                0493       SUBROUTINE READ_MFLDS_LEV_RS(
                0494      I                fldName,
                0495      O                field,
                0496      U                nj,
                0497      I                fPrec, kSiz, kLo, kHi, myIter, myThid )
                0498 
                0499 C     !DESCRIPTION:
                0500 C     Read, from a Multi-Fields binary file, field "fldName", a set of
                0501 C     consecutive levels (from kLo to kHi) into 3D RS array "field" (size: kSiz)
                0502 C     record Nb "nj" is search through the field-list (from meta-file) which
                0503 C     has been set before (calling READ_MFLDS_SET).
                0504 C     In case nFlds is <=0, by-pass the search and directly read record number "nj"
                0505 
                0506 C     !USES:
                0507       IMPLICIT NONE
                0508 #include "SIZE.h"
                0509 #include "EEPARAMS.h"
                0510 #include "PARAMS.h"
                0511 #include "RW_MFLDS.h"
                0512 
                0513 C     !INPUT/OUTPUT PARAMETERS:
                0514 C     fldName :: Name of the field to read
                0515 C     field   :: Output array (RS type) to read in
                0516 C     nj (in) :: number of the record (in file) just before the one to read
                0517 C     nj (out):: number of the record (from current file) which was read in
                0518 C     fPrec   :: File precision (number of bits per word, = 32 or 64)
                0519 C     kSiz    :: size of third dimension of array "field" to read-in
                0520 C     kLo     :: 1rst vertical level (of array "field") to read-in
                0521 C     kHi     :: last vertical level (of array "field") to read-in
                0522 C     myIter  :: Iteration number
                0523 C     myThid  :: My Thread Id number
                0524       CHARACTER*(8) fldName
                0525       _RS     field(*)
                0526       INTEGER nj
                0527       INTEGER fPrec
                0528       INTEGER kSiz, kLo, kHi
                0529       INTEGER myIter
                0530       INTEGER myThid
                0531 CEOP
                0532 
                0533 C     !FUNCTIONS
                0534       INTEGER  ILNBLNK
                0535       EXTERNAL ILNBLNK
                0536 
                0537 C     !LOCAL VARIABLES:
                0538       INTEGER j, iL, ioUnit
                0539       LOGICAL prtMsg
                0540       LOGICAL useCurrentDir
                0541       _RL     dummyRL(1)
                0542       CHARACTER*(2) fType
                0543       CHARACTER*(MAX_LEN_FNAM) fName
                0544       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0545 C-----
                0546 
                0547       iL = ILNBLNK(mFldsFile)
                0548 #ifdef RW_SAFE_MFLDS
                0549       IF ( iL.EQ.0 ) THEN
                0550         WRITE(msgBuf,'(2A,I4)') 'READ_MFLDS_LEV_RS: ',
                0551      &    'empty MFLDS file-name'
                0552         CALL PRINT_ERROR( msgBuf, myThid )
                0553         CALL ALL_PROC_DIE( myThid )
                0554         STOP 'ABNORMAL END: S/R READ_MFLDS_LEV_RS (fileName)'
                0555       ENDIF
                0556 #endif /* RW_SAFE_MFLDS */
                0557 
                0558       ioUnit = standardMessageUnit
                0559       prtMsg = debugLevel.GE.debLevA .AND. myThid.EQ.1
                0560       IF ( nFlds.GE.1 ) THEN
                0561 C--   Search for "fldName" in list of field-names:
                0562         nj = 0
                0563         DO j=1,nFlds
                0564           IF ( fldName.EQ.fldList(j) .AND. nj.EQ.0 ) nj = j
                0565         ENDDO
                0566         IF ( nj.EQ.0 ) THEN
                0567 C-      record unsuccessful search:
                0568           _BEGIN_MASTER( myThid )
                0569           nMissFld = nMissFld + 1
                0570           j = MIN(nMissFld,sizFldList)
                0571           fldMiss(j) = fldName
                0572           _END_MASTER( myThid )
                0573           IF ( prtMsg ) THEN
                0574             iL = ILNBLNK(mFldsFile)
                0575             iL = MIN(iL,MAX_LEN_MBUF-54-20)
                0576             WRITE(msgBuf,'(5A)') 'READ_MFLDS_LEV_RS: ',
                0577      &       'field: "',fldName,'" missing in file: ',mFldsFile(1:iL)
                0578             CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0579           ENDIF
                0580         ELSE
                0581 C-      convert from field Number to record number (if mix of 3D & 2D flds)
                0582           j = nj
                0583           IF ( nj.GT.nFl3D ) nj = nj + nFl3D*(thirdDim-1)
                0584           IF ( prtMsg ) THEN
                0585             WRITE(msgBuf,'(3A,2(A,I4))') 'READ_MFLDS_LEV_RS: ',
                0586      &       'read field: "',fldName,'", #',j,' in fldList, rec=',nj
                0587             CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0588           ENDIF
                0589         ENDIF
                0590       ELSEIF ( nj.GE.0 ) THEN
                0591 C-      increment record number
                0592         nj = nj + 1
                0593         IF ( prtMsg ) THEN
                0594             WRITE(msgBuf,'(3A,2(A,I4))') 'READ_MFLDS_LEV_RS: ',
                0595      &       'no fldList, try to read field "',fldName, '", rec=',nj
                0596             CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0597         ENDIF
                0598       ENDIF
                0599 
                0600       IF ( nj.GE.1 ) THEN
                0601 C--   read in array "field"
                0602         fName = mFldsFile
                0603         useCurrentDir = .FALSE.
                0604         fType = 'RS'
                0605 #ifdef ALLOW_MDSIO
                0606         CALL MDS_READ_FIELD(
                0607      I                       fName, fPrec, useCurrentDir,
                0608      I                       fType, kSiz, kLo, kHi,
                0609      O                       dummyRL, field,
                0610      I                       nj, myThid )
79bad69582 Jean*0611 
                0612 #endif
                0613       ENDIF
                0614 
                0615       RETURN
                0616       END
                0617 
                0618 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0619 CBOP
8be8fc53ab Jean*0620 C     !ROUTINE: READ_MFLDS_CHECK
                0621 C     !INTERFACE:
                0622       SUBROUTINE READ_MFLDS_CHECK(
                0623      O                errList,
                0624      U                nbErr,
                0625      I                myIter, myThid )
                0626 
                0627 C     !DESCRIPTION:
                0628 C     After reading a Multi-Fields binary file, check (and report)
                0629 C     for missing fields (attempted to read but not found).
                0630 C
                0631 C     Note: If missing fields, print error msg but take no action (no stop)
                0632 C           but return number of missing fields (+ list, if nbErr_inputArg > 0)
                0633 C           Depending on the calling context, may choose to stop or to continue
                0634 
                0635 C     !USES:
                0636       IMPLICIT NONE
                0637 #include "SIZE.h"
                0638 #include "EEPARAMS.h"
                0639 #include "PARAMS.h"
                0640 #include "RW_MFLDS.h"
                0641 
                0642 C     !INPUT PARAMETERS:
                0643 C     nbErr   :: max size of array errList
                0644 C     myIter  :: Iteration number
                0645 C     myThid  :: My Thread Id number
                0646 C     !OUTPUT PARAMETERS:
                0647 C     errList :: List of missing fields   (attempted to read but not found)
                0648 C     nbErr   :: Number of missing fields (attempted to read but not found)
                0649       CHARACTER*(8) errList(*)
                0650       INTEGER nbErr
                0651       INTEGER myIter
                0652       INTEGER myThid
                0653 CEOP
                0654 
                0655 C     !FUNCTIONS
                0656       INTEGER  ILNBLNK
                0657       EXTERNAL ILNBLNK
                0658 
                0659 C     !LOCAL VARIABLES:
                0660       INTEGER i, j, nj, iL, ioUnit
b445337786 Jean*0661       LOGICAL prtMsg
8be8fc53ab Jean*0662       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0663 C-----
                0664 
                0665       iL = ILNBLNK(mFldsFile)
                0666 #ifdef RW_SAFE_MFLDS
                0667       IF ( iL.EQ.0 ) THEN
                0668         WRITE(msgBuf,'(2A,I4)') 'READ_MFLDS_CHECK: ',
                0669      &    'empty MFLDS file-name'
                0670         CALL PRINT_ERROR( msgBuf, myThid )
b445337786 Jean*0671         CALL ALL_PROC_DIE( myThid )
8be8fc53ab Jean*0672         STOP 'ABNORMAL END: S/R READ_MFLDS_CHECK (fileName)'
                0673       ENDIF
                0674 #endif /* RW_SAFE_MFLDS */
                0675 
                0676 C--   Initialise output arguments
                0677       DO j=1,nbErr
                0678        errList(j) = ' '
                0679       ENDDO
                0680 
79bad69582 Jean*0681 C--   every one waits for master thread to finish the update of
                0682 C       missing fields number & list.
                0683       _BARRIER
                0684 
8be8fc53ab Jean*0685       IF ( nMissFld.GE.1 ) THEN
                0686 C--   Attempted to read some fields that were not in the current MFLDS file
                0687 C     => report by printing Error Msg:
                0688          ioUnit = errorMessageUnit
b445337786 Jean*0689          _BEGIN_MASTER( myThid )
8be8fc53ab Jean*0690          WRITE(msgBuf,'(3A)') 'READ_MFLDS_CHECK: ',
                0691      &     'reading from file: ', mFldsFile(1:iL)
                0692          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0693          WRITE(msgBuf,'(2A,I4,A)') 'READ_MFLDS_CHECK: ',
                0694      &     'which contains ', nFlds, ' fields :'
                0695          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0696          DO j=1,nFlds,20
                0697           WRITE(msgBuf,'(20(A2,A8,A))')
                0698      &     (' >', fldList(i), '<', i=j,MIN(j+19,nFlds) )
                0699           CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0700          ENDDO
                0701          WRITE(msgBuf,'(A,I4,A)') 'READ_MFLDS_CHECK: ',
                0702      &                  nMissFld, ' field(s) is/are missing :'
                0703          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0704          nj = MIN( nMissFld, sizFldList )
                0705          DO j=1,nj,20
                0706           WRITE(msgBuf,'(20(A2,A8,A))')
                0707      &     (' >', fldMiss(i), '<', i=j,MIN(j+19,nj) )
                0708           CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0709          ENDDO
b445337786 Jean*0710          _END_MASTER( myThid )
8be8fc53ab Jean*0711 
                0712 C-       Size problem:
                0713          IF ( nMissFld.GT.sizFldList ) THEN
                0714            WRITE(msgBuf,'(2A,I4)') 'READ_MFLDS_CHECK: ',
                0715      &      'missing fields list has been truncated to', sizFldList
                0716            CALL PRINT_ERROR( msgBuf, myThid )
b445337786 Jean*0717            CALL ALL_PROC_DIE( myThid )
8be8fc53ab Jean*0718            STOP 'ABNORMAL END: S/R READ_MFLDS_CHECK (list-size Pb)'
                0719          ENDIF
                0720 
                0721 C-       Fill the error output list (up to the Max size: nbErr)
                0722          nj = MIN( nMissFld, nbErr )
                0723          DO j=1,nj
                0724           errList(j) = fldMiss(j)
                0725          ENDDO
                0726       ELSE
                0727 C--   Normal end : print msg before resetting "mFldsFile"
                0728         ioUnit = standardMessageUnit
b445337786 Jean*0729         prtMsg = debugLevel.GE.debLevA .AND. myThid.EQ.1
                0730         IF ( prtMsg ) THEN
8be8fc53ab Jean*0731          WRITE(msgBuf,'(3A)') 'READ_MFLDS_CHECK: ',
                0732      &     '- normal end ; reset MFLDS file-name: ', mFldsFile(1:iL)
                0733          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0734         ENDIF
                0735 
                0736       ENDIF
                0737 
                0738 C-    Return the number of missing fields
                0739       nbErr = nMissFld
                0740 
                0741 #ifdef RW_SAFE_MFLDS
                0742       _BARRIER
                0743       _BEGIN_MASTER( myThid )
                0744 C--   Reset MFLDS file name:
                0745        mFldsFile = ' '
                0746       _END_MASTER( myThid )
                0747       _BARRIER
                0748 #endif /* RW_SAFE_MFLDS */
                0749 
                0750       RETURN
                0751       END
1596008957 Jean*0752 
                0753 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0754 CBOP
                0755 C     !ROUTINE: READ_MFLDS_RENAME
                0756 C     !INTERFACE:
                0757       SUBROUTINE READ_MFLDS_RENAME(
                0758      I                              fldName, newName,
                0759      O                              errCode,
                0760      I                              myThid )
                0761 
                0762 C     !DESCRIPTION:
                0763 C     Rename one field in fldList
                0764 
                0765 C     !USES:
                0766       IMPLICIT NONE
                0767 c#include "SIZE.h"
                0768 #include "EEPARAMS.h"
                0769 #include "RW_MFLDS.h"
                0770 
                0771 C     !INPUT/OUTPUT PARAMETERS:
                0772 C     fldName  :: field name to rename
                0773 C     newName  :: new name to replace fldName
                0774 C     errCode  :: returned error code:
                0775 C                 0 = succesful ; 1 = fldName not found ; > 1 : error
                0776 C     myThid   :: my Thread Id. number
                0777       CHARACTER*(8) fldName
                0778       CHARACTER*(8) newName
                0779       INTEGER errCode
                0780       INTEGER myThid
                0781 CEOP
                0782 
                0783 C     !LOCAL VARIABLES:
                0784 C     i , j    :: loop counter
                0785       INTEGER i , j
                0786 C-    for debug print:
                0787 c     CHARACTER*(MAX_LEN_MBUF) msgBuf
                0788 
                0789       errCode = 1
                0790 
                0791 C-    search for fldName in fldList:
                0792       j = 0
                0793       DO i=1,nFlds
                0794         IF ( fldList(i) .EQ. fldName ) THEN
                0795           IF ( j.EQ.0 ) THEN
                0796             errCode = 0
                0797             j = i
                0798           ELSE
                0799 C--    fldName appears more than once in fldList (errCode=3):
                0800             errCode = 3
                0801           ENDIF
                0802         ENDIF
                0803       ENDDO
                0804 
                0805       IF ( errCode.EQ.0 ) THEN
                0806 C--   Do not replace if newName is already in the list (errCode=2):
                0807         DO i=1,nFlds
                0808           IF ( fldList(i).EQ.newName ) errCode = 2
                0809         ENDDO
                0810       ENDIF
                0811 
                0812       IF ( errCode.EQ.0 ) THEN
694f6da5b8 Jean*0813         _BARRIER
1596008957 Jean*0814         _BEGIN_MASTER( myThid )
                0815         fldList(j) = newName
                0816         _END_MASTER( myThid )
                0817         _BARRIER
                0818       ENDIF
                0819 
                0820       RETURN
                0821       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!