C $Header: /u/gcmpack/MITgcm/pkg/ptracers/ptracers_read_pickup.F,v 1.18 2017/03/24 23:48:33 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_START.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*(10) suff CHARACTER*(MAX_LEN_FNAM) fn CHARACTER*(8) fldName, missFldList(missFldDim) CHARACTER*(MAX_LEN_MBUF) msgBuf #ifdef PTRACERS_ALLOW_DYN_STATE CHARACTER*(MAX_LEN_FNAM) filNam LOGICAL useCurrentDir, fileExist 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 */ C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| IF ( PTRACERS_pickup_read_mdsio ) THEN IF ( pickupSuff.EQ.' ' ) THEN IF ( rwSuffixType.EQ.0 ) THEN WRITE(fn,'(A,I10.10)') 'pickup_ptracers.', myIter ELSE CALL RW_GET_SUFFIX( suff, startTime, myIter, myThid ) WRITE(fn,'(A,A)') 'pickup_ptracers.', suff ENDIF 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) .OR. & PTRACERS_AdamsBash_Tr(iTracer) ) THEN IF ( PTRACERS_AdamsBashGtr(iTracer) ) & fldName = 'gPtr'//PTRACERS_ioLabel(iTracer)//'m1' IF ( PTRACERS_AdamsBash_Tr(iTracer) ) & fldName = 'pTr'//PTRACERS_ioLabel(iTracer)//'Nm1' 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 ) C-- end: pickup_read_mdsio ENDIF C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| #ifdef PTRACERS_ALLOW_DYN_STATE c IF ( PTRACERS_pickup_read_mdsio ) THEN C-- Read pickup file with 2nd.Order moment fields prec = precFloat64 DO iTracer = 1, PTRACERS_numInUse IF ( PTRACERS_SOM_Advection(iTracer) ) THEN IF ( pickupSuff.EQ.' ' ) THEN IF ( rwSuffixType.EQ.0 ) THEN WRITE(fn,'(3A,I10.10)') 'pickup_somTRAC', & PTRACERS_ioLabel(iTracer),'.', myIter ELSE CALL RW_GET_SUFFIX( suff, startTime, myIter, myThid ) WRITE(fn,'(3A,A)') 'pickup_somTRAC', & PTRACERS_ioLabel(iTracer),'.', suff ENDIF ELSE WRITE(fn,'(3A,A10)') 'pickup_somTRAC', & PTRACERS_ioLabel(iTracer),'.', pickupSuff ENDIF ioUnit = standardMessageUnit WRITE(msgBuf,'(A,I3,A)')'PTRACERS_READ_PICKUP: iTracer = ', & iTracer, ' : reading 2nd-order moments from file:' CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid ) CALL PRINT_MESSAGE( fn, ioUnit, SQUEEZE_RIGHT, myThid ) C- First check if pickup file exist #ifdef ALLOW_MDSIO useCurrentDir = .FALSE. CALL MDS_CHECK4FILE( I fn, '.data', 'PTRACERS_READ_PICKUP', O filNam, fileExist, I useCurrentDir, myThid ) #else STOP 'ABNORMAL END: S/R PTRACERS_READ_PICKUP: Needs MDSIO pkg' #endif IF ( fileExist ) THEN 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 ) ELSE ioUnit = errorMessageUnit IF ( pickupStrictlyMatch ) THEN 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,'(2A)') 'WARNING >> PTRACERS_READ_PICKUP: ', & 'approximated restart: reset Ptr_SOM to zero' CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid ) ENDIF ENDIF ENDIF ENDDO C-- end: pickup_read_mdsio, SOM pickups c ENDIF #endif /* PTRACERS_ALLOW_DYN_STATE */ #endif /* ALLOW_PTRACERS */ RETURN END