pkg/gmredi/gmredi_read_pickup.F

5a6ef5c2b4 Mich*0001 #include "GMREDI_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 GMREDI_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
                0015 #include "SIZE.h"
                0016 #include "EEPARAMS.h"
                0017 #include "PARAMS.h"
                0018 #include "GMREDI.h"
                0019
                0020 C     !INPUT PARAMETERS:
                0021 C     myIter            :: time-step number
                0022 C     myThid            :: thread number
                0023       INTEGER myIter
                0024       INTEGER myThid
                0025
a4576c7cde Juli*0026 #if ( defined GM_BATES_K3D || defined GM_GEOM_VARIABLE_K )
                0027 C     !FUNCTIONS:
                0028       INTEGER  ILNBLNK
                0029       EXTERNAL ILNBLNK
5a6ef5c2b4 Mich*0030
                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
a4576c7cde Juli*0046       INTEGER j, nj, ioUnit, iL
                0047 #ifdef GM_BATES_K3D
                0048       INTEGER i, k, n, bi, bj
                0049       _RL vec(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0050 # ifdef GM_GEOM_VARIABLE_K
                0051       PARAMETER( missFldDim = 5+2*GM_Bates_NModes )
                0052 # else
                0053       PARAMETER( missFldDim = 2+2*GM_Bates_NModes )
                0054 # endif
                0055 #else /* GM_BATES_K3D */
                0056       PARAMETER( missFldDim = 3 )
                0057 #endif /* GM_BATES_K3D */
df5a9764ba Jean*0058       CHARACTER*(10) suff
a4576c7cde Juli*0059       CHARACTER*(MAX_LEN_FNAM) fn, tmpNam
5a6ef5c2b4 Mich*0060       CHARACTER*(8) missFldList(missFldDim)
                0061       CHARACTER*(8) fieldname
a4576c7cde Juli*0062       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0063       LOGICAL useCurrentDir, fileExist, StopFlag
5a6ef5c2b4 Mich*0064 CEOP
                0065
a4576c7cde Juli*0066       IF ( GM_useBatesK3d .OR. GM_useGEOM ) THEN
                0067        ioUnit = errorMessageUnit
                0068
5a6ef5c2b4 Mich*0069 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0070
                0071        IF ( pickupSuff.EQ.' ' ) THEN
df5a9764ba Jean*0072         IF ( rwSuffixType.EQ.0 ) THEN
                0073           WRITE(fn,'(A,I10.10)') 'pickup_gmredi.', myIter
                0074         ELSE
                0075           CALL RW_GET_SUFFIX( suff, startTime, myIter, myThid )
                0076           WRITE(fn,'(A,A)') 'pickup_gmredi.', suff
                0077         ENDIF
5a6ef5c2b4 Mich*0078        ELSE
df5a9764ba Jean*0079         WRITE(fn,'(A,A10)') 'pickup_gmredi.', pickupSuff
5a6ef5c2b4 Mich*0080        ENDIF
                0081        fp = precFloat64
                0082
                0083        CALL READ_MFLDS_SET(
                0084      I                      fn,
                0085      O                      nbFields, filePrec,
                0086      I                      Nr, myIter, myThid )
                0087        _BEGIN_MASTER( myThid )
                0088 c      IF ( filePrec.NE.0 .AND. filePrec.NE.fp ) THEN
                0089        IF ( nbFields.GE.0 .AND. filePrec.NE.fp ) THEN
                0090          WRITE(msgBuf,'(2A,I4)') 'GMREDI_READ_PICKUP: ',
                0091      &    'pickup-file binary precision do not match !'
                0092          CALL PRINT_ERROR( msgBuf, myThid )
                0093          WRITE(msgBuf,'(A,2(A,I4))') 'GMREDI_READ_PICKUP: ',
                0094      &    'file prec.=', filePrec, ' but expecting prec.=', fp
                0095          CALL PRINT_ERROR( msgBuf, myThid )
                0096          CALL ALL_PROC_DIE( 0 )
                0097          STOP 'ABNORMAL END: S/R GMREDI_READ_PICKUP (data-prec Pb)'
                0098        ENDIF
                0099        _END_MASTER( myThid )
                0100
                0101        IF ( nbFields.LE.0 ) THEN
                0102 C-      No meta-file or old meta-file without List of Fields
                0103         IF ( pickupStrictlyMatch ) THEN
a4576c7cde Juli*0104          WRITE(msgBuf,'(4A)') 'GMREDI_READ_PICKUP: ',
5a6ef5c2b4 Mich*0105      &      'no field-list found in meta-file',
                0106      &      ' => cannot check for strick-matching'
a4576c7cde Juli*0107          CALL PRINT_ERROR( msgBuf, myThid )
                0108          WRITE(msgBuf,'(4A)') 'GMREDI_READ_PICKUP: ',
5a6ef5c2b4 Mich*0109      &      'try with " pickupStrictlyMatch=.FALSE.,"',
                0110      &      ' in file: "data", NameList: "PARM03"'
a4576c7cde Juli*0111          CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0112          CALL ALL_PROC_DIE( myThid )
                0113          STOP 'ABNORMAL END: S/R GMREDI_READ_PICKUP'
5a6ef5c2b4 Mich*0114         ELSE
                0115          IF ( nbFields.EQ.-1 ) THEN
a4576c7cde Juli*0116 C-      No meta-file: then check if binary pickup file (i.e., ".data") exist
                0117 #ifdef ALLOW_MDSIO
                0118           useCurrentDir = .FALSE.
                0119           CALL MDS_CHECK4FILE(
                0120      I                     fn, '.data', 'GMREDI_READ_PICKUP',
                0121      O                     tmpNam, fileExist,
                0122      I                     useCurrentDir, myThid )
                0123 #else
                0124           STOP 'ABNORMAL END: S/R DIC_READ_PICKUP: Needs MDSIO pkg'
                0125 #endif
                0126           IF ( fileExist ) THEN
                0127            WRITE(msgBuf,'(4A)') 'WARNING >> GMREDI_READ_PICKUP: ',
                0128      &      ' no field-list found'
                0129            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0130            WRITE(msgBuf,'(4A)') 'WARNING >> ',
5a6ef5c2b4 Mich*0131      &      ' try to read pickup as currently written'
a4576c7cde Juli*0132            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0133           ELSE
                0134            iL = ILNBLNK(fn)
                0135            WRITE(msgBuf,'(4A)') 'WARNING >> GMREDI_READ_PICKUP: ',
                0136      &      'missing both "meta" & "data" files for "', fn(1:iL), '"'
                0137            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0138            nbFields = -2
                0139 #ifdef GM_GEOM_VARIABLE_K
                0140            _BEGIN_MASTER( myThid )
                0141            IF ( GM_useGEOM ) THEN
                0142             GEOM_startAB = 0
                0143             WRITE(msgBuf,'(4A)') 'WARNING >> GMREDI_READ_PICKUP: ',
                0144      &      'restart with uniform GEOM_EKE = GEOM_ini_EKE'
                0145             CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0146            _END_MASTER( myThid )
                0147            ENDIF
                0148 #endif
                0149           ENDIF
5a6ef5c2b4 Mich*0150          ELSE
                0151 C-      Old meta-file without List of Fields
                0152 c         WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0153 c    &      ' try to read pickup as it used to be written'
                0154 c         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0155 c         WRITE(msgBuf,'(4A)') 'WARNING >> ',
                0156 c    &      ' until checkpoint59l (2007 Dec 17)'
                0157 c         CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0158           WRITE(msgBuf,'(4A)') 'GMREDI_READ_PICKUP: ',
                0159      &      'no field-list found in meta-file'
                0160           CALL PRINT_ERROR( msgBuf, myThid )
                0161           CALL ALL_PROC_DIE( myThid )
                0162           STOP 'ABNORMAL END: S/R GMREDI_READ_PICKUP'
                0163          ENDIF
                0164         ENDIF
                0165        ENDIF
                0166
                0167 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0168
                0169        IF ( nbFields.EQ.0 ) THEN
                0170 C---   Old way to read pickup:
                0171
a4576c7cde Juli*0172 c        WRITE(msgBuf,'(2A,I4)') 'GMREDI_READ_PICKUP: ',
                0173 c    &        'old way of reading pickups not implemented, continuing'
                0174 c        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
5a6ef5c2b4 Mich*0175
a4576c7cde Juli*0176        ELSEIF ( nbFields.NE.-2 ) THEN
5a6ef5c2b4 Mich*0177
a4576c7cde Juli*0178         nj = 0
                0179 C---   read GMREDI fields for restart
                0180
                0181 #ifdef GM_BATES_K3D
                0182         IF ( GM_useBatesK3d ) THEN
                0183
                0184 C        Center mode
                0185          fieldname = 'mode01C '
5a6ef5c2b4 Mich*0186          CALL READ_MFLDS_3D_RL( fieldname, vec,
a4576c7cde Juli*0187      &                          nj, fp, Nr, myIter, myThid )
                0188          CALL EXCH_3D_RL( vec, Nr, myThid )
5a6ef5c2b4 Mich*0189          DO bj=myByLo(myThid),myByHi(myThid)
                0190           DO bi=myBxLo(myThid),myBxHi(myThid)
                0191            DO k=1,Nr
df5a9764ba Jean*0192             DO j=1-OLy,sNy+OLy
                0193              DO i=1-OLx,sNx+OLx
a4576c7cde Juli*0194               modesC(1,i,j,k,bi,bj) = vec(i,j,k,bi,bj)
5a6ef5c2b4 Mich*0195              ENDDO
                0196             ENDDO
                0197            ENDDO
                0198           ENDDO
                0199          ENDDO
                0200
a4576c7cde Juli*0201 C      Western Mode
                0202          DO n=1,GM_Bates_NModes
                0203           WRITE(fieldname, '(A,I2.2,A)') 'mode',n,'W'
                0204           CALL READ_MFLDS_3D_RL( fieldname, vec,
                0205      &                           nj, fp, Nr, myIter, myThid )
                0206           CALL EXCH_3D_RL( vec, Nr, myThid )
                0207           DO bj=myByLo(myThid),myByHi(myThid)
                0208            DO bi=myBxLo(myThid),myBxHi(myThid)
                0209             DO k=1,Nr
                0210              DO j=1-OLy,sNy+OLy
                0211               DO i=1-OLx,sNx+OLx
                0212                modesW(n,i,j,k,bi,bj) = vec(i,j,k,bi,bj)
                0213               ENDDO
5a6ef5c2b4 Mich*0214              ENDDO
                0215             ENDDO
                0216            ENDDO
                0217           ENDDO
                0218          ENDDO
                0219
a4576c7cde Juli*0220 C      Southern Mode
                0221          DO n=1,GM_Bates_NModes
                0222           WRITE(fieldname, '(A,I2.2,A)') 'mode',n,'S'
                0223           CALL READ_MFLDS_3D_RL( fieldname, vec,
                0224      &                           nj, fp, Nr, myIter, myThid )
                0225           CALL EXCH_3D_RL( vec, Nr, myThid )
                0226           DO bj=myByLo(myThid),myByHi(myThid)
                0227            DO bi=myBxLo(myThid),myBxHi(myThid)
                0228             DO k=1,Nr
                0229              DO j=1-OLy,sNy+OLy
                0230               DO i=1-OLx,sNx+OLx
                0231                modesS(n,i,j,k,bi,bj) = vec(i,j,k,bi,bj)
                0232               ENDDO
                0233              ENDDO
                0234             ENDDO
                0235            ENDDO
                0236           ENDDO
                0237          ENDDO
5a6ef5c2b4 Mich*0238
a4576c7cde Juli*0239 C     Switch to - 2D fields :
                0240          nj = nj*Nr
5a6ef5c2b4 Mich*0241 C       Deformation radius
a4576c7cde Juli*0242          fieldname = 'Rdef    '
                0243          CALL READ_MFLDS_3D_RL( fieldname, Rdef,
                0244      &                          nj, fp, 1, myIter, myThid )
                0245          CALL EXCH_XY_RL( Rdef, myThid )
                0246
                0247 c     GM_useBates3D
                0248         ENDIF
                0249 #endif /* GM_BATES_K3D */
                0250
                0251 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0252
                0253 #ifdef GM_GEOM_VARIABLE_K
                0254         IF ( GM_useGEOM ) THEN
                0255
                0256 C     Continue with GEOMETRIC - 2D fields :
                0257 C        GEOMETRIC energy
                0258          fieldname = 'GEOM_EKE'
                0259          CALL READ_MFLDS_3D_RL( fieldname, GEOM_EKE,
                0260      &                          nj, fp, 1, myIter, myThid )
                0261          CALL EXCH_XY_RL( GEOM_EKE, myThid )
                0262
                0263          fieldname = 'GEKE_Nm1'
                0264          CALL READ_MFLDS_3D_RL( fieldname, GEOM_gEKE_Nm1,
                0265      &                          nj, fp, 1, myIter, myThid )
                0266          CALL EXCH_XY_RL( GEOM_gEKE_Nm1, myThid )
                0267
                0268         ENDIF
                0269 #endif /* GM_GEOM_VARIABLE_K */
5a6ef5c2b4 Mich*0270
                0271 C--   end: new way to read pickup file
a4576c7cde Juli*0272        ENDIF
5a6ef5c2b4 Mich*0273
a4576c7cde Juli*0274 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
5a6ef5c2b4 Mich*0275 C--    Check for missing fields:
a4576c7cde Juli*0276        nMissing = missFldDim
                0277        CALL READ_MFLDS_CHECK(
                0278      O       missFldList,
                0279      U       nMissing,
                0280      I       myIter, myThid )
                0281
                0282        _BEGIN_MASTER( myThid )
                0283        IF ( nMissing.GT.missFldDim ) THEN
5a6ef5c2b4 Mich*0284         WRITE(msgBuf,'(2A,I4)') 'GMREDI_READ_PICKUP: ',
                0285      &       'missing fields list has been truncated to', missFldDim
                0286         CALL PRINT_ERROR( msgBuf, myThid )
a4576c7cde Juli*0287         CALL ALL_PROC_DIE( 0 )
5a6ef5c2b4 Mich*0288         STOP 'ABNORMAL END: S/R GMREDI_READ_PICKUP (list-size Pb)'
a4576c7cde Juli*0289        ENDIF
                0290        IF ( nMissing.GE.1 ) THEN
                0291         stopFlag = .FALSE.
                0292         IF ( pickupStrictlyMatch ) THEN
5a6ef5c2b4 Mich*0293          WRITE(msgBuf,'(4A)') 'GMREDI_READ_PICKUP: ',
a4576c7cde Juli*0294      &      'try with " pickupStrictlyMatch=.FALSE.,"',
                0295      &      ' in file: "data", NameList: "PARM03"'
5a6ef5c2b4 Mich*0296          CALL PRINT_ERROR( msgBuf, myThid )
a4576c7cde Juli*0297          stopFlag = .TRUE.
                0298         ELSE
                0299          DO j=1,nMissing
                0300           IF ( missFldList(j).EQ.'GEOM_EKE' ) THEN
                0301 #ifdef GM_GEOM_VARIABLE_K
                0302            GEOM_startAB = 0
                0303            WRITE(msgBuf,'(4A)') '** WARNING ** GMREDI_READ_PICKUP: ',
                0304      &      'restart with uniform GEOM_EKE = GEOM_ini_EKE'
                0305            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0306           ELSEIF ( missFldList(j).EQ.'GEKE_Nm1' ) THEN
                0307            GEOM_startAB = 0
                0308            WRITE(msgBuf,'(4A)') '** WARNING ** GMREDI_READ_PICKUP: ',
                0309      &     'Will get only an approximated Restart (GEOM_startAB=0)'
                0310            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0311 #endif /* GM_GEOM_VARIABLE_K */
                0312           ELSE
                0313            stopFlag = .TRUE.
                0314            WRITE(msgBuf,'(4A)') 'GMREDI_READ_PICKUP: ',
                0315      &          'cannot restart without field "',missFldList(j),'"'
                0316            CALL PRINT_ERROR( msgBuf, myThid )
                0317           ENDIF
                0318          ENDDO
                0319         ENDIF
                0320         IF ( stopFlag ) THEN
                0321          CALL ALL_PROC_DIE( 0 )
                0322          STOP 'ABNORMAL END: S/R GMREDI_READ_PICKUP'
                0323         ENDIF
5a6ef5c2b4 Mich*0324
a4576c7cde Juli*0325        ENDIF
                0326        _END_MASTER( myThid )
                0327 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0328
                0329 C     end if GM_useBatesK3d or GM_useGEOM block
                0330       ENDIF
                0331 #endif /* GM_BATES_K3D or GM_GEOM_VARIABLE_K */
5a6ef5c2b4 Mich*0332
                0333       RETURN
                0334       END