pkg/dic/dic_read_pickup.F

7f407c2fb7 Davi*0001 #include "DIC_OPTIONS.h"
                0002
51e381e9c9 Jean*0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP
                0005 C     !ROUTINE: DIC_READ_PICKUP
7f407c2fb7 Davi*0006
51e381e9c9 Jean*0007 C     !INTERFACE:
                0008       SUBROUTINE DIC_READ_PICKUP( myIter, myThid )
                0009
                0010 C     !DESCRIPTION:
                0011 C     Reads current state of DIC from a pickup file
                0012
                0013 C     !USES:
7f407c2fb7 Davi*0014       IMPLICIT NONE
51e381e9c9 Jean*0015 C     == Global variables ===
7f407c2fb7 Davi*0016 #include "SIZE.h"
                0017 #include "EEPARAMS.h"
                0018 #include "PARAMS.h"
2ef8966791 Davi*0019 #include "DIC_VARS.h"
7f407c2fb7 Davi*0020
51e381e9c9 Jean*0021 C     !INPUT PARAMETERS:
                0022 C     myIter      :: time-step number in simulation
                0023 C     myThid      :: my Thread Id number
7f407c2fb7 Davi*0024       INTEGER myIter
                0025       INTEGER myThid
                0026
                0027 #ifdef ALLOW_DIC
                0028 #ifdef DIC_BIOTIC
51e381e9c9 Jean*0029 C     !FUNCTIONS:
                0030       INTEGER  ILNBLNK
                0031       EXTERNAL ILNBLNK
d800a455f8 Jean*0032
7f407c2fb7 Davi*0033 C     !LOCAL VARIABLES:
51e381e9c9 Jean*0034 C     fn          :: character buffer for creating filename
                0035 C     fp          :: precision of pickup files
                0036 C     filePrec    :: pickup-file precision (read from meta file)
                0037 C     nbFields    :: number of fields in pickup file (read from meta file)
                0038 C     missFldList :: List of missing fields   (attempted to read but not found)
                0039 C     missFldDim  :: Dimension of missing fields list array: missFldList
                0040 C     nMissing    :: Number of missing fields (attempted to read but not found)
                0041 C     j           :: loop index
                0042 C     nj          :: record number
                0043 C     ioUnit      :: temp for writing msg unit
                0044 C     msgBuf      :: Informational/error message buffer
                0045       INTEGER fp
                0046       INTEGER filePrec, nbFields
                0047       INTEGER missFldDim, nMissing
                0048       INTEGER j, nj, ioUnit
                0049       PARAMETER( missFldDim = 12 )
df5a9764ba Jean*0050       CHARACTER*(10) suff
51e381e9c9 Jean*0051       CHARACTER*(MAX_LEN_FNAM) fn
                0052       CHARACTER*(8) missFldList(missFldDim)
d800a455f8 Jean*0053       CHARACTER*(MAX_LEN_MBUF) msgBuf
51e381e9c9 Jean*0054       CHARACTER*(MAX_LEN_FNAM) tmpNam
                0055 C- note: to avoid beeing caught by tools/OAD_support/stop2print.sed,
                0056 C        change "stopFlag" to "StopFlag"
                0057       LOGICAL useCurrentDir, fileExist, StopFlag
                0058       INTEGER iL
7f407c2fb7 Davi*0059 CEOP
                0060
51e381e9c9 Jean*0061 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
d800a455f8 Jean*0062
51e381e9c9 Jean*0063        IF ( pickupSuff.EQ.' ' ) THEN
df5a9764ba Jean*0064         IF ( rwSuffixType.EQ.0 ) THEN
                0065           WRITE(fn,'(A,I10.10)') 'pickup_dic.', myIter
                0066         ELSE
                0067           CALL RW_GET_SUFFIX( suff, startTime, myIter, myThid )
                0068           WRITE(fn,'(A,A)') 'pickup_dic.', suff
                0069         ENDIF
51e381e9c9 Jean*0070        ELSE
d800a455f8 Jean*0071         WRITE(fn,'(A,A10)') 'pickup_dic.', pickupSuff
51e381e9c9 Jean*0072        ENDIF
                0073        fp = precFloat64
7f407c2fb7 Davi*0074
51e381e9c9 Jean*0075        CALL READ_MFLDS_SET(
                0076      I                      fn,
                0077      O                      nbFields, filePrec,
                0078      I                      Nr, myIter, myThid )
                0079        _BEGIN_MASTER( myThid )
                0080 c      IF ( filePrec.NE.0 .AND. filePrec.NE.fp ) THEN
                0081        IF ( nbFields.GE.0 .AND. filePrec.NE.fp ) THEN
                0082          WRITE(msgBuf,'(2A,I4)') 'DIC_READ_PICKUP: ',
                0083      &    'pickup-file binary precision do not match !'
                0084          CALL PRINT_ERROR( msgBuf, myThid )
                0085          WRITE(msgBuf,'(A,2(A,I4))') 'DIC_READ_PICKUP: ',
                0086      &    'file prec.=', filePrec, ' but expecting prec.=', fp
                0087          CALL PRINT_ERROR( msgBuf, myThid )
                0088          CALL ALL_PROC_DIE( 0 )
                0089          STOP 'ABNORMAL END: S/R DIC_READ_PICKUP (data-prec Pb)'
                0090        ENDIF
                0091        _END_MASTER( myThid )
                0092
                0093        ioUnit = errorMessageUnit
                0094        StopFlag = .FALSE.
                0095        IF ( nbFields.LE.0 ) THEN
                0096 C-      No meta-file or old meta-file without List of Fields
                0097         IF ( pickupStrictlyMatch ) THEN
                0098          WRITE(msgBuf,'(4A)') 'DIC_READ_PICKUP: ',
                0099      &      'no field-list found in meta-file',
                0100      &      ' => cannot check for strick-matching'
                0101          CALL PRINT_ERROR( msgBuf, myThid )
                0102          WRITE(msgBuf,'(4A)') 'DIC_READ_PICKUP: ',
                0103      &      'try with " pickupStrictlyMatch=.FALSE.,"',
                0104      &      ' in file: "data", NameList: "PARM03"'
                0105          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0106          StopFlag = .TRUE.
                0107         ELSE
                0108          WRITE(msgBuf,'(4A)') 'WARNING >> DIC_READ_PICKUP: ',
                0109      &      ' no field-list found'
                0110          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0111          IF ( nbFields.EQ.-1 ) THEN
                0112 C-      No meta-file: then check if binary pickup file (i.e., ".data") exist
c8b148d42e Jean*0113 #ifdef ALLOW_MDSIO
51e381e9c9 Jean*0114           useCurrentDir = .FALSE.
                0115           CALL MDS_CHECK4FILE(
4aace458cd Jean*0116      I                     fn, '.data', 'DIC_READ_PICKUP',
51e381e9c9 Jean*0117      O                     tmpNam, fileExist,
c8b148d42e Jean*0118      I                     useCurrentDir, myThid )
                0119 #else
51e381e9c9 Jean*0120           STOP 'ABNORMAL END: S/R DIC_READ_PICKUP: Needs MDSIO pkg'
c8b148d42e Jean*0121 #endif
51e381e9c9 Jean*0122           IF ( fileExist ) THEN
                0123            WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0124      &      ' try to read pickup as currently written'
                0125            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0126           ELSE
                0127            iL = ILNBLNK(fn)
                0128            WRITE(msgBuf,'(4A)') 'DIC_READ_PICKUP: ',
                0129      &      'missing both "meta" & "data" files for "', fn(1:iL), '"'
                0130            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0131            nbFields = -2
                0132           ENDIF
                0133          ELSE
                0134 C-      Old meta-file without List of Fields
                0135 c         WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0136 c    &      ' try to read pickup as it used to be written'
                0137 c         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0138 c         WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0139 c    &      ' until checkpoint59l (2007 Dec 17)'
                0140 c         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0141           WRITE(msgBuf,'(4A)') 'DIC_READ_PICKUP: ',
                0142      &      'no field-list found in meta-file'
                0143           CALL PRINT_ERROR( msgBuf, myThid )
                0144           StopFlag = .TRUE.
                0145          ENDIF
                0146         ENDIF
                0147        ENDIF
                0148        IF ( StopFlag ) THEN
                0149          CALL ALL_PROC_DIE( myThid )
                0150          STOP 'ABNORMAL END: S/R DIC_READ_PICKUP'
                0151        ENDIF
d800a455f8 Jean*0152
51e381e9c9 Jean*0153 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
d800a455f8 Jean*0154
51e381e9c9 Jean*0155        IF ( nbFields.EQ.0 ) THEN
                0156 C---   Old meta-file without List of Fields: use the old way to read pickup
                0157
                0158        ELSEIF ( nbFields.NE.-2 ) THEN
                0159 C---   New way to read DIC pickup:
                0160         nj = 0
                0161 C---    read DIC 3-D fields for restart
                0162 #ifdef DIC_CALCITE_SAT
                0163         IF ( useCalciteSaturation ) THEN
                0164 c        CALL READ_MFLDS_3D_RL( 'DIC_pH3d', pH3D,
                0165 c    &                                 nj, fp, Nr, myIter, myThid )
                0166 c        _BEGIN_MASTER( myThid )
                0167 c        pH_isLoaded(2) = .TRUE.
                0168 c        _END_MASTER( myThid )
                0169         ENDIF
                0170 #endif
                0171
                0172 C-    switch to 2-D fields:
                0173         nj = nj*Nr
                0174 C---    read DIC 2-D fields for restart
                0175         CALL READ_MFLDS_3D_RL( 'DIC_pH2d', pH,
                0176      &                                 nj, fp, 1 , myIter, myThid )
                0177         _BEGIN_MASTER( myThid )
                0178         pH_isLoaded(1) = .TRUE.
                0179         _END_MASTER( myThid )
                0180
                0181 C--    end: new way to read pickup file
                0182        ENDIF
                0183
                0184 C--    Check for missing fields:
                0185        nMissing = missFldDim
                0186        CALL READ_MFLDS_CHECK(
                0187      O                     missFldList,
                0188      U                     nMissing,
                0189      I                     myIter, myThid )
                0190        IF ( nMissing.GT.missFldDim ) THEN
                0191          WRITE(msgBuf,'(2A,I4)') 'DIC_READ_PICKUP: ',
                0192      &     'missing fields list has been truncated to', missFldDim
                0193          CALL PRINT_ERROR( msgBuf, myThid )
                0194          CALL ALL_PROC_DIE( myThid )
                0195          STOP 'ABNORMAL END: S/R DIC_READ_PICKUP (list-size Pb)'
                0196        ENDIF
                0197        IF ( nMissing.GE.1 ) THEN
                0198         DO j=1,nMissing
                0199          IF ( missFldList(nj) .EQ. 'DIC_pH2d' ) THEN
                0200            _BEGIN_MASTER( myThid )
                0201            pH_isLoaded(1) = .FALSE.
                0202            _END_MASTER( myThid )
                0203          ELSEIF ( missFldList(nj) .EQ. 'DIC_pH3d' ) THEN
                0204            _BEGIN_MASTER( myThid )
                0205            pH_isLoaded(2) = .FALSE.
                0206            _END_MASTER( myThid )
                0207          ELSE
                0208           StopFlag = .TRUE.
                0209           WRITE(msgBuf,'(4A)') 'DIC_READ_PICKUP: ',
                0210      &       'cannot restart without field "',missFldList(nj),'"'
                0211           CALL PRINT_ERROR( msgBuf, myThid )
                0212          ENDIF
                0213         ENDDO
                0214         IF ( pickupStrictlyMatch .AND. .NOT.StopFlag ) THEN
                0215           StopFlag = .TRUE.
d800a455f8 Jean*0216           WRITE(msgBuf,'(4A)') 'DIC_READ_PICKUP: ',
                0217      &      'try with " pickupStrictlyMatch=.FALSE.,"',
                0218      &      ' in file: "data", NameList: "PARM03"'
51e381e9c9 Jean*0219           CALL PRINT_ERROR( msgBuf, myThid )
d800a455f8 Jean*0220         ENDIF
51e381e9c9 Jean*0221        ENDIF
                0222        IF ( StopFlag ) THEN
                0223          CALL ALL_PROC_DIE( myThid )
                0224          STOP 'ABNORMAL END: S/R DIC_READ_PICKUP'
                0225        ENDIF
                0226
                0227        _BEGIN_MASTER( myThid )
                0228        IF ( .NOT.pH_isLoaded(1) ) THEN
                0229          WRITE(msgBuf,'(2A)') 'WARNING >> DIC_READ_PICKUP: ',
                0230      &      'will restart from approximated 2-D pH'
                0231          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0232        ENDIF
                0233        IF ( useCalciteSaturation .AND. .NOT.pH_isLoaded(2) ) THEN
                0234          WRITE(msgBuf,'(2A)') 'WARNING >> DIC_READ_PICKUP: ',
                0235      &      'will restart from approximated 3-D pH'
                0236 c        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0237        ENDIF
                0238        _END_MASTER( myThid )
                0239
                0240 C--    Update overlap regions:
                0241        CALL EXCH_XY_RL( pH, myThid )
                0242 #ifdef DIC_CALCITE_SAT
                0243        IF ( useCalciteSaturation ) THEN
                0244 c        CALL EXCH_3D_RL( pH3D, Nr, myThid )
                0245        ENDIF
                0246 #endif
7f407c2fb7 Davi*0247
51e381e9c9 Jean*0248 #endif /* DIC_BIOTIC */
                0249 #endif /* ALLOW_DIC  */
7f407c2fb7 Davi*0250
                0251       RETURN
                0252       END