C $Header: /u/gcmpack/MITgcm/pkg/ptracers/ptracers_read_pickup.F,v 1.14 2010/01/02 23:42:51 jmc Exp $
C $Name: $
#include "GAD_OPTIONS.h"
#include "PTRACERS_OPTIONS.h"
CBOP
C !ROUTINE: PTRACERS_READ_PICKUP
C !INTERFACE:
SUBROUTINE PTRACERS_READ_PICKUP( myIter, myThid )
C !DESCRIPTION:
C Reads current state of passive tracers from 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_RESTART.h"
#include "PTRACERS_FIELDS.h"
C !INPUT PARAMETERS:
C myIter :: time-step number
C myThid :: thread number
INTEGER myIter
INTEGER myThid
#ifdef ALLOW_PTRACERS
C !LOCAL VARIABLES:
C iTracer :: tracer index
C iRec :: record number
C fn :: character buffer for creating filename
C prec :: precision of pickup files
C filePrec :: pickup-file precision (read from meta file)
C nbFields :: number of fields in pickup file (read from meta file)
C fldName :: Name of the field to read
C missFldList :: List of missing fields (attempted to read but not found)
C missFldDim :: Dimension of missing fields list array: missFldList
C nMissing :: Number of missing fields (attempted to read but not found)
C j :: loop index
C nj :: record number
C ioUnit :: temp for writing msg unit
C msgBuf :: Informational/error message buffer
INTEGER iTracer, iRec, prec
INTEGER filePrec, nbFields
INTEGER missFldDim, nMissing
INTEGER nj, ioUnit
PARAMETER( missFldDim = 2*PTRACERS_num )
CHARACTER*(MAX_LEN_FNAM) fn
CHARACTER*(8) fldName, missFldList(missFldDim)
CHARACTER*(MAX_LEN_MBUF) msgBuf
#ifdef PTRACERS_ALLOW_DYN_STATE
INTEGER n
#endif
CEOP
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
#ifdef ALLOW_MNC
IF ( PTRACERS_pickup_read_mnc ) THEN
C Read variables from the pickup file
WRITE(fn,'(a)') 'pickup_ptracers'
CALL MNC_FILE_CLOSE_ALL_MATCHING(fn, myThid)
CALL MNC_CW_SET_UDIM(fn, 1, myThid)
CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, -1, myThid)
DO iTracer = 1, PTRACERS_numInUse
CALL MNC_CW_RL_R('D',fn,0,0, PTRACERS_names(iTracer),
& gpTrNm1(1-OLx,1-OLy,1,1,1,iTracer),myThid)
CALL EXCH_3D_RL( gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
& Nr, myThid )
ENDDO
CALL MNC_CW_SET_UDIM(fn, 2, myThid)
DO iTracer = 1, PTRACERS_numInUse
CALL MNC_CW_RL_R('D',fn,0,0, PTRACERS_names(iTracer),
& pTracer(1-OLx,1-OLy,1,1,1,iTracer),myThid)
CALL EXCH_3D_RL( pTracer(1-Olx,1-Oly,1,1,1,iTracer),
& Nr, myThid )
ENDDO
ENDIF
IF ( useMNC .AND. PTRACERS_pickup_read_mnc ) THEN
DO iTracer = 1, PTRACERS_numInUse
IF ( PTRACERS_SOM_Advection(iTracer) ) THEN
WRITE(msgBuf,'(3A)')'PTRACERS_READ_PICKUP: MNC not yet coded',
& ' for SOM advection',
& ' => read bin file instead'
CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
& SQUEEZE_RIGHT, myThid)
ENDIF
ENDDO
ENDIF
#endif /* ALLOW_MNC */
IF ( PTRACERS_pickup_read_mdsio ) THEN
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
IF ( pickupSuff.EQ.' ' ) THEN
WRITE(fn,'(A,I10.10)') 'pickup_ptracers.',myIter
ELSE
WRITE(fn,'(A,A10)') 'pickup_ptracers.',pickupSuff
ENDIF
prec = precFloat64
CALL READ_MFLDS_SET(
I fn,
O nbFields, filePrec,
I Nr, myIter, myThid )
_BEGIN_MASTER( myThid )
c IF ( filePrec.NE.0 .AND. filePrec.NE.prec ) THEN
IF ( nbFields.GE.0 .AND. filePrec.NE.prec ) THEN
WRITE(msgBuf,'(2A,I4)') 'PTRACERS_READ_PICKUP: ',
& 'pickup-file binary precision do not match !'
CALL PRINT_ERROR( msgBuf, myThid )
WRITE(msgBuf,'(A,2(A,I4))') 'PTRACERS_READ_PICKUP: ',
& 'file prec.=', filePrec, ' but expecting prec.=', prec
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R PTRACERS_READ_PICKUP (data-prec Pb)'
ENDIF
_END_MASTER( myThid )
IF ( nbFields.LE.0 ) THEN
C- No meta-file or old meta-file without List of Fields
ioUnit = errorMessageUnit
IF ( pickupStrictlyMatch ) THEN
WRITE(msgBuf,'(4A)') 'PTRACERS_READ_PICKUP: ',
& 'no field-list found in meta-file',
& ' => cannot check for strick-matching'
CALL PRINT_ERROR( msgBuf, myThid )
WRITE(msgBuf,'(4A)') 'PTRACERS_READ_PICKUP: ',
& 'try with " pickupStrictlyMatch=.FALSE.,"',
& ' in file: "data", NameList: "PARM03"'
CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
STOP 'ABNORMAL END: S/R PTRACERS_READ_PICKUP'
ELSE
WRITE(msgBuf,'(4A)') 'WARNING >> PTRACERS_READ_PICKUP: ',
& ' no field-list found'
CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
IF ( nbFields.EQ.-1 ) THEN
C- No meta-file
WRITE(msgBuf,'(4A)') 'WARNING >> ',
& ' try to read pickup as currently written'
CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
ELSE
C- Old meta-file without List of Fields
WRITE(msgBuf,'(4A)') 'WARNING >> ',
& ' try to read pickup as it used to be written'
CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
WRITE(msgBuf,'(4A)') 'WARNING >> ',
& ' until checkpoint59l (2007 Dec 17)'
CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
ENDIF
ENDIF
ENDIF
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C--- Very Old way to read ptracer pickup:
IF ( nbFields.EQ.0 .AND. usePickupBeforeC54 ) THEN
C Read fields as consecutive records
DO iTracer = 1, PTRACERS_numInUse
iRec = iTracer
CALL READ_REC_3D_RL( fn, prec, Nr,
O pTracer(1-Olx,1-Oly,1,1,1,iTracer),
I iRec, myIter, myThid )
CALL EXCH_3D_RL( pTracer(1-Olx,1-Oly,1,1,1,iTracer),
& Nr, myThid )
ENDDO
C Read historical tendencies as consecutive records
c DO iTracer = 1,PTRACERS_numInUse
c iRec = iTracer + PTRACERS_num
c CALL READ_REC_3D_RL( fn, prec, Nr,
c O gPtr(1-Olx,1-Oly,1,1,1,iTracer),
c I iRec, myIter, myThid )
c CALL EXCH_3D_RL( gPtr(1-Olx,1-Oly,1,1,1,iTracer),
c & Nr, myThid )
c ENDDO
DO iTracer = 1, PTRACERS_numInUse
iRec = iTracer + PTRACERS_num*2
CALL READ_REC_3D_RL( fn, prec, Nr,
O gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
I iRec, myIter, myThid )
CALL EXCH_3D_RL( gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
& Nr, myThid )
ENDDO
ELSEIF ( nbFields.EQ.0 ) THEN
C--- Old way to read ptracer pickup:
C Read fields & tendencies (needed for AB) as consecutive records,
C one tracer after the other, only for tracers "InUse". Note:
C this allow to restart from a pickup with a different number of
C tracers, with write_pickup dumping all of them (PTRACERS_num).
DO iTracer = 1, PTRACERS_numInUse
iRec = 2*iTracer -1
CALL READ_REC_3D_RL( fn, prec, Nr,
O pTracer(1-Olx,1-Oly,1,1,1,iTracer),
I iRec, myIter, myThid )
iRec = 2*iTracer
CALL READ_REC_3D_RL( fn, prec, Nr,
O gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
I iRec, myIter, myThid )
CALL EXCH_3D_RL( pTracer(1-Olx,1-Oly,1,1,1,iTracer),
& Nr, myThid )
CALL EXCH_3D_RL( gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
& Nr, myThid )
ENDDO
ELSE
C--- New way to read ptracer pickup:
nj = 0
DO iTracer = 1, PTRACERS_numInUse
C--- read pTracer 3-D fields for restart
fldName = 'pTr'//PTRACERS_ioLabel(iTracer)//' '
CALL READ_MFLDS_3D_RL( fldName,
O pTracer(1-Olx,1-Oly,1,1,1,iTracer),
& nj, prec, Nr, myIter, myThid )
CALL EXCH_3D_RL( pTracer(1-Olx,1-Oly,1,1,1,iTracer),
& Nr, myThid )
ENDDO
DO iTracer = 1, PTRACERS_numInUse
C--- read pTracer 3-D tendencies for AB-restart
IF ( PTRACERS_AdamsBashGtr(iTracer) ) THEN
fldName = 'gPtr'//PTRACERS_ioLabel(iTracer)//'m1'
CALL READ_MFLDS_3D_RL( fldName,
O gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
& nj, prec, Nr, myIter, myThid )
CALL EXCH_3D_RL( gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
& Nr, myThid )
ENDIF
ENDDO
C-- end: new way to read pickup file
ENDIF
C-- Check for missing fields:
nMissing = missFldDim
CALL READ_MFLDS_CHECK(
O missFldList,
U nMissing,
I myIter, myThid )
IF ( nMissing.GT.missFldDim ) THEN
WRITE(msgBuf,'(2A,I4)') 'PTRACERS_READ_PICKUP: ',
& 'missing fields list has been truncated to', missFldDim
CALL PRINT_ERROR( msgBuf, myThid )
STOP 'ABNORMAL END: S/R PTRACERS_READ_PICKUP (list-size Pb)'
ENDIF
CALL PTRACERS_CHECK_PICKUP(
I missFldList,
I nMissing, nbFields,
I myIter, myThid )
#ifdef PTRACERS_ALLOW_DYN_STATE
C-- Read pickup file with 2nd.Order moment fields
DO iTracer = 1, PTRACERS_numInUse
IF ( PTRACERS_SOM_Advection(iTracer) ) THEN
IF (pickupSuff .EQ. ' ') THEN
WRITE(fn,'(3A,I10.10)') 'pickup_somTRAC',
& PTRACERS_ioLabel(iTracer),'.', myIter
ELSE
WRITE(fn,'(3A,A10)') 'pickup_somTRAC',
& PTRACERS_ioLabel(iTracer),'.', pickupSuff
ENDIF
WRITE(msgBuf,'(A,I3,A)')'PTRACERS_READ_PICKUP: iTracer = ',
& iTracer,
& ' : reading 2nd-order moments from file '
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
& SQUEEZE_RIGHT, myThid)
CALL PRINT_MESSAGE( fn, standardMessageUnit,
& SQUEEZE_RIGHT, myThid)
prec = precFloat64
C Read 2nd Order moments as consecutive records
DO n=1,nSOM
iRec = n
CALL READ_REC_3D_RL( fn, prec, Nr,
O _Ptracers_som(:,:,:,:,:,n,iTracer),
I iRec, myIter, myThid )
ENDDO
CALL GAD_EXCH_SOM( _Ptracers_som(:,:,:,:,:,:,iTracer),
& Nr, myThid )
ENDIF
ENDDO
#endif /* PTRACERS_ALLOW_DYN_STATE */
C-- end: pickup_read_mdsio
ENDIF
#endif /* ALLOW_PTRACERS */
RETURN
END