pkg/atm_phys/atm_phys_write_pickup.F

b2ea1d2979 Jean*0001 #include "ATM_PHYS_OPTIONS.h"
                0002
                0003 CBOP
                0004 C !ROUTINE: ATM_PHYS_WRITE_PICKUP
                0005
                0006 C !INTERFACE: ==========================================================
                0007       SUBROUTINE ATM_PHYS_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 "ATM_PHYS_PARAMS.h"
                0019 #include "ATM_PHYS_VARS.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_ATM_PHYS
                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
                0054       _RL     timList(1)
                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
b5f066e9ce Jean*0062 C-    for now, only needs pickup if stepping forward SST
                0063       IF ( .NOT.atmPhys_stepSST ) RETURN
                0064
b2ea1d2979 Jean*0065         lChar = ILNBLNK(suff)
                0066         IF ( lChar.EQ.0 ) THEN
                0067           WRITE(fn,'(2A)') 'pickup_atmPhys'
                0068         ELSE
                0069           WRITE(fn,'(2A)') 'pickup_atmPhys.',suff(1:lChar)
                0070         ENDIF
                0071         fp = precFloat64
                0072         j  = 0
                0073
                0074 C       Firstly, write 3-D fields as consecutive records,
                0075
                0076 C-    switch to 2-D fields:
                0077         nj = -j*Nr
                0078
                0079         j = j + 1
                0080         nj = nj-1
                0081         CALL WRITE_REC_3D_RL( fn, fp, 1,
                0082      &                        atmPhys_SST, nj, myIter, myThid )
                0083         IF (j.LE.listDim) wrFldList(j) = 'AtPh_SST'
                0084
                0085 C--------------------------
                0086         nWrFlds = j
                0087         IF ( nWrFlds.GT.listDim ) THEN
                0088           WRITE(msgBuf,'(2A,I5,A)') 'ATM_PHYS_WRITE_PICKUP: ',
                0089      &     'trying to write ',nWrFlds,' fields'
                0090           CALL PRINT_ERROR( msgBuf, myThid )
                0091           WRITE(msgBuf,'(2A,I5,A)') 'ATM_PHYS_WRITE_PICKUP: ',
                0092      &     'field-list dimension (listDim=',listDim,') too small'
                0093           CALL PRINT_ERROR( msgBuf, myThid )
                0094           CALL ALL_PROC_DIE( myThid )
                0095           STOP 'ABNORMAL END: S/R ATM_PHYS_WRITE_PICKUP (list-size Pb)'
                0096         ENDIF
                0097 #ifdef ALLOW_MDSIO
                0098 C     uses this specific S/R to write (with more informations) only meta files
                0099         j  = 1
                0100         nj = ABS(nj)
                0101         IF ( nWrFlds*Nr .EQ. nj ) THEN
                0102           j  = Nr
                0103           nj = nWrFlds
                0104         ENDIF
                0105         glf  = globalFiles
                0106         timList(1) = myTime
                0107         CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE.,
                0108      &                         0, 0, j, ' ',
                0109      &                         nWrFlds, wrFldList,
                0110      &                         1, timList, oneRL,
                0111      &                         nj, myIter, myThid )
                0112 #endif /* ALLOW_MDSIO */
                0113 C--------------------------
                0114
                0115 #endif /* ALLOW_ATM_PHYS */
                0116
                0117       RETURN
                0118       END