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       LOGICAL glf
                0039       _RL     timList(1)
e0f9a7ba0b Matt*0040       INTEGER j
c0d1c06c15 Matt*0041       INTEGER listDim, nWrFlds
                0042       PARAMETER( listDim = 6 )
                0043       CHARACTER*(8) wrFldList(listDim)
                0044       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0045
                0046         prec = precFloat64
                0047
                0048         WRITE(fn,'(A,A)') 'pickup_bling.',suff
                0049         j = 0
                0050
                0051 C     Firstly, write 3-D fields as consecutive records,
                0052
                0053 C       record number < 0 : a hack not to write meta files now:
                0054         j = j + 1
                0055         CALL WRITE_REC_3D_RL( fn, prec, Nr, pH, -j, myIter, myThid )
                0056         IF (j.LE.listDim) wrFldList(j) = 'BLG_pH3d'
                0057
                0058         j = j + 1
                0059         CALL WRITE_REC_3D_RL( fn, prec, Nr, irr_mem,
                0060      &                        -j, myIter, myThid )
                0061         IF (j.LE.listDim) wrFldList(j) = 'BLG_irrm'
                0062
                0063         j = j + 1
                0064         CALL WRITE_REC_3D_RL( fn, prec, Nr, chl, -j, myIter, myThid )
                0065         IF (j.LE.listDim) wrFldList(j) = 'BLG_chl '
                0066
                0067         j = j + 1
e0f9a7ba0b Matt*0068         CALL WRITE_REC_3D_RL( fn, prec, Nr, phyto_sm, -j, myIter,
4ac06494d5 Matt*0069      & myThid )
39f4971479 Matt*0070         IF (j.LE.listDim) wrFldList(j) = 'BLG_Psm '
c0d1c06c15 Matt*0071
                0072         j = j + 1
e0f9a7ba0b Matt*0073         CALL WRITE_REC_3D_RL( fn, prec, Nr, phyto_lg, -j, myIter,
4ac06494d5 Matt*0074      & myThid )
c0d1c06c15 Matt*0075         IF (j.LE.listDim) wrFldList(j) = 'BLG_Plg '
                0076
e0f9a7ba0b Matt*0077 #ifndef USE_BLING_V1
c0d1c06c15 Matt*0078         j = j + 1
e0f9a7ba0b Matt*0079         CALL WRITE_REC_3D_RL( fn, prec, Nr, phyto_diaz, -j, myIter,
4ac06494d5 Matt*0080      & myThid )
c0d1c06c15 Matt*0081         IF (j.LE.listDim) wrFldList(j) = 'BLG_Pdia'
e0f9a7ba0b Matt*0082 #endif
c0d1c06c15 Matt*0083
                0084 C--------------------------
                0085         nWrFlds = j
                0086         IF ( nWrFlds.GT.listDim ) THEN
                0087           WRITE(msgBuf,'(2A,I5,A)') 'BLING_WRITE_PICKUP: ',
                0088      &     'trying to write ',nWrFlds,' fields'
                0089           CALL PRINT_ERROR( msgBuf, myThid )
                0090           WRITE(msgBuf,'(2A,I5,A)') 'BLING_WRITE_PICKUP: ',
                0091      &     'field-list dimension (listDim=',listDim,') too small'
                0092           CALL PRINT_ERROR( msgBuf, myThid )
                0093           STOP 'ABNORMAL END: S/R BLING_WRITE_PICKUP (list-size Pb)'
                0094         ENDIF
                0095
                0096 #ifdef ALLOW_MDSIO
                0097 C     uses this specific S/R to write (with more informations) only meta
                0098 C     files
                0099         j  = 1
                0100         glf  = globalFiles
                0101         timList(1) = myTime
                0102         CALL MDS_WR_METAFILES( fn, prec, glf, .FALSE.,
                0103      &                         0, 0, Nr, ' ',
                0104      &                         nWrFlds, wrFldList,
                0105      &                         1, timList, oneRL,
                0106      &                         j, myIter, myThid )
                0107 #endif /* ALLOW_MDSIO */
                0108 C--------------------------
                0109
                0110 #endif /* ALLOW_BLING */
                0111
                0112       RETURN
                0113       END