Back to home page

MITgcm
 
 

    

File indexing completed on 2022-03-25 05:10:02 UTC

view on githubraw file Latest commit 64811cb0 on 2022-03-25 02:40:24 UTC
5b141690f8 Jean*0001 #include "MYPACKAGE_OPTIONS.h"
                0002 
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP
                0005 C     !ROUTINE: MYPACKAGE_READ_PICKUP
                0006 
                0007 C     !INTERFACE:
                0008       SUBROUTINE MYPACKAGE_READ_PICKUP( myIter, myThid )
                0009 
                0010 C     !DESCRIPTION:
                0011 C     Reads current state of MYPACKAGE from a pickup file
                0012 
                0013 C     !USES:
                0014       IMPLICIT NONE
64811cb024 Jean*0015 C     == Global variables ===
5b141690f8 Jean*0016 #include "SIZE.h"
                0017 #include "EEPARAMS.h"
                0018 #include "PARAMS.h"
                0019 #include "MYPACKAGE.h"
                0020 
                0021 C     !INPUT PARAMETERS:
                0022 C     myIter            :: time-step number
                0023 C     myThid            :: thread number
                0024       INTEGER myIter
                0025       INTEGER myThid
                0026 
68a8df71d9 Jean*0027 #if (defined MYPACKAGE_3D_STATE) || (defined MYPACKAGE_2D_STATE)
5b141690f8 Jean*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 )
df5a9764ba Jean*0046       CHARACTER*(10) suff
5b141690f8 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 
                0054        IF ( pickupSuff.EQ.' ' ) THEN
df5a9764ba Jean*0055         IF ( rwSuffixType.EQ.0 ) THEN
                0056           WRITE(fn,'(A,I10.10)') 'pickup_mypackage.', myIter
                0057         ELSE
                0058           CALL RW_GET_SUFFIX( suff, startTime, myIter, myThid )
                0059           WRITE(fn,'(A,A)') 'pickup_mypackage.', suff
                0060         ENDIF
5b141690f8 Jean*0061        ELSE
df5a9764ba Jean*0062         WRITE(fn,'(A,A10)') 'pickup_mypackage.', pickupSuff
5b141690f8 Jean*0063        ENDIF
                0064        fp = precFloat64
                0065 
                0066        CALL READ_MFLDS_SET(
                0067      I                      fn,
                0068      O                      nbFields, filePrec,
                0069      I                      Nr, myIter, myThid )
                0070        _BEGIN_MASTER( myThid )
                0071 c      IF ( filePrec.NE.0 .AND. filePrec.NE.fp ) THEN
                0072        IF ( nbFields.GE.0 .AND. filePrec.NE.fp ) THEN
                0073          WRITE(msgBuf,'(2A,I4)') 'MYPACKAGE_READ_PICKUP: ',
                0074      &    'pickup-file binary precision do not match !'
                0075          CALL PRINT_ERROR( msgBuf, myThid )
                0076          WRITE(msgBuf,'(A,2(A,I4))') 'MYPACKAGE_READ_PICKUP: ',
                0077      &    'file prec.=', filePrec, ' but expecting prec.=', fp
                0078          CALL PRINT_ERROR( msgBuf, myThid )
7610a0b85a Jean*0079          CALL ALL_PROC_DIE( 0 )
5b141690f8 Jean*0080          STOP 'ABNORMAL END: S/R MYPACKAGE_READ_PICKUP (data-prec Pb)'
                0081        ENDIF
                0082        _END_MASTER( myThid )
                0083 
                0084        IF ( nbFields.LE.0 ) THEN
                0085 C-      No meta-file or old meta-file without List of Fields
                0086         ioUnit = errorMessageUnit
                0087         IF ( pickupStrictlyMatch ) THEN
                0088           WRITE(msgBuf,'(4A)') 'MYPACKAGE_READ_PICKUP: ',
                0089      &      'no field-list found in meta-file',
                0090      &      ' => cannot check for strick-matching'
                0091           CALL PRINT_ERROR( msgBuf, myThid )
                0092           WRITE(msgBuf,'(4A)') 'MYPACKAGE_READ_PICKUP: ',
                0093      &      'try with " pickupStrictlyMatch=.FALSE.,"',
                0094      &      ' in file: "data", NameList: "PARM03"'
                0095           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
7610a0b85a Jean*0096           CALL ALL_PROC_DIE( myThid )
5b141690f8 Jean*0097           STOP 'ABNORMAL END: S/R MYPACKAGE_READ_PICKUP'
                0098         ELSE
                0099           WRITE(msgBuf,'(4A)') 'WARNING >> MYPACKAGE_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)') 'MYPACKAGE_READ_PICKUP: ',
                0116      &      'no field-list found in meta-file'
                0117           CALL PRINT_ERROR( msgBuf, myThid )
7610a0b85a Jean*0118           CALL ALL_PROC_DIE( myThid )
5b141690f8 Jean*0119           STOP 'ABNORMAL END: S/R MYPACKAGE_READ_PICKUP'
                0120          ENDIF
                0121         ENDIF
                0122        ENDIF
                0123 
                0124 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0125 
                0126        IF ( nbFields.EQ.0 ) THEN
                0127 C---   Old way to read pickup:
                0128 
                0129        ELSE
                0130 C---   New way to read MYPACKAGE pickup:
                0131         nj = 0
                0132 C---    read MYPACKAGE 3-D fields for restart
                0133 #ifdef MYPACKAGE_3D_STATE
                0134         CALL READ_MFLDS_3D_RL( 'myPaSta1', myPa_StatScal1,
                0135      &                                 nj, fp, Nr, myIter, myThid )
                0136         CALL READ_MFLDS_3D_RL( 'myPaSta2', myPa_StatScal2,
                0137      &                                 nj, fp, Nr, myIter, myThid )
                0138         CALL READ_MFLDS_3D_RL( 'myPaStaU', myPa_StatVelU,
                0139      &                                 nj, fp, Nr, myIter, myThid )
                0140         CALL READ_MFLDS_3D_RL( 'myPaStaV', myPa_StatVelV,
                0141      &                                 nj, fp, Nr, myIter, myThid )
                0142 #endif /* MYPACKAGE_3D_STATE */
                0143         nj = nj*Nr
                0144 C---    read MYPACKAGE 2-D fields for restart
                0145 #ifdef MYPACKAGE_2D_STATE
                0146         CALL READ_MFLDS_3D_RL( 'myPaSur1', myPa_Surf1,
                0147      &                                 nj, fp, 1 , myIter, myThid )
0cc13345f6 Jean*0148         CALL READ_MFLDS_3D_RL( 'myPaSur2', myPa_Surf2,
5b141690f8 Jean*0149      &                                 nj, fp, 1 , myIter, myThid )
                0150 #endif /* MYPACKAGE_2D_STATE */
                0151 
                0152 C--    end: new way to read pickup file
                0153        ENDIF
                0154 
                0155 C--    Check for missing fields:
                0156        nMissing = missFldDim
                0157        CALL READ_MFLDS_CHECK(
                0158      O                     missFldList,
                0159      U                     nMissing,
                0160      I                     myIter, myThid )
                0161        IF ( nMissing.GT.missFldDim ) THEN
                0162          WRITE(msgBuf,'(2A,I4)') 'MYPACKAGE_READ_PICKUP: ',
                0163      &     'missing fields list has been truncated to', missFldDim
                0164          CALL PRINT_ERROR( msgBuf, myThid )
7610a0b85a Jean*0165          CALL ALL_PROC_DIE( myThid )
5b141690f8 Jean*0166          STOP 'ABNORMAL END: S/R MYPACKAGE_READ_PICKUP (list-size Pb)'
                0167        ENDIF
                0168        IF ( nMissing.GE.1 ) THEN
                0169         ioUnit = errorMessageUnit
                0170         DO j=1,nMissing
                0171          WRITE(msgBuf,'(4A)') 'MYPACKAGE_READ_PICKUP: ',
                0172      &       'cannot restart without field "',missFldList(nj),'"'
                0173          CALL PRINT_ERROR( msgBuf, myThid )
                0174         ENDDO
7610a0b85a Jean*0175         CALL ALL_PROC_DIE( myThid )
5b141690f8 Jean*0176         STOP 'ABNORMAL END: S/R MYPACKAGE_READ_PICKUP'
                0177        ENDIF
                0178 
                0179 C--    Update overlap regions:
                0180 #ifdef MYPACKAGE_3D_STATE
                0181         CALL EXCH_3D_RL( myPa_StatScal1, Nr, myThid )
                0182         CALL EXCH_3D_RL( myPa_StatScal2, Nr, myThid )
                0183         IF ( myPa_StaV_Cgrid ) THEN
                0184          CALL EXCH_UV_3D_RL( myPa_StatVelU, myPa_StatVelV,
                0185      &                       .TRUE., Nr, myThid )
                0186         ELSE
                0187 C-      Assume Agrid position:
                0188          CALL EXCH_UV_AGRID_3D_RL( myPa_StatVelU, myPa_StatVelV,
                0189      &                       .TRUE., Nr, myThid )
                0190         ENDIF
                0191 #endif /* MYPACKAGE_3D_STATE */
                0192 #ifdef MYPACKAGE_2D_STATE
                0193         CALL EXCH_XY_RL( myPa_Surf1, myThid )
                0194         CALL EXCH_XY_RL( myPa_Surf2, myThid )
                0195 #endif /* MYPACKAGE_2D_STATE */
                0196 
68a8df71d9 Jean*0197 #endif /* MYPACKAGE_3D_STATE or MYPACKAGE_2D_STATE */
5b141690f8 Jean*0198 
                0199       RETURN
                0200       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!