pkg/bbl/bbl_write_pickup.F

53b68b7823 Dimi*0001 #include "BBL_OPTIONS.h"
                0002
                0003 CBOP
                0004 C !ROUTINE: BBL_WRITE_PICKUP
                0005
                0006 C !INTERFACE: ==========================================================
                0007       SUBROUTINE BBL_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 "BBL.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
                0035 #ifdef ALLOW_BBL
                0036
                0037 C     === Functions ====
                0038       INTEGER  ILNBLNK
                0039       EXTERNAL ILNBLNK
                0040
                0041 C !LOCAL VARIABLES: ====================================================
                0042 C     j           :: loop index / field number
                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
                0050       INTEGER j, fp, lChar
                0051       LOGICAL glf
1706a6e971 Jean*0052       _RL     timList(1)
53b68b7823 Dimi*0053       CHARACTER*(MAX_LEN_FNAM) fn
                0054       INTEGER listDim, nWrFlds
                0055       PARAMETER( listDim = 3 )
                0056       CHARACTER*(8) wrFldList(listDim)
                0057       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0058 CEOP
                0059
                0060         lChar = ILNBLNK(suff)
                0061         IF ( lChar.EQ.0 ) THEN
                0062           WRITE(fn,'(2A)') 'pickup_bbl'
                0063         ELSE
                0064           WRITE(fn,'(2A)') 'pickup_bbl.',suff(1:lChar)
                0065         ENDIF
                0066         fp = precFloat64
                0067         j  = 0
                0068
                0069 C     Write 2-D fields
                0070 C     record number < 0 : a hack not to write meta files now:
                0071
                0072         j = j + 1
                0073         CALL WRITE_REC_3D_RL( fn, fp, 1,
                0074      &                        bbl_theta, -j, myIter, myThid )
                0075         IF (j.LE.listDim) wrFldList(j) = 'bblTheta'
                0076
                0077         j = j + 1
                0078         CALL WRITE_REC_3D_RL( fn, fp, 1,
                0079      &                        bbl_salt, -j, myIter, myThid )
                0080         IF (j.LE.listDim) wrFldList(j) = 'bblSalt '
                0081
                0082         j = j + 1
                0083         CALL WRITE_REC_3D_RL( fn, fp, 1,
                0084      &                        bbl_eta, -j, myIter, myThid )
                0085         IF (j.LE.listDim) wrFldList(j) = 'bblEta  '
                0086
                0087 C--------------------------
                0088         nWrFlds = j
                0089         IF ( nWrFlds.GT.listDim ) THEN
                0090           WRITE(msgBuf,'(2A,I5,A)') 'BBL_WRITE_PICKUP: ',
                0091      &     'trying to write ',nWrFlds,' fields'
                0092           CALL PRINT_ERROR( msgBuf, myThid )
                0093           WRITE(msgBuf,'(2A,I5,A)') 'BBL_WRITE_PICKUP: ',
                0094      &     'field-list dimension (listDim=',listDim,') too small'
                0095           CALL PRINT_ERROR( msgBuf, myThid )
                0096           STOP 'ABNORMAL END: S/R BBL_WRITE_PICKUP (list-size Pb)'
                0097         ENDIF
                0098 #ifdef ALLOW_MDSIO
                0099 C     uses this specific S/R to write meta file
                0100         glf  = globalFiles
1706a6e971 Jean*0101         timList(1) = myTime
53b68b7823 Dimi*0102         CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE.,
                0103      &                         0, 0, 1, ' ',
                0104      &                         nWrFlds, wrFldList,
ba68d2f969 Jean*0105      &                         1, timList, oneRL,
53b68b7823 Dimi*0106      &                         j, myIter, myThid )
                0107 #endif /* ALLOW_MDSIO */
                0108 C--------------------------
                0109
                0110 #endif /* ALLOW_BBL */
                0111
                0112       RETURN
                0113       END