C $Header: /u/gcmpack/MITgcm/pkg/ptracers/ptracers_write_pickup.F,v 1.16 2014/08/18 14:34:27 jmc Exp $
C $Name:  $

#include "GAD_OPTIONS.h"
#include "PTRACERS_OPTIONS.h"

CBOP
C !ROUTINE: PTRACERS_WRITE_PICKUP

C !INTERFACE: ==========================================================
      SUBROUTINE PTRACERS_WRITE_PICKUP( permCheckPoint,
     &                    suff, myTime, myIter, myThid )

C !DESCRIPTION:
C     Writes current state of passive tracers to a pickup file

C !USES: ===============================================================
#include "PTRACERS_MOD.h"
      IMPLICIT NONE
#include "SIZE.h"
#include "EEPARAMS.h"
#include "PARAMS.h"
#include "GAD.h"
#include "PTRACERS_SIZE.h"
#include "PTRACERS_PARAMS.h"
#include "PTRACERS_FIELDS.h"

C !INPUT PARAMETERS: ===================================================
C     permCheckPoint  :: permanent or a rolling checkpoint
C     suff            :: suffix for pickup file (eg. ckptA or 0000000010)
C     myTime          :: model time
C     myIter          :: time-step number
C     myThid          :: thread number
      LOGICAL permCheckPoint
      CHARACTER*(*) suff
      _RL myTime
      INTEGER myIter
      INTEGER myThid

C !OUTPUT PARAMETERS: ==================================================
C  none

#ifdef ALLOW_PTRACERS

C     === Functions ====
      INTEGER  ILNBLNK
      EXTERNAL 

C !LOCAL VARIABLES: ====================================================
C     iTracer     :: tracer index
C     j           :: loop index / field number
C     prec        :: pickup-file precision
C     glf         :: local flag for "globalFiles"
C     fn          :: character buffer for creating filename
C     nWrFlds     :: number of fields being written
C     listDim     :: dimension of "wrFldList" local array
C     wrFldList   :: list of written fields
C     msgBuf      :: Informational/error message buffer
      INTEGER iTracer, j, prec, lChar
      LOGICAL glf
      _RL     timList(1)
      CHARACTER*(MAX_LEN_FNAM) fn
      INTEGER listDim, nWrFlds
      PARAMETER( listDim = 3*PTRACERS_num )
      CHARACTER*(8) wrFldList(listDim)
      CHARACTER*(MAX_LEN_MBUF) msgBuf
#ifdef PTRACERS_ALLOW_DYN_STATE
      INTEGER n, iRec
#endif
CEOP

#ifdef ALLOW_MNC
      IF ( PTRACERS_pickup_write_mnc ) THEN
        IF ( permCheckPoint ) THEN
          WRITE(fn,'(A)') 'pickup_ptracers'
        ELSE
          lChar = ILNBLNK(suff)
          WRITE(fn,'(2A)') 'pickup_ptracers.', suff(1:lChar)
        ENDIF
        CALL MNC_FILE_CLOSE_ALL_MATCHING(fn, myThid)
C       First ***define*** the file group name
        CALL MNC_CW_SET_UDIM(fn, 1, myThid)
        IF ( permCheckPoint ) THEN
          CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, -1, 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)
C       The following two values should probably be for the n-1 time
C       step since we are saving the gpTrNm1 variable first
        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)
        DO iTracer = 1,PTRACERS_numInUse
          CALL MNC_CW_RL_W('D',fn,0,0, PTRACERS_names(iTracer),
     &         gpTrNm1(1-OLx,1-OLy,1,1,1,iTracer),myThid)
        ENDDO
        CALL MNC_CW_SET_UDIM(fn, 2, 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)
        DO iTracer = 1,PTRACERS_numInUse
          CALL MNC_CW_RL_W('D',fn,0,0, PTRACERS_names(iTracer),
     &         pTracer(1-OLx,1-OLy,1,1,1,iTracer),myThid)
        ENDDO
      ENDIF
      IF ( useMNC .AND. PTRACERS_pickup_write_mnc ) THEN
       DO iTracer = 1, PTRACERS_numInUse
        IF ( PTRACERS_SOM_Advection(iTracer) ) THEN
         WRITE(msgBuf,'(3A)')'PTRACERS_WRITE_PICKUP: MNC not yet coded',
     &                       ' for SOM advection',
     &                       ' => write bin file instead'
         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &                       SQUEEZE_RIGHT, myThid)
        ENDIF
       ENDDO
      ENDIF
#endif /*  ALLOW_MNC  */

      lChar = ILNBLNK(suff)
      IF ( PTRACERS_pickup_write_mdsio ) THEN

        IF ( lChar.EQ.0 ) THEN
          WRITE(fn,'(2A)') 'pickup_ptracers'
        ELSE
          WRITE(fn,'(2A)') 'pickup_ptracers.',suff(1:lChar)
        ENDIF
        prec = precFloat64

C       Firstly, write ptracer fields as consecutive records,
C       one tracer after the other, for all tracers "InUse".

        j  = 0
C     record number < 0 : a hack not to write meta files now:
        DO iTracer = 1, PTRACERS_numInUse
          j = j + 1
          CALL WRITE_REC_3D_RL( fn, prec, Nr,
     &         pTracer(1-OLx,1-OLy,1,1,1,iTracer),
     &         -j, myIter, myThid )
          IF (j.LE.listDim)
     &      wrFldList(j) = 'pTr'//PTRACERS_ioLabel(iTracer)//'   '
        ENDDO

C       Then write ptracer tendencies (if this tracer is using AB time-stepping)
        DO iTracer = 1, PTRACERS_numInUse
         IF ( PTRACERS_AdamsBashGtr(iTracer) .OR.
     &        PTRACERS_AdamsBash_Tr(iTracer) ) THEN
          j = j + 1
          CALL WRITE_REC_3D_RL( fn, prec, Nr,
     &         gpTrNm1(1-OLx,1-OLy,1,1,1,iTracer),
     &         -j, myIter, myThid )
          IF ( j.LE.listDim .AND. PTRACERS_AdamsBashGtr(iTracer) )
     &      wrFldList(j) = 'gPtr'//PTRACERS_ioLabel(iTracer)//'m1'
          IF ( j.LE.listDim .AND. PTRACERS_AdamsBash_Tr(iTracer) )
     &      wrFldList(j) = 'pTr'//PTRACERS_ioLabel(iTracer)//'Nm1'
         ENDIF

        ENDDO

C--------------------------
        nWrFlds = j
        IF ( nWrFlds.GT.listDim ) THEN
          WRITE(msgBuf,'(2A,I5,A)') 'PTRACERS_WRITE_PICKUP: ',
     &     'trying to write ',nWrFlds,' fields'
          CALL PRINT_ERROR( msgBuf, myThid )
          WRITE(msgBuf,'(2A,I5,A)') 'PTRACERS_WRITE_PICKUP: ',
     &     'field-list dimension (listDim=',listDim,') too small'
          CALL PRINT_ERROR( msgBuf, myThid )
          STOP 'ABNORMAL END: S/R PTRACERS_WRITE_PICKUP (list-size Pb)'
        ENDIF
#ifdef ALLOW_MDSIO
C     uses this specific S/R to write (with more informations) only meta files
        glf  = globalFiles
        timList(1) = myTime
        CALL MDS_WR_METAFILES( fn, prec, glf, .FALSE.,
     &                         0, 0, Nr, ' ',
     &                         nWrFlds, wrFldList,
     &                         1, timList, oneRL,
     &                         j, myIter, myThid )
#endif /* ALLOW_MDSIO */
C--------------------------
      ENDIF

#ifdef PTRACERS_ALLOW_DYN_STATE
C     write pickup for 2nd-order moment fields
C     we write a separate file for each Ptracer that uses SOM advection
        DO iTracer = 1, PTRACERS_numInUse
         IF ( PTRACERS_SOM_Advection(iTracer) ) THEN
          IF ( lChar.EQ.0 ) THEN
            WRITE(fn,'(2A)') 'pickup_somTRAC',PTRACERS_ioLabel(iTracer)
          ELSE
            WRITE(fn,'(4A)') 'pickup_somTRAC',PTRACERS_ioLabel(iTracer),
     &                       '.',suff(1:lChar)
          ENDIF
          _BEGIN_MASTER(myThid)
          WRITE(msgBuf,'(A,I4,A)')'PTRACERS_WRITE_PICKUP: iTracer =',
     &                       iTracer, ' : writing 2nd-order moments'
          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                        SQUEEZE_RIGHT, myThid )
          j = ILNBLNK(fn)
          WRITE(msgBuf,'(A,A)') ' to file: ',fn(1:j)
          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                        SQUEEZE_RIGHT, myThid )
          _END_MASTER(myThid)
          prec = precFloat64
C     Write 2nd Order moments as consecutive records
          DO n=1,nSOM
            iRec = n
            CALL WRITE_REC_3D_RL( fn, prec, Nr,
     I               _Ptracers_som(:,:,:,:,:,n,iTracer),
     I               iRec, myIter, myThid )
          ENDDO
         ENDIF
        ENDDO
#endif /* PTRACERS_ALLOW_DYN_STATE */

#endif /* ALLOW_PTRACERS */

      RETURN
      END