pkg/cheapaml/cheapaml_write_pickup.F

cf5b5345a0 Jean*0001 #include "CHEAPAML_OPTIONS.h"
                0002
                0003 CBOP
                0004 C !ROUTINE: CHEAPAML_WRITE_PICKUP
                0005
                0006 C !INTERFACE: ==========================================================
                0007       SUBROUTINE CHEAPAML_WRITE_PICKUP( permPickup,
                0008      &                    suff, myTime, myIter, myThid )
                0009
                0010 C !DESCRIPTION:
ced0783fba Jean*0011 C     Writes current state of cheapaml variables  to a pickup file
cf5b5345a0 Jean*0012
                0013 C !USES: ===============================================================
                0014       IMPLICIT NONE
                0015 #include "SIZE.h"
                0016 #include "EEPARAMS.h"
                0017 #include "PARAMS.h"
ced0783fba Jean*0018 #include "FFIELDS.h"
cf5b5345a0 Jean*0019 #include "CHEAPAML.h"
                0020
                0021 C !INPUT PARAMETERS: ===================================================
                0022 C     permPickup      :: write a permanent pickup
                0023 C     suff            :: suffix for pickup file (eg. ckptA or 0000000010)
                0024 C     myTime          :: model time
                0025 C     myIter          :: time-step number
                0026 C     myThid          :: thread number
                0027       LOGICAL permPickup
                0028       CHARACTER*(*) suff
                0029       _RL myTime
                0030       INTEGER myIter
                0031       INTEGER myThid
                0032
                0033 C !OUTPUT PARAMETERS: ==================================================
                0034 C  none
                0035
                0036 #ifdef ALLOW_CHEAPAML
                0037
                0038 C     === Functions ====
                0039       INTEGER  ILNBLNK
                0040       EXTERNAL ILNBLNK
                0041
                0042 C !LOCAL VARIABLES: ====================================================
                0043 C     j           :: loop index / field number
                0044 C     nj          :: record number
                0045 C     fp          :: pickup-file precision
                0046 C     glf         :: local flag for "globalFiles"
                0047 C     fn          :: character buffer for creating filename
                0048 C     nWrFlds     :: number of fields being written
                0049 C     listDim     :: dimension of "wrFldList" local array
                0050 C     wrFldList   :: list of written fields
                0051 C     msgBuf      :: Informational/error message buffer
                0052       INTEGER j, nj, fp, lChar
                0053       LOGICAL glf
ba68d2f969 Jean*0054       _RL     timList(1)
cf5b5345a0 Jean*0055       CHARACTER*(MAX_LEN_FNAM) fn
                0056       INTEGER listDim, nWrFlds
                0057       PARAMETER( listDim = 12 )
                0058       CHARACTER*(8) wrFldList(listDim)
                0059       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0060 CEOP
                0061
                0062         lChar = ILNBLNK(suff)
                0063         IF ( lChar.EQ.0 ) THEN
                0064           WRITE(fn,'(2A)') 'pickup_cheapaml'
                0065         ELSE
                0066           WRITE(fn,'(2A)') 'pickup_cheapaml.',suff(1:lChar)
                0067         ENDIF
                0068         fp = precFloat64
                0069         j  = 0
                0070
                0071 C       Firstly, write 3-D fields as consecutive records,
                0072
                0073 C     record number < 0 : a hack not to write meta files now:
                0074
                0075 C-    switch to 2-D fields:
                0076         nj = -j*Nr
                0077
                0078         j = j + 1
                0079         nj = nj-1
                0080         CALL WRITE_REC_3D_RL( fn, fp, 1,
                0081      &                        Tair, nj, myIter, myThid )
d1720f0c76 Nico*0082         IF (j.LE.listDim) wrFldList(j) = 'Tair    '
ced0783fba Jean*0083         j = j + 1
                0084         nj = nj-1
4fa4901be6 Nico*0085         CALL WRITE_REC_3D_RL( fn, fp, 1,
58fa289e25 Jean*0086      &                        gTairm, nj, myIter, myThid )
                0087         IF (j.LE.listDim) wrFldList(j) = 'gTairNm1'
ced0783fba Jean*0088
58fa289e25 Jean*0089        IF (useFreshWaterFlux) THEN
ced0783fba Jean*0090         j = j + 1
                0091         nj = nj-1
                0092         CALL WRITE_REC_3D_RL( fn, fp, 1,
                0093      &                        qair, nj, myIter, myThid )
d1720f0c76 Nico*0094         IF (j.LE.listDim) wrFldList(j) = 'Qair    '
ced0783fba Jean*0095         j = j + 1
                0096         nj = nj-1
4fa4901be6 Nico*0097         CALL WRITE_REC_3D_RL( fn, fp, 1,
58fa289e25 Jean*0098      &                        gqairm, nj, myIter, myThid )
                0099         IF (j.LE.listDim) wrFldList(j) = 'gQairNm1'
                0100        ENDIF
51132e5783 Nico*0101
58fa289e25 Jean*0102        IF (useCheapTracer) THEN
                0103         j = j + 1
                0104         nj = nj-1
                0105         CALL WRITE_REC_3D_RL( fn, fp, 1,
51132e5783 Nico*0106      &                        Cheaptracer, nj, myIter, myThid )
58fa289e25 Jean*0107         IF (j.LE.listDim) wrFldList(j) = 'cTracer '
                0108         j = j + 1
                0109         nj = nj-1
                0110         CALL WRITE_REC_3D_RL( fn, fp, 1,
                0111      &                        gCheaptracerm, nj, myIter, myThid )
                0112         IF (j.LE.listDim) wrFldList(j) = 'gTracNm1'
                0113        ENDIF
51132e5783 Nico*0114
cf5b5345a0 Jean*0115 C--------------------------
58fa289e25 Jean*0116        nWrFlds = j
                0117        IF ( nWrFlds.GT.listDim ) THEN
cf5b5345a0 Jean*0118           WRITE(msgBuf,'(2A,I5,A)') 'CHEAPAML_WRITE_PICKUP: ',
                0119      &     'trying to write ',nWrFlds,' fields'
                0120           CALL PRINT_ERROR( msgBuf, myThid )
                0121           WRITE(msgBuf,'(2A,I5,A)') 'CHEAPAML_WRITE_PICKUP: ',
                0122      &     'field-list dimension (listDim=',listDim,') too small'
                0123           CALL PRINT_ERROR( msgBuf, myThid )
                0124           STOP 'ABNORMAL END: S/R CHEAPAML_WRITE_PICKUP (list-size Pb)'
58fa289e25 Jean*0125        ENDIF
cf5b5345a0 Jean*0126 #ifdef ALLOW_MDSIO
                0127 C     uses this specific S/R to write (with more informations) only meta files
                0128         j  = 1
                0129         nj = ABS(nj)
                0130         IF ( nWrFlds*Nr .EQ. nj ) THEN
                0131           j  = Nr
                0132           nj = nWrFlds
                0133         ENDIF
                0134         glf  = globalFiles
ba68d2f969 Jean*0135         timList(1) = myTime
cf5b5345a0 Jean*0136         CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE.,
                0137      &                         0, 0, j, ' ',
                0138      &                         nWrFlds, wrFldList,
ba68d2f969 Jean*0139      &                         1, timList, oneRL,
cf5b5345a0 Jean*0140      &                         nj, myIter, myThid )
                0141 #endif /* ALLOW_MDSIO */
                0142 C--------------------------
                0143
                0144 #endif /* ALLOW_CHEAPAML */
                0145
                0146       RETURN
                0147       END