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