Back to home page

MITgcm
 
 

    

File indexing completed on 2018-03-02 18:38:24 UTC

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
629a141662 Nico*0001 #include "CHEAPAML_OPTIONS.h"
                0002 
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP
                0005 C     !ROUTINE: CHEAPAML_READ_PICKUP
                0006 
                0007 C     !INTERFACE:
                0008       SUBROUTINE CHEAPAML_READ_PICKUP( myIter, myThid )
                0009 
                0010 C     !DESCRIPTION:
                0011 C     Reads current state of CHEAPAML 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 "CHEAPAML.h"
                0019 
                0020 C     !INPUT PARAMETERS:
                0021 C     myIter            :: time-step number
                0022 C     myThid            :: thread number
                0023       INTEGER myIter
                0024       INTEGER myThid
                0025 
                0026 #ifdef ALLOW_CHEAPAML
                0027 
                0028 C     !LOCAL VARIABLES:
                0029 C     fn          :: character buffer for creating filename
                0030 C     fp          :: precision of pickup files
                0031 C     filePrec    :: pickup-file precision (read from meta file)
                0032 C     nbFields    :: number of fields in pickup file (read from meta file)
                0033 C     missFldList :: List of missing fields   (attempted to read but not found)
                0034 C     missFldDim  :: Dimension of missing fields list array: missFldList
                0035 C     nMissing    :: Number of missing fields (attempted to read but not found)
                0036 C     j           :: loop index
                0037 C     nj          :: record number
                0038 C     ioUnit      :: temp for writing msg unit
                0039 C     msgBuf      :: Informational/error message buffer
58fa289e25 Jean*0040       LOGICAL stopFlag
629a141662 Nico*0041       INTEGER fp
                0042       INTEGER filePrec, nbFields
58fa289e25 Jean*0043       INTEGER missFldDim, nMissing, warnCnts
629a141662 Nico*0044       INTEGER j, nj, ioUnit
                0045       PARAMETER( missFldDim = 12 )
df5a9764ba Jean*0046       CHARACTER*(10) suff
629a141662 Nico*0047       CHARACTER*(MAX_LEN_FNAM) fn
                0048       CHARACTER*(8) missFldList(missFldDim)
                0049       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0050 CEOP
                0051 
                0052       _BARRIER
                0053 
                0054 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0055 
                0056        IF ( pickupSuff.EQ.' ' ) THEN
df5a9764ba Jean*0057         IF ( rwSuffixType.EQ.0 ) THEN
                0058           WRITE(fn,'(A,I10.10)') 'pickup_cheapaml.', myIter
                0059         ELSE
                0060           CALL RW_GET_SUFFIX( suff, startTime, myIter, myThid )
                0061           WRITE(fn,'(A,A)') 'pickup_cheapaml.', myIter
                0062         ENDIF
629a141662 Nico*0063        ELSE
df5a9764ba Jean*0064         WRITE(fn,'(A,A10)') 'pickup_cheapaml.', pickupSuff
629a141662 Nico*0065        ENDIF
                0066        fp = precFloat64
                0067 
                0068        CALL READ_MFLDS_SET(
                0069      I                      fn,
                0070      O                      nbFields, filePrec,
                0071      I                      Nr, myIter, myThid )
                0072        _BEGIN_MASTER( myThid )
                0073 c      IF ( filePrec.NE.0 .AND. filePrec.NE.fp ) THEN
                0074        IF ( nbFields.GE.0 .AND. filePrec.NE.fp ) THEN
                0075          WRITE(msgBuf,'(2A,I4)') 'CHEAPAML_READ_PICKUP: ',
                0076      &    'pickup-file binary precision do not match !'
                0077          CALL PRINT_ERROR( msgBuf, myThid )
                0078          WRITE(msgBuf,'(A,2(A,I4))') 'CHEAPAML_READ_PICKUP: ',
                0079      &    'file prec.=', filePrec, ' but expecting prec.=', fp
                0080          CALL PRINT_ERROR( msgBuf, myThid )
                0081          STOP 'ABNORMAL END: S/R CHEAPAML_READ_PICKUP (data-prec Pb)'
                0082        ENDIF
                0083        _END_MASTER( myThid )
                0084 
                0085        IF ( nbFields.LE.0 ) THEN
                0086 C-      No meta-file or old meta-file without List of Fields
                0087         ioUnit = errorMessageUnit
                0088         IF ( pickupStrictlyMatch ) THEN
                0089           WRITE(msgBuf,'(4A)') 'CHEAPAML_READ_PICKUP: ',
                0090      &      'no field-list found in meta-file',
                0091      &      ' => cannot check for strick-matching'
                0092           CALL PRINT_ERROR( msgBuf, myThid )
                0093           WRITE(msgBuf,'(4A)') 'CHEAPAML_READ_PICKUP: ',
                0094      &      'try with " pickupStrictlyMatch=.FALSE.,"',
                0095      &      ' in file: "data", NameList: "PARM03"'
                0096           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0097           STOP 'ABNORMAL END: S/R CHEAPAML_READ_PICKUP'
                0098         ELSE
                0099           WRITE(msgBuf,'(4A)') 'WARNING >> CHEAPAML_READ_PICKUP: ',
                0100      &      ' no field-list found'
                0101           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0102          IF ( nbFields.EQ.-1 ) THEN
                0103 C-      No meta-file
                0104           WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0105      &      ' try to read pickup as currently written'
                0106           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0107          ELSE
                0108 C-      Old meta-file without List of Fields
                0109 c         WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0110 c    &      ' try to read pickup as it used to be written'
                0111 c         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0112 c         WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0113 c    &      ' until checkpoint59l (2007 Dec 17)'
                0114 c         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0115           WRITE(msgBuf,'(4A)') 'CHEAPAML_READ_PICKUP: ',
                0116      &      'no field-list found in meta-file'
                0117           CALL PRINT_ERROR( msgBuf, myThid )
                0118           STOP 'ABNORMAL END: S/R CHEAPAML_READ_PICKUP'
                0119          ENDIF
                0120         ENDIF
                0121        ENDIF
                0122 
                0123 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0124 
                0125        IF ( nbFields.EQ.0 ) THEN
                0126 C---   Old way to read pickup:
                0127        ELSE
                0128 C---   New way to read CHEAPAML pickup:
                0129         nj = 0
                0130         nj = nj*Nr
                0131 C---    read CHEAPAML 2-D fields for restart
83d1639494 Nico*0132         CALL READ_MFLDS_3D_RL( 'Tair    ', Tair,
629a141662 Nico*0133      &                                 nj, fp, 1 , myIter, myThid )
58fa289e25 Jean*0134         CALL READ_MFLDS_3D_RL( 'gTairNm1', gTairm,
                0135      &                                 nj, fp, 1 , myIter, myThid )
                0136 
51132e5783 Nico*0137         IF(useFreshWaterFlux)THEN
83d1639494 Nico*0138         CALL READ_MFLDS_3D_RL( 'Qair    ', qair,
58fa289e25 Jean*0139      &                                 nj, fp, 1 , myIter, myThid )
                0140         CALL READ_MFLDS_3D_RL( 'gQairNm1', gqairm,
                0141      &                                 nj, fp, 1 , myIter, myThid )
51132e5783 Nico*0142         ENDIF
                0143         IF(useCheaptracer)THEN
83d1639494 Nico*0144         CALL READ_MFLDS_3D_RL( 'cTracer ', Cheaptracer,
58fa289e25 Jean*0145      &                                 nj, fp, 1 ,myIter, myThid )
                0146         CALL READ_MFLDS_3D_RL( 'gTracNm1', Cheaptracer,
                0147      &                                 nj, fp, 1 ,myIter, myThid )
51132e5783 Nico*0148         ENDIF
629a141662 Nico*0149 
                0150 C--    end: new way to read pickup file
                0151        ENDIF
                0152 
                0153 C--    Check for missing fields:
                0154        nMissing = missFldDim
                0155        CALL READ_MFLDS_CHECK(
                0156      O                     missFldList,
                0157      U                     nMissing,
                0158      I                     myIter, myThid )
                0159        IF ( nMissing.GT.missFldDim ) THEN
                0160          WRITE(msgBuf,'(2A,I4)') 'CHEAPAML_READ_PICKUP: ',
                0161      &     'missing fields list has been truncated to', missFldDim
                0162          CALL PRINT_ERROR( msgBuf, myThid )
                0163          STOP 'ABNORMAL END: S/R CHEAPAML_READ_PICKUP (list-size Pb)'
                0164        ENDIF
                0165        IF ( nMissing.GE.1 ) THEN
58fa289e25 Jean*0166         _BEGIN_MASTER( myThid )
629a141662 Nico*0167         ioUnit = errorMessageUnit
58fa289e25 Jean*0168         stopFlag = .FALSE.
                0169         warnCnts = nMissing
629a141662 Nico*0170         DO j=1,nMissing
58fa289e25 Jean*0171          IF     ( missFldList(j).EQ.'gTairNm1' ) THEN
                0172            cheapTairStartAB = 0
                0173          ELSEIF ( missFldList(j).EQ.'gQairNm1' ) THEN
                0174            cheapQairStartAB = 0
                0175          ELSEIF ( missFldList(j).EQ.'gTracNm1' ) THEN
                0176            cheapTracStartAB = 0
                0177          ELSE
                0178           stopFlag = .TRUE.
                0179           WRITE(msgBuf,'(4A)') 'CHEAPAML_READ_PICKUP: ',
629a141662 Nico*0180      &       'cannot restart without field "',missFldList(nj),'"'
58fa289e25 Jean*0181           CALL PRINT_ERROR( msgBuf, myThid )
                0182          ENDIF
629a141662 Nico*0183         ENDDO
58fa289e25 Jean*0184         IF ( stopFlag ) THEN
                0185          STOP 'ABNORMAL END: S/R CHEAPAML_READ_PICKUP'
                0186         ELSEIF ( pickupStrictlyMatch ) THEN
                0187          WRITE(msgBuf,'(4A)') 'CHEAPAML_READ_PICKUP: ',
                0188      &      'try with " pickupStrictlyMatch=.FALSE.,"',
                0189      &      ' in file: "data", NameList: "PARM03"'
                0190          CALL PRINT_ERROR( msgBuf, myThid )
                0191          STOP 'ABNORMAL END: S/R CHEAPAML_READ_PICKUP'
                0192         ELSEIF ( warnCnts .GT. 0 ) THEN
                0193          WRITE(msgBuf,'(4A)') '** WARNING ** CHEAPAML_READ_PICKUP: ',
                0194      &     'Will get only an approximated Restart'
                0195          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0196         ENDIF
                0197         _END_MASTER( myThid )
629a141662 Nico*0198        ENDIF
                0199 
83d1639494 Nico*0200 C--    Update overlap regions:
58fa289e25 Jean*0201        CALL EXCH_XY_RL( Tair, myThid )
                0202        CALL EXCH_XY_RL( qair, myThid )
                0203        CALL EXCH_XY_RL( Cheaptracer, myThid )
83d1639494 Nico*0204 
629a141662 Nico*0205 #endif /* ALLOW_CHEAPAML */
                0206 
                0207       RETURN
                0208       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!