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