pkg/atm_phys/atm_phys_read_pickup.F

b2ea1d2979 Jean*0001 #include "ATM_PHYS_OPTIONS.h"
                0002
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP
                0005 C     !ROUTINE: ATM_PHYS_READ_PICKUP
                0006
                0007 C     !INTERFACE:
                0008       SUBROUTINE ATM_PHYS_READ_PICKUP( myIter, myThid )
                0009
                0010 C     !DESCRIPTION:
                0011 C     Reads current state of Atm_Phys from a pickup file
                0012
                0013 C     !USES:
                0014       IMPLICIT NONE
                0015 #include "SIZE.h"
                0016 #include "EEPARAMS.h"
                0017 #include "PARAMS.h"
                0018 #include "ATM_PHYS_PARAMS.h"
                0019 #include "ATM_PHYS_VARS.h"
                0020
                0021 C     !INPUT PARAMETERS:
                0022 C     myIter            :: time-step number
                0023 C     myThid            :: thread number
                0024       INTEGER myIter
                0025       INTEGER myThid
                0026
                0027 #ifdef ALLOW_ATM_PHYS
                0028
                0029 C     !LOCAL VARIABLES:
                0030 C     fn          :: character buffer for creating filename
                0031 C     fp          :: precision of pickup files
                0032 C     filePrec    :: pickup-file precision (read from meta file)
                0033 C     nbFields    :: number of fields in pickup file (read from meta file)
                0034 C     missFldList :: List of missing fields   (attempted to read but not found)
                0035 C     missFldDim  :: Dimension of missing fields list array: missFldList
                0036 C     nMissing    :: Number of missing fields (attempted to read but not found)
                0037 C     j           :: loop index
                0038 C     nj          :: record number
                0039 C     ioUnit      :: temp for writing msg unit
                0040 C     msgBuf      :: Informational/error message buffer
                0041       INTEGER fp
                0042       INTEGER filePrec, nbFields
                0043       INTEGER missFldDim, nMissing
                0044       INTEGER j, nj, ioUnit
                0045       PARAMETER( missFldDim = 12 )
ab33782b56 Jean*0046       CHARACTER*(10) suff
b2ea1d2979 Jean*0047       CHARACTER*(MAX_LEN_FNAM) fn
                0048       CHARACTER*(8) missFldList(missFldDim)
                0049       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0050 CEOP
                0051
                0052 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0053
b5f066e9ce Jean*0054 C-    for now, only needs pickup if stepping forward SST
                0055       IF ( .NOT.atmPhys_stepSST ) RETURN
                0056
b2ea1d2979 Jean*0057        IF ( pickupSuff.EQ.' ' ) THEN
ab33782b56 Jean*0058         IF ( rwSuffixType.EQ.0 ) THEN
                0059           WRITE(fn,'(A,I10.10)') 'pickup_atmPhys.', myIter
                0060         ELSE
                0061           CALL RW_GET_SUFFIX( suff, startTime, myIter, myThid )
                0062           WRITE(fn,'(A,A)') 'pickup_atmPhys.', suff
                0063         ENDIF
b2ea1d2979 Jean*0064        ELSE
ab33782b56 Jean*0065         WRITE(fn,'(A,A10)') 'pickup_atmPhys.', pickupSuff
b2ea1d2979 Jean*0066        ENDIF
                0067        fp = precFloat64
                0068
                0069        CALL READ_MFLDS_SET(
                0070      I                      fn,
                0071      O                      nbFields, filePrec,
                0072      I                      Nr, myIter, myThid )
                0073        _BEGIN_MASTER( myThid )
                0074 c      IF ( filePrec.NE.0 .AND. filePrec.NE.fp ) THEN
                0075        IF ( nbFields.GE.0 .AND. filePrec.NE.fp ) THEN
                0076          WRITE(msgBuf,'(2A,I4)') 'ATM_PHYS_READ_PICKUP: ',
                0077      &    'pickup-file binary precision do not match !'
                0078          CALL PRINT_ERROR( msgBuf, myThid )
                0079          WRITE(msgBuf,'(A,2(A,I4))') 'ATM_PHYS_READ_PICKUP: ',
                0080      &    'file prec.=', filePrec, ' but expecting prec.=', fp
                0081          CALL PRINT_ERROR( msgBuf, myThid )
                0082          CALL ALL_PROC_DIE( 0 )
                0083          STOP 'ABNORMAL END: S/R ATM_PHYS_READ_PICKUP (data-prec Pb)'
                0084        ENDIF
                0085        _END_MASTER( myThid )
                0086
                0087        IF ( nbFields.LE.0 ) THEN
                0088 C-      No meta-file or old meta-file without List of Fields
                0089         ioUnit = errorMessageUnit
                0090         IF ( pickupStrictlyMatch ) THEN
                0091           WRITE(msgBuf,'(4A)') 'ATM_PHYS_READ_PICKUP: ',
                0092      &      'no field-list found in meta-file',
                0093      &      ' => cannot check for strick-matching'
                0094           CALL PRINT_ERROR( msgBuf, myThid )
                0095           WRITE(msgBuf,'(4A)') 'ATM_PHYS_READ_PICKUP: ',
                0096      &      'try with " pickupStrictlyMatch=.FALSE.,"',
                0097      &      ' in file: "data", NameList: "PARM03"'
                0098           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0099           CALL ALL_PROC_DIE( myThid )
                0100           STOP 'ABNORMAL END: S/R ATM_PHYS_READ_PICKUP'
                0101         ELSE
                0102           WRITE(msgBuf,'(4A)') 'WARNING >> ATM_PHYS_READ_PICKUP: ',
                0103      &      ' no field-list found'
                0104           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0105          IF ( nbFields.EQ.-1 ) THEN
                0106 C-      No meta-file
                0107           WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0108      &      ' try to read pickup as currently written'
                0109           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0110          ELSE
                0111 C-      Old meta-file without List of Fields
                0112 c         WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0113 c    &      ' try to read pickup as it used to be written'
                0114 c         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0115 c         WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0116 c    &      ' until checkpoint59l (2007 Dec 17)'
                0117 c         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0118           WRITE(msgBuf,'(4A)') 'ATM_PHYS_READ_PICKUP: ',
                0119      &      'no field-list found in meta-file'
                0120           CALL PRINT_ERROR( msgBuf, myThid )
                0121           CALL ALL_PROC_DIE( myThid )
                0122           STOP 'ABNORMAL END: S/R ATM_PHYS_READ_PICKUP'
                0123          ENDIF
                0124         ENDIF
                0125        ENDIF
                0126
                0127 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0128
                0129        IF ( nbFields.EQ.0 ) THEN
                0130 C---   Old way to read pickup:
                0131
                0132        ELSE
                0133 C---   New way to read ATM_PHYS pickup:
                0134         nj = 0
                0135 C---    read ATM_PHYS 3-D fields for restart
                0136
                0137         nj = nj*Nr
                0138 C---    read ATM_PHYS 2-D fields for restart
                0139         CALL READ_MFLDS_3D_RL( 'AtPh_SST', atmPhys_SST,
                0140      &                                 nj, fp, 1 , myIter, myThid )
                0141
                0142 C--    end: new way to read pickup file
                0143        ENDIF
                0144
                0145 C--    Check for missing fields:
                0146        nMissing = missFldDim
                0147        CALL READ_MFLDS_CHECK(
                0148      O                     missFldList,
                0149      U                     nMissing,
                0150      I                     myIter, myThid )
                0151        IF ( nMissing.GT.missFldDim ) THEN
                0152          WRITE(msgBuf,'(2A,I4)') 'ATM_PHYS_READ_PICKUP: ',
                0153      &     'missing fields list has been truncated to', missFldDim
                0154          CALL PRINT_ERROR( msgBuf, myThid )
                0155          CALL ALL_PROC_DIE( myThid )
                0156          STOP 'ABNORMAL END: S/R ATM_PHYS_READ_PICKUP (list-size Pb)'
                0157        ENDIF
                0158        IF ( nMissing.GE.1 ) THEN
                0159         ioUnit = errorMessageUnit
                0160         DO j=1,nMissing
                0161          WRITE(msgBuf,'(4A)') 'ATM_PHYS_READ_PICKUP: ',
                0162      &       'cannot restart without field "',missFldList(nj),'"'
                0163          CALL PRINT_ERROR( msgBuf, myThid )
                0164         ENDDO
                0165         CALL ALL_PROC_DIE( myThid )
                0166         STOP 'ABNORMAL END: S/R ATM_PHYS_READ_PICKUP'
                0167        ENDIF
                0168
                0169 C--    Update overlap regions:
b5f066e9ce Jean*0170        CALL EXCH_XY_RL( atmPhys_SST, myThid )
b2ea1d2979 Jean*0171
                0172 #endif /* ALLOW_ATM_PHYS */
                0173
                0174       RETURN
                0175       END