pkg/bling/bling_write_pickup.F

c0d1c06c15 Matt*0001 #include "BLING_OPTIONS.h"
                0002
                0003 CBOP
                0004       subroutine BLING_WRITE_PICKUP( permPickup,
                0005      I                             suff, myTime, myIter, myThid )
                0006
                0007 C     =================================================================
                0008 C     | subroutine bling_write_pickup
                0009 C     | o Writes BLING arrays (needed for a restart) to a pickup file
                0010 C     =================================================================
                0011
e0f9a7ba0b Matt*0012       IMPLICIT NONE
                0013
c0d1c06c15 Matt*0014 C     === Global variables ===
                0015 #include "SIZE.h"
                0016 #include "EEPARAMS.h"
                0017 #include "PARAMS.h"
                0018 #include "BLING_VARS.h"
                0019
                0020 C     === Routine arguments ===
                0021 C     permPickup :: write a permanent pickup
                0022 C     suff       :: suffix for pickup file (eg. ckptA or 0000000010)
                0023 C     myTime     :: Current time in simulation
                0024 C     myIter     :: Current iteration number in simulation
                0025 C     myThid     :: My Thread Id number
                0026       LOGICAL permPickup
                0027       CHARACTER*(*) suff
                0028       _RL     myTime
                0029       INTEGER myIter
                0030       INTEGER myThid
                0031 CEOP
                0032
                0033 #ifdef ALLOW_BLING
                0034
                0035 C     == Local variables ==
                0036       CHARACTER*(MAX_LEN_FNAM) fn
                0037       INTEGER prec
                0038 #ifndef USE_ATMOSCO2
e0f9a7ba0b Matt*0039 c     INTEGER ioUnit
                0040 c     _RL tmpFld(2)
                0041 c     _RS dummyRS(1)
c0d1c06c15 Matt*0042 #endif
                0043       LOGICAL glf
                0044       _RL     timList(1)
e0f9a7ba0b Matt*0045       INTEGER j
c0d1c06c15 Matt*0046       INTEGER listDim, nWrFlds
                0047       PARAMETER( listDim = 6 )
                0048       CHARACTER*(8) wrFldList(listDim)
                0049       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0050
                0051         prec = precFloat64
                0052
                0053         WRITE(fn,'(A,A)') 'pickup_bling.',suff
                0054         j = 0
                0055
                0056 C     Firstly, write 3-D fields as consecutive records,
                0057
                0058 C       record number < 0 : a hack not to write meta files now:
                0059         j = j + 1
                0060         CALL WRITE_REC_3D_RL( fn, prec, Nr, pH, -j, myIter, myThid )
                0061         IF (j.LE.listDim) wrFldList(j) = 'BLG_pH3d'
                0062
                0063         j = j + 1
                0064         CALL WRITE_REC_3D_RL( fn, prec, Nr, irr_mem,
                0065      &                        -j, myIter, myThid )
                0066         IF (j.LE.listDim) wrFldList(j) = 'BLG_irrm'
                0067
                0068         j = j + 1
                0069         CALL WRITE_REC_3D_RL( fn, prec, Nr, chl, -j, myIter, myThid )
                0070         IF (j.LE.listDim) wrFldList(j) = 'BLG_chl '
                0071
                0072         j = j + 1
e0f9a7ba0b Matt*0073         CALL WRITE_REC_3D_RL( fn, prec, Nr, phyto_sm, -j, myIter,
4ac06494d5 Matt*0074      & myThid )
39f4971479 Matt*0075         IF (j.LE.listDim) wrFldList(j) = 'BLG_Psm '
c0d1c06c15 Matt*0076
                0077         j = j + 1
e0f9a7ba0b Matt*0078         CALL WRITE_REC_3D_RL( fn, prec, Nr, phyto_lg, -j, myIter,
4ac06494d5 Matt*0079      & myThid )
c0d1c06c15 Matt*0080         IF (j.LE.listDim) wrFldList(j) = 'BLG_Plg '
                0081
e0f9a7ba0b Matt*0082 #ifndef USE_BLING_V1
c0d1c06c15 Matt*0083         j = j + 1
e0f9a7ba0b Matt*0084         CALL WRITE_REC_3D_RL( fn, prec, Nr, phyto_diaz, -j, myIter,
4ac06494d5 Matt*0085      & myThid )
c0d1c06c15 Matt*0086         IF (j.LE.listDim) wrFldList(j) = 'BLG_Pdia'
e0f9a7ba0b Matt*0087 #endif
c0d1c06c15 Matt*0088
                0089 C--------------------------
                0090         nWrFlds = j
                0091         IF ( nWrFlds.GT.listDim ) THEN
                0092           WRITE(msgBuf,'(2A,I5,A)') 'BLING_WRITE_PICKUP: ',
                0093      &     'trying to write ',nWrFlds,' fields'
                0094           CALL PRINT_ERROR( msgBuf, myThid )
                0095           WRITE(msgBuf,'(2A,I5,A)') 'BLING_WRITE_PICKUP: ',
                0096      &     'field-list dimension (listDim=',listDim,') too small'
                0097           CALL PRINT_ERROR( msgBuf, myThid )
                0098           STOP 'ABNORMAL END: S/R BLING_WRITE_PICKUP (list-size Pb)'
                0099         ENDIF
                0100
                0101 #ifdef ALLOW_MDSIO
                0102 C     uses this specific S/R to write (with more informations) only meta
                0103 C     files
                0104         j  = 1
                0105         glf  = globalFiles
                0106         timList(1) = myTime
                0107         CALL MDS_WR_METAFILES( fn, prec, glf, .FALSE.,
                0108      &                         0, 0, Nr, ' ',
                0109      &                         nWrFlds, wrFldList,
                0110      &                         1, timList, oneRL,
                0111      &                         j, myIter, myThid )
                0112 #endif /* ALLOW_MDSIO */
                0113 C--------------------------
                0114
                0115 #endif /* ALLOW_BLING */
                0116
                0117       RETURN
                0118       END