pkg/shelfice/shelfice_read_pickup.F

198f6904ea Dani*0001 #include "SHELFICE_OPTIONS.h"
                0002
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP
                0005 C     !ROUTINE: SHELFICE_READ_PICKUP
                0006
                0007 C     !INTERFACE:
9952f046d7 dngo*0008       SUBROUTINE SHELFICE_READ_PICKUP( seqFlag, myIter, myThid )
198f6904ea Dani*0009
                0010 C     !DESCRIPTION:
                0011 C     Reads current state of SHELFICE 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 "SHELFICE.h"
                0019
                0020 C     !INPUT PARAMETERS:
9952f046d7 dngo*0021 C     seqFlag :: flag that indicate where this S/R is called from:
                0022 C             :: =0 called early on, from: ini_masks_etc.F
                0023 C             :: =1 called from INIT_VARIA (i.e. usual place)
                0024 C     myIter  :: my time-step number
                0025 C     myThid  :: my Thread Id number
                0026       INTEGER seqFlag
                0027       INTEGER myIter
198f6904ea Dani*0028       INTEGER myThid
                0029
                0030 #ifdef ALLOW_SHELFICE
                0031 C     !LOCAL VARIABLES:
                0032 C     fn          :: character buffer for creating filename
                0033 C     fp          :: precision of pickup files
                0034 C     filePrec    :: pickup-file precision (read from meta file)
                0035 C     nbFields    :: number of fields in pickup file (read from meta file)
                0036 C     missFldList :: List of missing fields   (attempted to read but not found)
                0037 C     missFldDim  :: Dimension of missing fields list array: missFldList
                0038 C     nMissing    :: Number of missing fields (attempted to read but not found)
                0039 C     j           :: loop index
                0040 C     nj          :: record number
                0041 C     ioUnit      :: temp for writing msg unit
                0042 C     msgBuf      :: Informational/error message buffer
                0043       INTEGER fp
                0044       INTEGER filePrec, nbFields
                0045       INTEGER missFldDim, nMissing
                0046       INTEGER j, nj, ioUnit
                0047       PARAMETER( missFldDim = 12 )
af20bc5e19 Jean*0048       CHARACTER*(10) suff
198f6904ea Dani*0049       CHARACTER*(MAX_LEN_FNAM) fn
                0050       CHARACTER*(8) missFldList(missFldDim)
                0051       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0052 CEOP
                0053
                0054 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0055
9952f046d7 dngo*0056       IF ( pickupSuff.EQ.' ' ) THEN
af20bc5e19 Jean*0057         IF ( rwSuffixType.EQ.0 ) THEN
                0058           WRITE(fn,'(A,I10.10)') 'pickup_shelfice.', nIter0
                0059         ELSE
                0060           CALL RW_GET_SUFFIX( suff, startTime, nIter0, myThid )
                0061           WRITE(fn,'(A,A)') 'pickup_shelfice.', suff
                0062         ENDIF
9952f046d7 dngo*0063       ELSE
af20bc5e19 Jean*0064         WRITE(fn,'(A,A10)')    'pickup_shelfice.', pickupSuff
9952f046d7 dngo*0065       ENDIF
                0066       fp = precFloat64
198f6904ea Dani*0067
9952f046d7 dngo*0068       CALL READ_MFLDS_SET(
198f6904ea Dani*0069      I                      fn,
                0070      O                      nbFields, filePrec,
                0071      I                      Nr, nIter0, myThid )
                0072
9952f046d7 dngo*0073       _BEGIN_MASTER( myThid )
                0074       IF ( nbFields.GE.0 .AND. filePrec.NE.fp ) THEN
198f6904ea Dani*0075          WRITE(msgBuf,'(2A,I4)') 'SHELFICE_READ_PICKUP: ',
                0076      &    'pickup-file binary precision do not match !'
                0077          CALL PRINT_ERROR( msgBuf, myThid )
                0078          WRITE(msgBuf,'(A,2(A,I4))') 'SHELFICE_READ_PICKUP: ',
                0079      &    'file prec.=', filePrec, ' but expecting prec.=', fp
                0080          CALL PRINT_ERROR( msgBuf, myThid )
                0081          CALL ALL_PROC_DIE( 0 )
                0082          STOP 'ABNORMAL END: S/R SHELFICE_READ_PICKUP (data-prec Pb)'
9952f046d7 dngo*0083       ENDIF
                0084       _END_MASTER( myThid )
198f6904ea Dani*0085
9952f046d7 dngo*0086       IF ( nbFields.LE.0 ) THEN
198f6904ea Dani*0087 C-      No meta-file or old meta-file without List of Fields
                0088         ioUnit = errorMessageUnit
                0089         IF ( pickupStrictlyMatch ) THEN
                0090           WRITE(msgBuf,'(4A)') 'SHELFICE_READ_PICKUP: ',
                0091      &      'no field-list found in meta-file',
                0092      &      ' => cannot check for strick-matching'
                0093           CALL PRINT_ERROR( msgBuf, myThid )
                0094           WRITE(msgBuf,'(4A)') 'SHELFICE_READ_PICKUP: ',
                0095      &      'try with " pickupStrictlyMatch=.FALSE.,"',
                0096      &      ' in file: "data", NameList: "PARM03"'
                0097           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0098           CALL ALL_PROC_DIE( myThid )
                0099           STOP 'ABNORMAL END: S/R SHELFICE_READ_PICKUP'
                0100         ELSE
                0101           WRITE(msgBuf,'(4A)') 'WARNING >> SHELFICE_READ_PICKUP: ',
                0102      &      ' no field-list found'
                0103           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0104          IF ( nbFields.EQ.-1 ) THEN
                0105 C-      No meta-file
                0106           WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0107      &      ' try to read pickup as currently written'
                0108           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0109          ELSE
                0110 C-      Old meta-file without List of Fields
                0111 c         WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0112 c    &      ' try to read pickup as it used to be written'
                0113 c         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0114 c         WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0115 c    &      ' until checkpoint59l (2007 Dec 17)'
                0116 c         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0117           WRITE(msgBuf,'(4A)') 'SHELFICE_READ_PICKUP: ',
                0118      &      'no field-list found in meta-file'
                0119           CALL PRINT_ERROR( msgBuf, myThid )
                0120           CALL ALL_PROC_DIE( myThid )
                0121           STOP 'ABNORMAL END: S/R SHELFICE_READ_PICKUP'
                0122          ENDIF
                0123         ENDIF
9952f046d7 dngo*0124       ENDIF
198f6904ea Dani*0125
                0126 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0127
9952f046d7 dngo*0128       IF ( nbFields.EQ.0 ) THEN
                0129 C---  Old way to read pickup:
198f6904ea Dani*0130
9952f046d7 dngo*0131       ELSE
                0132 C---  New way to read SHELFICE pickup:
198f6904ea Dani*0133         nj = 0
9952f046d7 dngo*0134 C-    read SHELFICE 3-D fields for restart
198f6904ea Dani*0135         nj = nj*Nr
9952f046d7 dngo*0136 C-    read SHELFICE 2-D fields for restart
198f6904ea Dani*0137
9952f046d7 dngo*0138         IF ( seqFlag.EQ.1 .AND. SHELFICEMassStepping ) THEN
                0139           CALL READ_MFLDS_3D_RL( 'SHI_mass', shelficeMass,
af20bc5e19 Jean*0140      &                                 nj, fp, 1 , nIter0, myThid )
9952f046d7 dngo*0141         ENDIF
                0142
                0143 #ifdef ALLOW_SHELFICE_REMESHING
                0144         IF ( seqFlag.EQ.0 .AND. SHELFICEremeshFrequency.GT.zeroRL ) THEN
3b86795949 Jean*0145           CALL READ_MFLDS_LEV_RS( 'R_Shelfi', R_shelfIce,
c4cdaac583 Jean*0146      &                            nj, fp, 1, 1, 1, nIter0, myThid )
9952f046d7 dngo*0147         ENDIF
                0148 #endif /* ALLOW_SHELFICE_REMESHING */
198f6904ea Dani*0149
9952f046d7 dngo*0150 C--   end: new way to read pickup file
                0151       ENDIF
198f6904ea Dani*0152
9952f046d7 dngo*0153 C--   Check for missing fields:
                0154       nMissing = missFldDim
                0155       CALL READ_MFLDS_CHECK(
198f6904ea Dani*0156      O                     missFldList,
                0157      U                     nMissing,
af20bc5e19 Jean*0158      I                     nIter0, myThid )
9952f046d7 dngo*0159       IF ( nMissing.GT.missFldDim ) THEN
198f6904ea Dani*0160          WRITE(msgBuf,'(2A,I4)') 'SHELFICE_READ_PICKUP: ',
                0161      &     'missing fields list has been truncated to', missFldDim
                0162          CALL PRINT_ERROR( msgBuf, myThid )
                0163          CALL ALL_PROC_DIE( myThid )
                0164          STOP 'ABNORMAL END: S/R SHELFICE_READ_PICKUP (list-size Pb)'
9952f046d7 dngo*0165       ENDIF
                0166       IF ( nMissing.GE.1 ) THEN
198f6904ea Dani*0167         ioUnit = errorMessageUnit
                0168         DO j=1,nMissing
                0169          WRITE(msgBuf,'(4A)') 'SHELFICE_READ_PICKUP: ',
                0170      &       'cannot restart without field "',missFldList(nj),'"'
                0171          CALL PRINT_ERROR( msgBuf, myThid )
                0172         ENDDO
                0173         CALL ALL_PROC_DIE( myThid )
                0174         STOP 'ABNORMAL END: S/R SHELFICE_READ_PICKUP'
9952f046d7 dngo*0175       ENDIF
                0176
                0177 C--   Update overlap regions:
                0178       IF ( seqFlag.EQ.1 .AND. SHELFICEMassStepping ) THEN
                0179         CALL EXCH_XY_RL( shelficeMass, myThid )
                0180       ENDIF
                0181 #ifdef ALLOW_SHELFICE_REMESHING
                0182       IF ( seqFlag.EQ.0 .AND. SHELFICEremeshFrequency.GT.zeroRL ) THEN
3b86795949 Jean*0183         CALL EXCH_XY_RS( R_shelfIce, myThid )
9952f046d7 dngo*0184       ENDIF
                0185 #endif
198f6904ea Dani*0186
                0187 #endif /* ALLOW_SHELFICE */
                0188
                0189       RETURN
                0190       END