pkg/gmredi/gmredi_write_pickup.F

5a6ef5c2b4 Mich*0001 #include "GMREDI_OPTIONS.h"
                0002
                0003 CBOP
                0004 C !ROUTINE: GMREDI_WRITE_PICKUP
                0005
                0006 C !INTERFACE: ==========================================================
                0007       SUBROUTINE GMREDI_WRITE_PICKUP( permPickup,
                0008      &     suff, myTime, myIter, myThid )
                0009
                0010 C !DESCRIPTION:
                0011 C     Writes current state of passive tracers to 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     permPickup      :: write a permanent pickup
                0022 C     suff            :: suffix for pickup file (eg. ckptA or 0000000010)
                0023 C     myTime          :: model time
                0024 C     myIter          :: time-step number
                0025 C     myThid          :: thread number
                0026       LOGICAL permPickup
                0027       CHARACTER*(*) suff
                0028       _RL myTime
                0029       INTEGER myIter
                0030       INTEGER myThid
                0031
                0032 C !OUTPUT PARAMETERS: ==================================================
                0033 C  none
                0034
a4576c7cde Juli*0035 #if ( defined GM_BATES_K3D || defined GM_GEOM_VARIABLE_K )
                0036 C !FUNCTIONS: ==========================================================
5a6ef5c2b4 Mich*0037       INTEGER  ILNBLNK
                0038       EXTERNAL ILNBLNK
                0039
                0040 C !LOCAL VARIABLES: ====================================================
a4576c7cde Juli*0041 C     n           :: loop index / field number
                0042 C     nj          :: record number
5a6ef5c2b4 Mich*0043 C     fp          :: pickup-file precision
                0044 C     glf         :: local flag for "globalFiles"
                0045 C     fn          :: character buffer for creating filename
                0046 C     nWrFlds     :: number of fields being written
                0047 C     listDim     :: dimension of "wrFldList" local array
                0048 C     wrFldList   :: list of written fields
                0049 C     msgBuf      :: Informational/error message buffer
a4576c7cde Juli*0050       INTEGER n, nj, fp, lChar
5a6ef5c2b4 Mich*0051       LOGICAL glf
                0052       _RL     timList(1)
                0053       CHARACTER*(MAX_LEN_FNAM) fn
                0054       INTEGER listDim, nWrFlds
a4576c7cde Juli*0055 #ifdef GM_BATES_K3D
                0056       INTEGER i, j, k, bi, bj, m
                0057       _RL vec(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0058 # ifdef GM_GEOM_VARIABLE_K
                0059       PARAMETER( listDim = 5+2*GM_Bates_NModes )
                0060 # else
05118ac017 Jean*0061       PARAMETER( listDim = 2+2*GM_Bates_NModes )
a4576c7cde Juli*0062 # endif
                0063 #else /* GM_BATES_K3D */
                0064       PARAMETER( listDim = 3 )
                0065 #endif /* GM_BATES_K3D */
5a6ef5c2b4 Mich*0066       CHARACTER*(8) wrFldList(listDim)
                0067       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0068       CHARACTER*(8) fieldname
                0069 CEOP
                0070
a4576c7cde Juli*0071 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
5a6ef5c2b4 Mich*0072
a4576c7cde Juli*0073       IF ( GM_useBatesK3d .OR. GM_useGEOM ) THEN
                0074
                0075        lChar = ILNBLNK(suff)
                0076        IF ( lChar.EQ.0 ) THEN
                0077          WRITE(fn,'(2A)') 'pickup_gmredi'
                0078        ELSE
                0079          WRITE(fn,'(2A)') 'pickup_gmredi.',suff(1:lChar)
                0080        ENDIF
                0081        fp = precFloat64
                0082        n  = 0
                0083        nj = 0
                0084
                0085 #ifdef GM_BATES_K3D
                0086        IF ( GM_useBatesK3d ) THEN
5a6ef5c2b4 Mich*0087
                0088 C     record number < 0 : a hack not to write meta files now:
                0089
                0090 C     Centre mode
a4576c7cde Juli*0091         DO bj=myByLo(myThid),myByHi(myThid)
                0092          DO bi=myBxLo(myThid),myBxHi(myThid)
                0093           DO k=1,Nr
                0094            DO j=1-OLy,sNy+OLy
                0095             DO i=1-OLx,sNx+OLx
                0096              vec(i,j,k,bi,bj) = modesC(1,i,j,k,bi,bj)
                0097             ENDDO
                0098            ENDDO
5a6ef5c2b4 Mich*0099           ENDDO
                0100          ENDDO
                0101         ENDDO
a4576c7cde Juli*0102         n = n + 1
                0103         CALL WRITE_REC_3D_RL( fn, fp, Nr,
                0104      &                        vec, -n, myIter, myThid )
                0105         fieldname = 'mode01C '
                0106         IF (n.LE.listDim) wrFldList(n) = fieldname
5a6ef5c2b4 Mich*0107
                0108 C     Western Mode
a4576c7cde Juli*0109         DO m=1,GM_Bates_NModes
                0110          DO bj=myByLo(myThid),myByHi(myThid)
                0111           DO bi=myBxLo(myThid),myBxHi(myThid)
                0112            DO k=1,Nr
                0113             DO j=1-OLy,sNy+OLy
                0114              DO i=1-OLx,sNx+OLx
                0115               vec(i,j,k,bi,bj) = modesW(m,i,j,k,bi,bj)
                0116              ENDDO
                0117             ENDDO
5a6ef5c2b4 Mich*0118            ENDDO
                0119           ENDDO
                0120          ENDDO
a4576c7cde Juli*0121          n = n + 1
                0122          CALL WRITE_REC_3D_RL( fn, fp, Nr,
                0123      &                         vec, -n, myIter, myThid )
                0124          WRITE(fieldname, '(A,I2.2,A)') 'mode',m,'W'
                0125          IF (n.LE.listDim) wrFldList(n) = fieldname
5a6ef5c2b4 Mich*0126         ENDDO
                0127
                0128 C     Southern Mode
a4576c7cde Juli*0129         DO m=1,GM_Bates_NModes
                0130          DO bj=myByLo(myThid),myByHi(myThid)
                0131           DO bi=myBxLo(myThid),myBxHi(myThid)
                0132            DO k=1,Nr
                0133             DO j=1-OLy,sNy+OLy
                0134              DO i=1-OLx,sNx+OLx
                0135               vec(i,j,k,bi,bj) = modesS(m,i,j,k,bi,bj)
                0136              ENDDO
                0137             ENDDO
5a6ef5c2b4 Mich*0138            ENDDO
                0139           ENDDO
                0140          ENDDO
a4576c7cde Juli*0141          n = n + 1
                0142          CALL WRITE_REC_3D_RL( fn, fp, Nr,
                0143      &                         vec, -n, myIter, myThid )
                0144          WRITE(fieldname, '(A,I2.2,A)') 'mode',m,'S'
                0145          IF (n.LE.listDim) wrFldList(n) = fieldname
5a6ef5c2b4 Mich*0146         ENDDO
                0147 C--------------------------
                0148
                0149 C-    switch to 2-D fields:
a4576c7cde Juli*0150         nj = -n*Nr
5a6ef5c2b4 Mich*0151
                0152 C     The deformation radius (2D field)
a4576c7cde Juli*0153         n = n + 1
                0154         nj = nj-1
                0155         CALL WRITE_REC_3D_RL( fn, fp, 1,
                0156      &                        Rdef, nj, myIter, myThid )
                0157         fieldname = 'Rdef    '
                0158         IF (n.LE.listDim) wrFldList(n) = fieldname
                0159
                0160 c     if GM_useBatesK3d
                0161        ENDIF
                0162 #endif /* GM_BATES_K3D */
                0163
                0164 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0165
                0166 #ifdef GM_GEOM_VARIABLE_K
                0167        IF ( GM_useGEOM ) THEN
                0168
                0169         n = n + 1
                0170         nj = nj-1
                0171         CALL WRITE_REC_3D_RL( fn,fp,1,GEOM_EKE,nj,myIter,myThid )
                0172         fieldname = 'GEOM_EKE'
                0173         IF (n.LE.listDim) wrFldList(n) = fieldname
                0174
                0175         n = n + 1
                0176         nj = nj-1
                0177         CALL WRITE_REC_3D_RL( fn,fp,1,GEOM_gEKE_Nm1,nj,myIter,myThid )
                0178         fieldname = 'GEKE_Nm1'
                0179         IF (n.LE.listDim) wrFldList(n) = fieldname
                0180
                0181 C     if GM_useGEOM
                0182        ENDIF
                0183 #endif /* GM_GEOM_VARIABLE_K */
                0184
                0185        nWrFlds = n
                0186        IF ( nWrFlds.GT.listDim ) THEN
                0187          WRITE(msgBuf,'(2A,I5,A)') 'GMREDI_WRITE_PICKUP: ',
                0188      &        'trying to write ',nWrFlds,' fields'
                0189          CALL PRINT_ERROR( msgBuf, myThid )
                0190          WRITE(msgBuf,'(2A,I5,A)') 'GMREDI_WRITE_PICKUP: ',
                0191      &        'field-list dimension (listDim=',listDim,') too small'
                0192          CALL PRINT_ERROR( msgBuf, myThid )
                0193          CALL ALL_PROC_DIE( myThid )
                0194          STOP 'ABNORMAL END: S/R GMREDI_WRITE_PICKUP (list-size Pb)'
                0195        ENDIF
                0196
5a6ef5c2b4 Mich*0197 #ifdef ALLOW_MDSIO
                0198 C     uses this specific S/R to write (with more informations) only meta files
a4576c7cde Juli*0199        n  = 1
                0200        nj = ABS(nj)
                0201        IF ( nWrFlds*Nr .EQ. nj ) THEN
                0202          n  = Nr
                0203          nj = nWrFlds
                0204        ENDIF
                0205        glf  = globalFiles
                0206        timList(1) = myTime
                0207        CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE.,
                0208      &       0, 0, n, ' ',
                0209      &       nWrFlds, wrFldList,
                0210      &       1, timList, oneRL,
                0211      &       nj, myIter, myThid )
5a6ef5c2b4 Mich*0212 #endif /* ALLOW_MDSIO */
                0213
a4576c7cde Juli*0214 C     if GM_useBatesK3d or GM_useGEOM
                0215       ENDIF
                0216
                0217 #endif /* GM_BATES_K3D or GM_GEOM_VARIABLE_K */
5a6ef5c2b4 Mich*0218
                0219       RETURN
                0220       END