pkg/ptracers/ptracers_write_pickup.F

d217ad1db8 Oliv*0001 #include "GAD_OPTIONS.h"
785a077159 Alis*0002 #include "PTRACERS_OPTIONS.h"
                0003
                0004 CBOP
33e25d6b04 Jean*0005 C !ROUTINE: PTRACERS_WRITE_PICKUP
785a077159 Alis*0006
                0007 C !INTERFACE: ==========================================================
d197c88195 Jean*0008       SUBROUTINE PTRACERS_WRITE_PICKUP( permCheckPoint,
2902091e6e Jean*0009      &                    suff, myTime, myIter, myThid )
785a077159 Alis*0010
                0011 C !DESCRIPTION:
                0012 C     Writes current state of passive tracers to a pickup file
                0013
                0014 C !USES: ===============================================================
d217ad1db8 Oliv*0015 #include "PTRACERS_MOD.h"
785a077159 Alis*0016       IMPLICIT NONE
                0017 #include "SIZE.h"
                0018 #include "EEPARAMS.h"
                0019 #include "PARAMS.h"
d217ad1db8 Oliv*0020 #include "GAD.h"
636477d15b Jean*0021 #include "PTRACERS_SIZE.h"
0a278985fd Jean*0022 #include "PTRACERS_PARAMS.h"
                0023 #include "PTRACERS_FIELDS.h"
785a077159 Alis*0024
                0025 C !INPUT PARAMETERS: ===================================================
5bc9611487 Ed H*0026 C     permCheckPoint  :: permanent or a rolling checkpoint
                0027 C     suff            :: suffix for pickup file (eg. ckptA or 0000000010)
                0028 C     myTime          :: model time
2902091e6e Jean*0029 C     myIter          :: time-step number
5bc9611487 Ed H*0030 C     myThid          :: thread number
                0031       LOGICAL permCheckPoint
785a077159 Alis*0032       CHARACTER*(*) suff
                0033       _RL myTime
2902091e6e Jean*0034       INTEGER myIter
785a077159 Alis*0035       INTEGER myThid
                0036
                0037 C !OUTPUT PARAMETERS: ==================================================
                0038 C  none
                0039
                0040 #ifdef ALLOW_PTRACERS
                0041
d197c88195 Jean*0042 C     === Functions ====
                0043       INTEGER  ILNBLNK
                0044       EXTERNAL ILNBLNK
                0045
785a077159 Alis*0046 C !LOCAL VARIABLES: ====================================================
804ee8c862 Jean*0047 C     iTracer     :: tracer index
                0048 C     j           :: loop index / field number
                0049 C     prec        :: pickup-file precision
                0050 C     glf         :: local flag for "globalFiles"
                0051 C     fn          :: character buffer for creating filename
                0052 C     nWrFlds     :: number of fields being written
                0053 C     listDim     :: dimension of "wrFldList" local array
                0054 C     wrFldList   :: list of written fields
                0055 C     msgBuf      :: Informational/error message buffer
3ab6b68cec Jean*0056       INTEGER iTracer, j, prec, lChar
804ee8c862 Jean*0057       LOGICAL glf
1706a6e971 Jean*0058       _RL     timList(1)
e42d45d3cd Mart*0059       CHARACTER*(MAX_LEN_FNAM) fn
804ee8c862 Jean*0060       INTEGER listDim, nWrFlds
                0061       PARAMETER( listDim = 3*PTRACERS_num )
                0062       CHARACTER*(8) wrFldList(listDim)
                0063       CHARACTER*(MAX_LEN_MBUF) msgBuf
3ab6b68cec Jean*0064 #ifdef PTRACERS_ALLOW_DYN_STATE
                0065       INTEGER n, iRec
                0066 #endif
785a077159 Alis*0067 CEOP
                0068
50653b81f1 Ed H*0069 #ifdef ALLOW_MNC
                0070       IF ( PTRACERS_pickup_write_mnc ) THEN
5bc9611487 Ed H*0071         IF ( permCheckPoint ) THEN
d197c88195 Jean*0072           WRITE(fn,'(A)') 'pickup_ptracers'
5bc9611487 Ed H*0073         ELSE
a3218bad56 Ed H*0074           lChar = ILNBLNK(suff)
d197c88195 Jean*0075           WRITE(fn,'(2A)') 'pickup_ptracers.', suff(1:lChar)
5bc9611487 Ed H*0076         ENDIF
                0077         CALL MNC_FILE_CLOSE_ALL_MATCHING(fn, myThid)
c29c5d093c Ed H*0078 C       First ***define*** the file group name
5bc9611487 Ed H*0079         CALL MNC_CW_SET_UDIM(fn, 1, myThid)
                0080         IF ( permCheckPoint ) THEN
                0081           CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, -1, myThid)
                0082         ELSE
                0083           CALL MNC_CW_SET_CITER(fn, 2, -1, -1, -1, myThid)
                0084         ENDIF
c29c5d093c Ed H*0085 C       Then set the actual unlimited dimension
                0086         CALL MNC_CW_SET_UDIM(fn, 1, myThid)
5bc9611487 Ed H*0087 C       The following two values should probably be for the n-1 time
88f72205aa Jean*0088 C       step since we are saving the gpTrNm1 variable first
5bc9611487 Ed H*0089         CALL MNC_CW_RL_W_S('D',fn,0,0,'T', myTime, myThid)
                0090         CALL MNC_CW_I_W_S('I',fn,0,0,'iter', myIter, myThid)
50653b81f1 Ed H*0091         DO iTracer = 1,PTRACERS_numInUse
5bc9611487 Ed H*0092           CALL MNC_CW_RL_W('D',fn,0,0, PTRACERS_names(iTracer),
0a278985fd Jean*0093      &         gpTrNm1(1-OLx,1-OLy,1,1,1,iTracer),myThid)
50653b81f1 Ed H*0094         ENDDO
5bc9611487 Ed H*0095         CALL MNC_CW_SET_UDIM(fn, 2, myThid)
                0096         CALL MNC_CW_RL_W_S('D',fn,0,0,'T', myTime, myThid)
                0097         CALL MNC_CW_I_W_S('I',fn,0,0,'iter', myIter, myThid)
50653b81f1 Ed H*0098         DO iTracer = 1,PTRACERS_numInUse
5bc9611487 Ed H*0099           CALL MNC_CW_RL_W('D',fn,0,0, PTRACERS_names(iTracer),
50653b81f1 Ed H*0100      &         pTracer(1-OLx,1-OLy,1,1,1,iTracer),myThid)
                0101         ENDDO
                0102       ENDIF
d217ad1db8 Oliv*0103       IF ( useMNC .AND. PTRACERS_pickup_write_mnc ) THEN
                0104        DO iTracer = 1, PTRACERS_numInUse
                0105         IF ( PTRACERS_SOM_Advection(iTracer) ) THEN
                0106          WRITE(msgBuf,'(3A)')'PTRACERS_WRITE_PICKUP: MNC not yet coded',
                0107      &                       ' for SOM advection',
                0108      &                       ' => write bin file instead'
                0109          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0110      &                       SQUEEZE_RIGHT, myThid)
                0111         ENDIF
                0112        ENDDO
                0113       ENDIF
50653b81f1 Ed H*0114 #endif /*  ALLOW_MNC  */
d197c88195 Jean*0115
11e93ca08e Jean*0116       lChar = ILNBLNK(suff)
50653b81f1 Ed H*0117       IF ( PTRACERS_pickup_write_mdsio ) THEN
785a077159 Alis*0118
d197c88195 Jean*0119         IF ( lChar.EQ.0 ) THEN
                0120           WRITE(fn,'(2A)') 'pickup_ptracers'
                0121         ELSE
                0122           WRITE(fn,'(2A)') 'pickup_ptracers.',suff(1:lChar)
                0123         ENDIF
50653b81f1 Ed H*0124         prec = precFloat64
785a077159 Alis*0125
804ee8c862 Jean*0126 C       Firstly, write ptracer fields as consecutive records,
                0127 C       one tracer after the other, for all tracers "InUse".
                0128
                0129         j  = 0
                0130 C     record number < 0 : a hack not to write meta files now:
                0131         DO iTracer = 1, PTRACERS_numInUse
                0132           j = j + 1
d197c88195 Jean*0133           CALL WRITE_REC_3D_RL( fn, prec, Nr,
9b39915e34 Jean*0134      &         pTracer(1-OLx,1-OLy,1,1,1,iTracer),
804ee8c862 Jean*0135      &         -j, myIter, myThid )
                0136           IF (j.LE.listDim)
                0137      &      wrFldList(j) = 'pTr'//PTRACERS_ioLabel(iTracer)//'   '
                0138         ENDDO
                0139
                0140 C       Then write ptracer tendencies (if this tracer is using AB time-stepping)
                0141         DO iTracer = 1, PTRACERS_numInUse
fc10d43a89 Jean*0142          IF ( PTRACERS_AdamsBashGtr(iTracer) .OR.
                0143      &        PTRACERS_AdamsBash_Tr(iTracer) ) THEN
804ee8c862 Jean*0144           j = j + 1
d197c88195 Jean*0145           CALL WRITE_REC_3D_RL( fn, prec, Nr,
9b39915e34 Jean*0146      &         gpTrNm1(1-OLx,1-OLy,1,1,1,iTracer),
804ee8c862 Jean*0147      &         -j, myIter, myThid )
fc10d43a89 Jean*0148           IF ( j.LE.listDim .AND. PTRACERS_AdamsBashGtr(iTracer) )
804ee8c862 Jean*0149      &      wrFldList(j) = 'gPtr'//PTRACERS_ioLabel(iTracer)//'m1'
fc10d43a89 Jean*0150           IF ( j.LE.listDim .AND. PTRACERS_AdamsBash_Tr(iTracer) )
                0151      &      wrFldList(j) = 'pTr'//PTRACERS_ioLabel(iTracer)//'Nm1'
804ee8c862 Jean*0152          ENDIF
                0153
50653b81f1 Ed H*0154         ENDDO
                0155
804ee8c862 Jean*0156 C--------------------------
                0157         nWrFlds = j
                0158         IF ( nWrFlds.GT.listDim ) THEN
                0159           WRITE(msgBuf,'(2A,I5,A)') 'PTRACERS_WRITE_PICKUP: ',
                0160      &     'trying to write ',nWrFlds,' fields'
                0161           CALL PRINT_ERROR( msgBuf, myThid )
                0162           WRITE(msgBuf,'(2A,I5,A)') 'PTRACERS_WRITE_PICKUP: ',
                0163      &     'field-list dimension (listDim=',listDim,') too small'
                0164           CALL PRINT_ERROR( msgBuf, myThid )
                0165           STOP 'ABNORMAL END: S/R PTRACERS_WRITE_PICKUP (list-size Pb)'
                0166         ENDIF
                0167 #ifdef ALLOW_MDSIO
                0168 C     uses this specific S/R to write (with more informations) only meta files
                0169         glf  = globalFiles
1706a6e971 Jean*0170         timList(1) = myTime
804ee8c862 Jean*0171         CALL MDS_WR_METAFILES( fn, prec, glf, .FALSE.,
                0172      &                         0, 0, Nr, ' ',
                0173      &                         nWrFlds, wrFldList,
ba68d2f969 Jean*0174      &                         1, timList, oneRL,
804ee8c862 Jean*0175      &                         j, myIter, myThid )
                0176 #endif /* ALLOW_MDSIO */
d217ad1db8 Oliv*0177 C--------------------------
11e93ca08e Jean*0178       ENDIF
                0179
811d3e9bd3 Jean*0180 #ifdef PTRACERS_ALLOW_DYN_STATE
d217ad1db8 Oliv*0181 C     write pickup for 2nd-order moment fields
                0182 C     we write a separate file for each Ptracer that uses SOM advection
                0183         DO iTracer = 1, PTRACERS_numInUse
                0184          IF ( PTRACERS_SOM_Advection(iTracer) ) THEN
                0185           IF ( lChar.EQ.0 ) THEN
                0186             WRITE(fn,'(2A)') 'pickup_somTRAC',PTRACERS_ioLabel(iTracer)
                0187           ELSE
                0188             WRITE(fn,'(4A)') 'pickup_somTRAC',PTRACERS_ioLabel(iTracer),
                0189      &                       '.',suff(1:lChar)
                0190           ENDIF
11e93ca08e Jean*0191           _BEGIN_MASTER(myThid)
                0192           WRITE(msgBuf,'(A,I4,A)')'PTRACERS_WRITE_PICKUP: iTracer =',
                0193      &                       iTracer, ' : writing 2nd-order moments'
d217ad1db8 Oliv*0194           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
11e93ca08e Jean*0195      &                        SQUEEZE_RIGHT, myThid )
                0196           j = ILNBLNK(fn)
                0197           WRITE(msgBuf,'(A,A)') ' to file: ',fn(1:j)
                0198           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0199      &                        SQUEEZE_RIGHT, myThid )
                0200           _END_MASTER(myThid)
d217ad1db8 Oliv*0201           prec = precFloat64
                0202 C     Write 2nd Order moments as consecutive records
                0203           DO n=1,nSOM
                0204             iRec = n
                0205             CALL WRITE_REC_3D_RL( fn, prec, Nr,
646c54e667 Jean*0206      I               _Ptracers_som(:,:,:,:,:,n,iTracer),
d217ad1db8 Oliv*0207      I               iRec, myIter, myThid )
                0208           ENDDO
                0209          ENDIF
                0210         ENDDO
811d3e9bd3 Jean*0211 #endif /* PTRACERS_ALLOW_DYN_STATE */
785a077159 Alis*0212
                0213 #endif /* ALLOW_PTRACERS */
                0214
                0215       RETURN
                0216       END