Back to home page

MITgcm
 
 

    

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

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
53b68b7823 Dimi*0001 #include "BBL_OPTIONS.h"
                0002 
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP
                0005 C     !ROUTINE: BBL_READ_PICKUP
                0006 
                0007 C     !INTERFACE:
                0008       SUBROUTINE BBL_READ_PICKUP( myIter, myThid )
                0009 
                0010 C     !DESCRIPTION:
                0011 C     Reads current state of BBL 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 "BBL.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_BBL
                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
                0040       INTEGER fp
                0041       INTEGER filePrec, nbFields
                0042       INTEGER missFldDim, nMissing
                0043       INTEGER j, nj, ioUnit
                0044       PARAMETER( missFldDim = 3 )
df5a9764ba Jean*0045       CHARACTER*(10) suff
53b68b7823 Dimi*0046       CHARACTER*(MAX_LEN_FNAM) fn
                0047       CHARACTER*(8) missFldList(missFldDim)
                0048       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0049 CEOP
                0050 
                0051 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0052 
                0053        IF ( pickupSuff.EQ.' ' ) THEN
df5a9764ba Jean*0054         IF ( rwSuffixType.EQ.0 ) THEN
                0055           WRITE(fn,'(A,I10.10)') 'pickup_bbl.', myIter
                0056         ELSE
                0057           CALL RW_GET_SUFFIX( suff, startTime, myIter, myThid )
                0058           WRITE(fn,'(A,A)') 'pickup_bbl.', suff
                0059         ENDIF
53b68b7823 Dimi*0060        ELSE
df5a9764ba Jean*0061         WRITE(fn,'(A,A10)') 'pickup_bbl.', pickupSuff
53b68b7823 Dimi*0062        ENDIF
                0063        fp = precFloat64
                0064 
                0065        CALL READ_MFLDS_SET(
                0066      I                      fn,
                0067      O                      nbFields, filePrec,
                0068      I                      Nr, myIter, myThid )
                0069        _BEGIN_MASTER( myThid )
                0070 c      IF ( filePrec.NE.0 .AND. filePrec.NE.fp ) THEN
                0071        IF ( nbFields.GE.0 .AND. filePrec.NE.fp ) THEN
                0072          WRITE(msgBuf,'(2A,I4)') 'BBL_READ_PICKUP: ',
                0073      &    'pickup-file binary precision do not match !'
                0074          CALL PRINT_ERROR( msgBuf, myThid )
                0075          WRITE(msgBuf,'(A,2(A,I4))') 'BBL_READ_PICKUP: ',
                0076      &    'file prec.=', filePrec, ' but expecting prec.=', fp
                0077          CALL PRINT_ERROR( msgBuf, myThid )
                0078          STOP 'ABNORMAL END: S/R BBL_READ_PICKUP (data-prec Pb)'
                0079        ENDIF
                0080        _END_MASTER( myThid )
                0081 
                0082        IF ( nbFields.LE.0 ) THEN
                0083 C-      No meta-file or old meta-file without List of Fields
                0084         ioUnit = errorMessageUnit
                0085         IF ( pickupStrictlyMatch ) THEN
                0086           WRITE(msgBuf,'(4A)') 'BBL_READ_PICKUP: ',
                0087      &      'no field-list found in meta-file',
                0088      &      ' => cannot check for strick-matching'
                0089           CALL PRINT_ERROR( msgBuf, myThid )
                0090           WRITE(msgBuf,'(4A)') 'BBL_READ_PICKUP: ',
                0091      &      'try with " pickupStrictlyMatch=.FALSE.,"',
                0092      &      ' in file: "data", NameList: "PARM03"'
                0093           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0094           STOP 'ABNORMAL END: S/R BBL_READ_PICKUP'
                0095         ELSE
                0096           WRITE(msgBuf,'(4A)') 'WARNING >> BBL_READ_PICKUP: ',
                0097      &      ' no field-list found'
                0098           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0099          IF ( nbFields.EQ.-1 ) THEN
                0100 C-      No meta-file
                0101           WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0102      &      ' try to read pickup as currently written'
                0103           CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0104          ELSE
                0105           WRITE(msgBuf,'(4A)') 'BBL_READ_PICKUP: ',
                0106      &      'no field-list found in meta-file'
                0107           CALL PRINT_ERROR( msgBuf, myThid )
                0108           STOP 'ABNORMAL END: S/R BBL_READ_PICKUP'
                0109          ENDIF
                0110         ENDIF
                0111        ENDIF
                0112 
                0113 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0114 
                0115        IF ( nbFields.EQ.0 ) THEN
                0116 C---   Old way to read pickup:
                0117 
                0118        ELSE
                0119 C---   New way to read BBL pickup:
                0120         nj = 0
                0121 C---    read BBL 2-D fields for restart
                0122         CALL READ_MFLDS_3D_RL( 'bblTheta', bbl_theta,
                0123      &                                 nj, fp, 1 , myIter, myThid )
                0124         CALL READ_MFLDS_3D_RL( 'bblSalt ', bbl_salt,
                0125      &                                 nj, fp, 1 , myIter, myThid )
                0126         CALL READ_MFLDS_3D_RL( 'bblEta  ', bbl_eta,
                0127      &                                 nj, fp, 1 , myIter, myThid )
                0128 
                0129 C--    end: new way to read pickup file
                0130        ENDIF
                0131 
                0132 C--    Check for missing fields:
                0133        nMissing = missFldDim
                0134        CALL READ_MFLDS_CHECK(
                0135      O                     missFldList,
                0136      U                     nMissing,
                0137      I                     myIter, myThid )
                0138        IF ( nMissing.GT.missFldDim ) THEN
                0139          WRITE(msgBuf,'(2A,I4)') 'BBL_READ_PICKUP: ',
                0140      &     'missing fields list has been truncated to', missFldDim
                0141          CALL PRINT_ERROR( msgBuf, myThid )
                0142          STOP 'ABNORMAL END: S/R BBL_READ_PICKUP (list-size Pb)'
                0143        ENDIF
                0144        IF ( nMissing.GE.1 ) THEN
                0145         ioUnit = errorMessageUnit
                0146         DO j=1,nMissing
                0147          WRITE(msgBuf,'(4A)') 'BBL_READ_PICKUP: ',
                0148      &       'cannot restart without field "',missFldList(nj),'"'
                0149          CALL PRINT_ERROR( msgBuf, myThid )
                0150         ENDDO
                0151         STOP 'ABNORMAL END: S/R BBL_READ_PICKUP'
                0152        ENDIF
                0153 
                0154 C--    Update overlap regions:
                0155         CALL EXCH_XY_RL( bbl_theta, myThid )
                0156         CALL EXCH_XY_RL( bbl_salt, myThid )
                0157         CALL EXCH_XY_RL( bbl_eta, myThid )
                0158 
                0159 #endif /* ALLOW_BBL */
                0160 
                0161       RETURN
                0162       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!