C $Header: /u/gcmpack/MITgcm/model/src/write_pickup.F,v 1.20 2017/03/25 16:03:10 jmc Exp $
C $Name:  $

#include "PACKAGES_CONFIG.h"
#include "CPP_OPTIONS.h"

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: WRITE_PICKUP
C     !INTERFACE:
      SUBROUTINE WRITE_PICKUP(
     I                 permPickup, suffix,
     I                 myTime, myIter, myThid )

C     !DESCRIPTION:
C     Write the main-model pickup-file and do it NOW.
C     It writes both "rolling-pickup" files (ckptA,ckptB) and
C     permanent pickup files (with iteration number in the file name).
C     It calls routines from other packages (\textit{eg.} rw and mnc)
C     to do the per-variable writes.

C     !USES:
      IMPLICIT NONE
#include "SIZE.h"
#include "EEPARAMS.h"
#include "PARAMS.h"
#include "RESTART.h"
#include "DYNVARS.h"
#include "SURFACE.h"
#include "FFIELDS.h"
#ifdef ALLOW_GENERIC_ADVDIFF
# include "GAD.h"
#endif
#ifdef ALLOW_NONHYDROSTATIC
# include "NH_VARS.h"
#endif
#ifdef ALLOW_MNC
# include "MNC_PARAMS.h"
#endif
#if defined(ALLOW_EDDYPSI)  defined(ALLOW_GMREDI)
# include "GMREDI.h"
#endif

C     !INPUT PARAMETERS:
C     permPickup      :: Is or is not a permanent pickup.
C     suffix          :: pickup-name suffix
C     myTime          :: Current time of simulation ( s )
C     myIter          :: Iteration number
C     myThid          :: Thread number for this instance of the routine.
      LOGICAL permPickup
      CHARACTER*(*) suffix
      _RL     myTime
      INTEGER myIter
      INTEGER myThid
CEOP

C     !LOCAL VARIABLES:
C     fp          :: pickup-file precision
C     glf         :: local flag for "globalFiles"
C     fn          :: Temp. for building file name.
C     nWrFlds     :: number of fields being written
C     n3D         :: number of 3-D fields being written
C     listDim     :: dimension of "wrFldList" local array
C     wrFldList   :: list of written fields
C     m1,m2       :: 6.th dim index (AB-3) corresponding to time-step N-1 & N-2
C     j           :: loop index / field number
C     nj          :: record number
C     msgBuf      :: Informational/error message buffer
      INTEGER fp
      LOGICAL  glf
      _RL      timList(1)
      CHARACTER*(MAX_LEN_FNAM) fn
      INTEGER listDim, nWrFlds, n3D
      PARAMETER( listDim = 20 )
      CHARACTER*(8) wrFldList(listDim)
#ifdef ALLOW_ADAMSBASHFORTH_3
      INTEGER m1, m2
#endif
      INTEGER j, nj
      CHARACTER*(MAX_LEN_MBUF) msgBuf
#ifndef ALLOW_GENERIC_ADVDIFF
      LOGICAL AdamsBashforthGt
      LOGICAL AdamsBashforthGs
      LOGICAL AdamsBashforth_T
      LOGICAL AdamsBashforth_S
      PARAMETER ( AdamsBashforthGt = .FALSE. ,
     &            AdamsBashforthGs = .FALSE. ,
     &            AdamsBashforth_T = .FALSE. ,
     &            AdamsBashforth_S = .FALSE. )
#endif

C-    Initialise:
      DO j=1,listDim
        wrFldList(j) = ' '
      ENDDO

C     Write model fields

C     Going to really do some IO. Make everyone except master thread wait.
C     this is done within IO routines => no longer needed
c     _BARRIER

      IF (pickup_write_mdsio) THEN

        WRITE(fn,'(A,A)') 'pickup.', suffix
        fp = precFloat64
        j  = 0
C     record number < 0 : a hack not to write meta files now:

C---  write State 3-D fields for restart
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, uVel,   -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'Uvel    '
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, vVel,   -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'Vvel    '

#if defined(ALLOW_EDDYPSI)  defined(ALLOW_GMREDI)
        IF (GM_InMomAsStress) THEN
          j = j + 1
          CALL WRITE_REC_3D_RL( fn, fp, Nr, uEulerMean,
     &                                            -j, myIter, myThid )
          IF (j.LE.listDim) wrFldList(j) = 'UEulerM '
          j = j + 1
          CALL WRITE_REC_3D_RL( fn, fp, Nr, vEulerMean,
     &                                            -j, myIter, myThid )
          IF (j.LE.listDim) wrFldList(j) = 'VEulerM '
      ENDIF
#endif

        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, theta,  -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'Theta   '
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, salt,   -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'Salt    '
C---  write 3-D fields for AB-restart
#ifdef ALLOW_ADAMSBASHFORTH_3
        m1 = 1 + MOD(myIter+1,2)
        m2 = 1 + MOD( myIter ,2)
      IF ( momStepping ) THEN
C--   U velocity:
       IF ( alph_AB.NE.0. .OR. beta_AB.NE.0. ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, guNm(1-OLx,1-OLy,1,1,1,m1),
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'GuNm1   '
       ENDIF
       IF ( beta_AB.NE.0. ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, guNm(1-OLx,1-OLy,1,1,1,m2),
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'GuNm2   '
       ENDIF
C--   V velocity:
       IF ( alph_AB.NE.0. .OR. beta_AB.NE.0. ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gvNm(1-OLx,1-OLy,1,1,1,m1),
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'GvNm1   '
       ENDIF
       IF ( beta_AB.NE.0. ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gvNm(1-OLx,1-OLy,1,1,1,m2),
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'GvNm2   '
       ENDIF
      ENDIF
C--   Temperature:
      IF ( AdamsBashforthGt.OR.AdamsBashforth_T ) THEN
       IF ( alph_AB.NE.0. .OR. beta_AB.NE.0. ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gtNm(1-OLx,1-OLy,1,1,1,m1),
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) THEN
         IF ( AdamsBashforthGt ) wrFldList(j) = 'GtNm1   '
         IF ( AdamsBashforth_T ) wrFldList(j) = 'TempNm1 '
        ENDIF
       ENDIF
       IF ( beta_AB.NE.0. ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gtNm(1-OLx,1-OLy,1,1,1,m2),
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) THEN
         IF ( AdamsBashforthGt ) wrFldList(j) = 'GtNm2   '
         IF ( AdamsBashforth_T ) wrFldList(j) = 'TempNm2 '
        ENDIF
       ENDIF
      ENDIF
C--   Salinity:
      IF ( AdamsBashforthGs.OR.AdamsBashforth_S ) THEN
       IF ( alph_AB.NE.0. .OR. beta_AB.NE.0. ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gsNm(1-OLx,1-OLy,1,1,1,m1),
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) THEN
         IF ( AdamsBashforthGs ) wrFldList(j) = 'GsNm1   '
         IF ( AdamsBashforth_S ) wrFldList(j) = 'SaltNm1 '
        ENDIF
       ENDIF
       IF ( beta_AB.NE.0. ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gsNm(1-OLx,1-OLy,1,1,1,m2),
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) THEN
         IF ( AdamsBashforthGs ) wrFldList(j) = 'GsNm2   '
         IF ( AdamsBashforth_S ) wrFldList(j) = 'SaltNm2 '
        ENDIF
       ENDIF
      ENDIF
#ifdef ALLOW_NONHYDROSTATIC
C--   W velocity:
      IF ( nonHydrostatic ) THEN
       IF ( alph_AB.NE.0. .OR. beta_AB.NE.0. ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gwNm(1-OLx,1-OLy,1,1,1,m1),
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'GwNm1   '
       ENDIF
       IF ( beta_AB.NE.0. ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gwNm(1-OLx,1-OLy,1,1,1,m2),
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'GwNm2   '
       ENDIF
      ENDIF
#endif /* ALLOW_NONHYDROSTATIC */
#else /*  ALLOW_ADAMSBASHFORTH_3 */
       IF ( momStepping ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, guNm1,  -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'GuNm1   '
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gvNm1,  -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'GvNm1   '
       ENDIF
       IF ( AdamsBashforthGt.OR.AdamsBashforth_T ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gtNm1,  -j, myIter, myThid )
        IF (j.LE.listDim) THEN
         IF ( AdamsBashforthGt ) wrFldList(j) = 'GtNm1   '
         IF ( AdamsBashforth_T ) wrFldList(j) = 'TempNm1 '
        ENDIF
       ENDIF
       IF ( AdamsBashforthGs.OR.AdamsBashforth_S ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gsNm1,  -j, myIter, myThid )
        IF (j.LE.listDim) THEN
         IF ( AdamsBashforthGs ) wrFldList(j) = 'GsNm1   '
         IF ( AdamsBashforth_S ) wrFldList(j) = 'SaltNm1 '
        ENDIF
       ENDIF
#ifdef ALLOW_NONHYDROSTATIC
       IF ( nonHydrostatic ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, gwNm1,  -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'GwNm1   '
       ENDIF
#endif /* ALLOW_NONHYDROSTATIC */
#endif /*  ALLOW_ADAMSBASHFORTH_3 */

C-    write Full Pressure for EOS in pressure:
       IF ( storePhiHyd4Phys ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr,totPhiHyd,-j,myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'PhiHyd  '
       ENDIF
#ifdef ALLOW_NONHYDROSTATIC
       IF ( use3Dsolver ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, phi_nh, -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'Phi_NHyd'
       ENDIF
#endif /* ALLOW_NONHYDROSTATIC */
#ifdef ALLOW_ADDFLUID
C-    write mass source/sink of fluid (but not needed if selectAddFluid=-1)
       IF ( selectAddFluid.NE.0 ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RL( fn, fp, Nr, addMass,-j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'AddMass '
       ENDIF
#endif /* ALLOW_ADDFLUID */
#ifdef ALLOW_FRICTION_HEATING
C-    needs frictional heating when using synchronous time-stepping
       IF ( addFrictionHeating .AND. .NOT.staggerTimeStep ) THEN
        j = j + 1
        CALL WRITE_REC_3D_RS( fn, fp, Nr, frictionHeating,
     &                                            -j, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'FricHeat'
       ENDIF
#endif /* ALLOW_FRICTION_HEATING */

        n3D = j
C---  Write 2-D fields, starting with Eta:
        j = j + 1
        nj = -( n3D*(Nr-1) + j )
        CALL WRITE_REC_3D_RL( fn, fp, 1 , etaN,   nj, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'EtaN    '
#ifdef ALLOW_NONHYDROSTATIC
       IF ( selectNHfreeSurf.GE.1 ) THEN
        j = j + 1
        nj = -( n3D*(Nr-1) + j )
        CALL WRITE_REC_3D_RL( fn, fp, 1, dPhiNH,  nj, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'dPhiNH  '
       ENDIF
#endif /* ALLOW_NONHYDROSTATIC */
#ifdef EXACT_CONSERV
c      IF ( exactConserv ) THEN
        j = j + 1
        nj = -( n3D*(Nr-1) + j )
        CALL WRITE_REC_3D_RL( fn, fp, 1, dEtaHdt, nj, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'dEtaHdt '
c      ENDIF
C- note: always write dEtaHdt & EtaH but read only if exactConserv & nonlinFreeSurf
C        this works only because nonlinFreeSurf > 0 => exactConserv=T
c      IF ( nonlinFreeSurf.GT.0 ) THEN
        j = j + 1
        nj = -( n3D*(Nr-1) + j )
        CALL WRITE_REC_3D_RL( fn, fp, 1, etaHnm1, nj, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'EtaH    '
c      ENDIF
#endif /* EXACT_CONSERV */
C--------------------------
        nWrFlds = j
        IF ( nWrFlds.GT.listDim ) THEN
          WRITE(msgBuf,'(2A,I5,A)') 'WRITE_PICKUP: ',
     &     'trying to write ',nWrFlds,' fields'
          CALL PRINT_ERROR( msgBuf, myThid )
          WRITE(msgBuf,'(2A,I5,A)') 'WRITE_PICKUP: ',
     &     'field-list dimension (listDim=',listDim,') too small'
          CALL PRINT_ERROR( msgBuf, myThid )
          STOP 'ABNORMAL END: S/R WRITE_PICKUP (list-size Pb)'
        ENDIF
#ifdef ALLOW_MDSIO
C-    Note: temporary: since it is a pain to add more arguments to
C     all MDSIO S/R, uses instead this specific S/R to write only
C     meta files but with more informations in it.
        nj = ABS(nj)
        glf  = globalFiles
        timList(1) = myTime
        CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE.,
     &                         0, 0, 1, ' ',
     &                         nWrFlds, wrFldList,
     &                         1, timList, oneRL,
     &                         nj, myIter, myThid )
#endif /* ALLOW_MDSIO */
C--------------------------
      ENDIF

#ifdef ALLOW_MNC
      IF (useMNC .AND. pickup_write_mnc) THEN
        IF ( permPickup ) THEN
          WRITE(fn,'(A)') 'pickup'
        ELSE
          WRITE(fn,'(A,A)') 'pickup.',checkPtSuff(nCheckLev)
        ENDIF
C       First ***define*** the file group name
        CALL MNC_CW_SET_UDIM(fn, 0, myThid)
        IF ( permPickup ) THEN
          CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, 0, myThid)
        ELSE
          CALL MNC_CW_SET_CITER(fn, 2, -1, -1, -1, myThid)
        ENDIF
C       Then set the actual unlimited dimension
        CALL MNC_CW_SET_UDIM(fn, 1, myThid)
        CALL MNC_CW_RL_W_S('D',fn,0,0,'T', myTime, myThid)
        CALL MNC_CW_I_W_S('I',fn,0,0,'iter', myIter, myThid)
        CALL MNC_CW_RL_W('D',fn,0,0,'U', uVel, myThid)
        CALL MNC_CW_RL_W('D',fn,0,0,'V', vVel, myThid)
#if defined(ALLOW_EDDYPSI)  defined(ALLOW_GMREDI)
        IF (GM_InMomAsStress) THEN
          CALL MNC_CW_RL_W('D',fn,0,0,'UEulerM', uEulerMean, myThid)
          CALL MNC_CW_RL_W('D',fn,0,0,'VEulerM', vEulerMean, myThid)
        ENDIF
#endif
        CALL MNC_CW_RL_W('D',fn,0,0,'Temp', theta, myThid)
        CALL MNC_CW_RL_W('D',fn,0,0,'S', salt, myThid)
        CALL MNC_CW_RL_W('D',fn,0,0,'Eta', etaN, myThid)
#ifndef ALLOW_ADAMSBASHFORTH_3
        CALL MNC_CW_RL_W('D',fn,0,0,'gUnm1', guNm1, myThid)
        CALL MNC_CW_RL_W('D',fn,0,0,'gVnm1', gvNm1, myThid)
        CALL MNC_CW_RL_W('D',fn,0,0,'gTnm1', gtNm1, myThid)
        CALL MNC_CW_RL_W('D',fn,0,0,'gSnm1', gsNm1, myThid)
#endif /* ALLOW_ADAMSBASHFORTH_3 */
#ifdef EXACT_CONSERV
        CALL MNC_CW_RL_W('D',fn,0,0,'dEtaHdt', dEtaHdt, myThid)
        CALL MNC_CW_RL_W('D',fn,0,0,'EtaH', etaHnm1, myThid)
#endif
#ifdef ALLOW_NONHYDROSTATIC
        IF ( use3Dsolver ) THEN
          CALL MNC_CW_RL_W('D',fn,0,0,'phi_nh', phi_nh, myThid)
c         CALL MNC_CW_RL_W('D',fn,0,0,'gW', gW, myThid)
#ifndef ALLOW_ADAMSBASHFORTH_3
          CALL MNC_CW_RL_W('D',fn,0,0,'gWnm1', gwNm1, myThid)
#endif
        ENDIF
#endif
        IF ( storePhiHyd4Phys ) THEN
          CALL MNC_CW_RL_W('D',fn,0,0,'phiHyd', totPhiHyd, myThid)
        ENDIF
        CALL MNC_FILE_CLOSE_ALL_MATCHING(fn, myThid)
      ENDIF
#endif /*  ALLOW_MNC  */

C--   Every one else must wait until writing is done.
C     this is done within IO routines => no longer needed
c     _BARRIER

      RETURN
      END