diff --git a/code/adjoint/CO_strat_pl_adj.f b/code/adjoint/CO_strat_pl_adj.f new file mode 100644 index 0000000..7c847bd --- /dev/null +++ b/code/adjoint/CO_strat_pl_adj.f @@ -0,0 +1,100 @@ +! $Id: CO_strat_pl_adj.f,v 1.1 2010/05/07 20:39:47 daven Exp $ + SUBROUTINE CO_STRAT_PL_ADJ( COPROD, COLOSS ) +! +!****************************************************************************** +! Subroutine CO_STRAT_PL_ADJ computes adjoint of net production of CO above +! annual mean tropopause using archived rates for P(CO) and L(CO). +! (dkh, 05/02/10) +! +! Based on forward model (bnd, qli, bmy, 12/9/99, 10/25/05) +! +! Arguments as Input: +! =========================================================================== +! (1 ) COPROD : (REAL*4) Zonally averaged P(CO) in [v/v/s] +! (2 ) COLOSS : (REAL*4) Zonally averaged L(CO) in [1/s] +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE DAO_MOD, ONLY : AD + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : XNUMOL, XNUMOLAIR + USE TRACERID_MOD, ONLY : IDTCO, IDTCH2O + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP, GET_MIN_TPAUSE_LEVEL + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*4, INTENT(IN) :: COPROD(JJPAR,LLPAR) + REAL*4, INTENT(IN) :: COLOSS(JJPAR,LLPAR) + + ! Local variables + INTEGER :: I, J, L, M, N, LMIN + + REAL*8 :: BAIRDENS, DT, GCO, STTTOGCO + + ! External functions + REAL*8, EXTERNAL :: BOXVL + + !================================================================= + ! CO_STRAT_PL_ADJ begins here! + !================================================================= + + ! Chemistry timestep [s] + DT = GET_TS_CHEM() * 60d0 + + !================================================================= + ! Loop over all stratospheric grid boxes ( L >= LPAUSE(I,J) ). + ! + ! Compute the net CO from the P(CO) and L(CO) rates that are + ! stored in the COPROD and COLOSS arrays. + ! + ! Unit conversion to/from [kg/box] and [molec/cm3] is required. + ! The conversion factor is STTTOGCO, which is given below. + ! + ! kg CO box | mole CO | 6.022e23 molec CO + ! ------- * -----------+-------------+------------------- + ! box BOXVL cm3 | 28e-3 kg CO | mole CO + ! + ! = molec CO + ! -------- + ! cm3 + !================================================================= + + ! Get the minimum extent of the tropopause + LMIN = GET_MIN_TPAUSE_LEVEL() + + DO L = LMIN, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Skip tropospheric grid boxes + IF ( ITS_IN_THE_TROP(I,J,L) ) CYCLE + + ! fwd code: + !STTTOGCO = 6.022d23 / ( 28d-3 * BOXVL(I,J,L) ) + !GCO = STT(I,J,L,IDTCO) * STTTOGCO + !GCO = GCO * ( 1d0 - COLOSS(J,L) * DT ) + + ! ( COPROD(J,L) * DT * BAIRDENS ) + !STT(I,J,L,IDTCO) = GCO / STTTOGCO + ! adj code (production does not affect adjoint): + STT_ADJ(I,J,L,IDTCO) = STT_ADJ(I,J,L,IDTCO) + & * ( 1d0 - COLOSS(J,L) * DT ) + + ! production does not affect adjoint + !STT(I,J,L,IDTCH2O) = STT(I,J,L,IDTCH2O) + + ! XNUMOL(IDTCO) / XNUMOL(IDTCH2O) * + ! COPROD(J,L) * BAIRDENS / + ! STTTOGCO + + + ENDDO + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE CO_STRAT_PL_ADJ diff --git a/code/adjoint/adj_arrays_mod.f b/code/adjoint/adj_arrays_mod.f new file mode 100644 index 0000000..f413a64 --- /dev/null +++ b/code/adjoint/adj_arrays_mod.f @@ -0,0 +1,4180 @@ +! $Id: adj_arrays_mod.f,v 1.26 2012/08/10 22:08:22 nicolas Exp $ + MODULE ADJ_ARRAYS_MOD +! +!****************************************************************************** +! Module ADJ_ARRAYS_MOD contains arrays for the GEOS-CHEM adjoint model, +! as well as routines to initialize, set, get, and destroy the arrays. +! These arrays are initialized at the beginning of the inverse driver. +! (mak, bmy, 3/14/06, 3/29/06, mak, 6/14/09) +! +! Module Variables: +! ============================================================================ +! (1 ) EMS_orig (REAL*8) : can store original emissions +! (2 ) FORCING (REAL*8) : holds (ym-yo)^2/err for all days +! (3 ) MOP_MOD_DIFF (REAL*8) : holds (ym-yo) for all days +! (4 ) MODEL_BIAS (REAL*8) : holds (ym-yo)/ym for all days +! (5 ) MODEL (REAL*8) : holds H(ym) +! (6 ) OBS (REAL*8) : holds h(yo) +! (7 ) COST_ARRAY (REAL*8) : holds J(I,J), assumes column obs +! (8 ) OBS_COUNT (REAL*8) : holds #obs/box +! (9 ) OBS_STT (REAL*4) : Array with psedudo observations +! (10) STT_ADJ (REAL*8) : Adjoint tracer array (STT equivalent in fwd) +! (11) CF_REGION (REAL*8) : Array with regional weight for pseudo obs and sensitivity +! (12) NOPT (INTEGER) : Size of control vector +! (13) N_CALC (INTEGER) : optimization iteration counter +! (14) N_CALC_STOP (INTEGER) : end iteration for current optimization +! (14bis) N_CALC_TOTAL (INTEGER) : total number of iterations in optimization +! (15) MMSCL (INTEGER) : number of temporal groups in control vector +! (17) FD_DIFF (INTEGER) : scaling for initial conditions +! (18) IFD (INTEGER) : lon gridbox for FD and debugging +! (19) LONFD (REAL*8) : lon for FD and debugging +! (20) JFD (INTEGER) : lat gridbox for FD and debugging +! (21) LATFD (REAL*8) : lat for FD and debugging +! (22) LFD (INTEGER) : vert level for FD and debugging +! (23) MFD (INTEGER) : temporal group for FD and debugging +! (24) NFD (INTEGER) : species for FD and debugging +! (25) EMSFD (INTEGER) : emission group for FD and debugging +! (26) COST FUNC (REAL*8) : scalar cost function +! (27) NOBS (INTEGER) : Number of obs datasets used +! (28) ICS_SF (REAL*8) : array of initial conditions +! (29) ICS_SF0 (REAL*8) : array of first guess for initial conditions +! (30) ICS_SF_DEFAULT (R*8) : scalar first guess for initial conditions +! (31) EMS_SF (REAL*8) : array of emission scaling +! (32) EMS_SF0 (REAL*8) : array of first guess for emission scaling +! (33) ICS_SF_DEFAULT (R*8) : Initial condition scaling factors at iteration 1 +! (34) ICS_SF_ADJ (REAL*8) : dJ/dICS_SF +! (35) EMS_SF_ADJ (REAL*8) : dJ/dEMS_SF +! (36) SAT (INTEGER) : number of sat data used +! (37) OBS_FREQ (INTEGER) : observation frequency, usually 60 (minutes) +! (38) DAYS (INTEGER) : number of days in simulation +! (39) DAY_OF_SIM (INTEGER) : day of the simulation, updated throughout +! (40) REG_PARAM_EMS(REAL*8) : regularization parameter for a priori/background term +! (41) REG_PARAM_ICS(REAL*8) : regularization parameter for a priori/background term +! (42) ICSFD (INTEGER) : initial condition species for FD tests +! (43) STT_ORIG (REAL*8) : Original unscaled values of STT +! (44) REMIS_ADJ (REAL*8) : Adjoint of REMIS +! (45) DEPSAV_ADJ (REAL*8) : Adjoint of DEPSAV +! (46) O3_PROF_SAV (REAL*8) : TOMS O3 profile from set_prof +! (47) EMS_ERROR (REAL*8) : standard error for for a priori/background term +! (48) OBS_THIS_SPECIES (L) : observe this species in cost function +! (49) OBS_THIS_TRACER (L) : observe this tracer in cost function +! (50) NSPAN (INTEGER) : total number of observations to include in CF +! (50) NOBS_CSPEC (INTEGER) : total number of species observed in CSPEC +! (51) IDCSPEC_ADJ (INTEGER) : index of species observed in CSPEC +! (52) ID2C (INTEGER) : reverse mapping of IDCSPEC_ADJ +! (53) OPT_THIS_TRACER (L) : Which tracer initial values to optimize, replace +! OPT_THIS_SPECIES +! (54) CNAME (CHARACTER) : names of species in cspec to observe +! (55) INV_NSPAN (REAL*8) : The inverse of NSPAN +! (56) EMS_ADJ (REAL*8) : dJ/dEMS +! (57) ICS_ERROR (REAL*8) : standard error for for a priori/background term +! (58) HMAX (INTEGER) : Total length of 1D gradient vector +! (59) VAR_FD (REAL*8) : Concentrations for chem adjoint debugging +! (60) RCONST_FD (REAL*8) : Reaction rates for chem adjoint debugging +! (61) TR_DDEP_CONV : Unit conversion array for ddep adjoint +! (62) CS_DDEP_CONV : Unit conversion array for ddep adjoint +! (63) TR_WDEP_CONV : Unit conversion array for Wdep adjoint +! (64) NOBS2NDEP : Mapping array from NOBS to drydep ID +! (65) NOBSCSPEC2NDEP : Mapping array from NOBS_CSPEC to drydep ID +! (66) NOBS2NWDEP : Mapping array from NOBS to wetdep ID +! (67) NTR2NOBS : Mapping array from NOBS to tracer (opposite TRACER_IND) +! (68) COV_ERROR_LY (REAL*8) : +! (69) COV_ERROR_LY (REAL*8) : +! (70) TEMP2 (REAL*8) : +! +! Module Routines: +! ============================================================================ +! ( 1) INIT_ADJ_EMS : Initializes adj ems arrays +! ( 2) INIT_TRACERID_ADJ : Zeroes all ems variables +! ( 3) TRACERID_ADJ : Defines adj tracers and emission ID numbers +! ( 4) INIT_ADJ_ARRAYS : Allocates & zeroes all module arrays +! ( 5) INIT_CF_REGION : Sets the domain for sensitivity/twin exp. runs +! ( 6) GET_CF_REGION : Gets regional cost function weight +! ( 7) ITS_TIME_FOR_OBS : Returns true if it's time for obs +! ( 8) CALC_NUM_SAT : Calculates # sat datasets (CO only now) +! ( 9) SET_EMS_ORIG : Writes a value into EMS_ORIG +! (10) GET_EMS_ORIG : Gets a value from EMS_ORIG +! (11) SET_FORCING : Writes a value into FORCING +! (12) GET_FORCING : Gets a value from FORCING +! (13) SET_MOP_MOD_DIFF : Writes a value into MOP_MOD_DIFF +! (14) GET_MOP_MOD_DIFFG : Gets a value from MOP_MOD_DIFF +! (15) SET_MODEL_BIAS : Writes a value into MODEL_BIAS +! (16) GET_MODEL_BIAS : Gets a value from MODEL_BIAS +! (17) SET_MODEL : Writes a value into MODEL +! (18) GET_MODEL : Gets a value from MODEL +! (19) SET_OBS : Writes a value into OBS +! (20) GET_OBS : Gets a value from OBS +! (21) CHECK_STT_ADJ : Checks STT_ADJ for NaNs and infinity +! (22) EXPAND_NAME : Replace NN token with current iteration +! (23) CLEANUP_ADJ_ARRAYS : Deallcoates all module arrays +! +! GEOS-Chem modules referenced by "adj_arrays_mod.f" +! ============================================================================ +! (1 ) "error_mod.f" : Module w/ NaN and error checks +! +! NOTES: +! (1 ) Clean up, make everthing public (mak, 6/14/09) +! (2 ) Move DIRECTION to time_mod.f (dkh, 04/28/10) +! (3 ) Now include CO2 emission ID #'s (dkh, 05/06/10) +! (4 ) Add EMS_SF_DEFAULT and ICS_SF_DEFAULT, EMS_ERROR, OBS_THIS_TRACER +! NSPAN, NOBS_CSPEC, IDCSPEC_ADJ, CNAME,INV_NSPAN, ICS_ERROR (dkh, 02/09/11) +! (5 ) Add EMS_ADJ (dkh, 02/17/11) +! (6 ) Add dust EMS_ADJ (xxu, dkh, 01/09/12, adj32_011) +! (7 ) add more VOCs (knl, dkh, 01/13/12, adj32_014) +! (8 ) Add support for strat chem adjoint (hml, dkh, 02/14/12, adj32_025) +! (9 ) Move VAR_FD and RCONST_FD here for dynamic allocation +! (dkh, 02/23/12, adj32_026) +! (10 ) Add N_CALC_TOTAL, which is the total number of iterations for the optimization +! Useful for L-BFGS inverse Hessian calculation (nab, 03/27/12 ) +!****************************************************************************** +! + IMPLICIT NONE + + + !================================================================= + ! MODULE PRIVATE DECLARATIONS + !================================================================= + + ! Make everything PUBLIC ... + PUBLIC + + !================================================================= + ! MODULE VARIABLES + !================================================================= + REAL*8, ALLOCATABLE :: EMS_orig(:,:,:) + REAL*8, ALLOCATABLE :: FORCING(:,:,:) + REAL*8, ALLOCATABLE :: MOP_MOD_DIFF(:,:,:) + REAL*8, ALLOCATABLE :: MODEL_BIAS(:,:,:,:) + REAL*8, ALLOCATABLE :: MODEL(:,:,:,:) + REAL*4, ALLOCATABLE :: SAT_DOFS(:,:,:,:) + REAL*8, ALLOCATABLE :: OBS(:,:,:,:) + REAL*8, ALLOCATABLE :: COST_ARRAY(:,:,:) + REAL*8, ALLOCATABLE :: OBS_COUNT(:,:) + REAL*4, ALLOCATABLE :: OBS_STT(:,:,:,:) + REAL*8, ALLOCATABLE :: STT_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: CF_REGION(:,:,:) + REAL*8, ALLOCATABLE :: ADJ_FORCE(:,:,:,:) + REAL*8, ALLOCATABLE :: SHIPO3DEP_ADJ(:,:) + + INTEGER :: NOPT + INTEGER :: N_CALC + INTEGER :: N_CALC_STOP + INTEGER :: N_CALC_TOTAL + + + ! FROM INPUT.GCADJ + INTEGER :: MMSCL + INTEGER :: NNEMS + REAL*8 :: FD_DIFF + INTEGER :: IFD + REAL*8 :: LONFD + INTEGER :: JFD + REAL*8 :: LATFD + INTEGER :: LFD + INTEGER :: MFD + INTEGER :: NFD + INTEGER :: EMSFD + INTEGER :: ICSFD + REAL*8 :: COST_FUNC + REAL*8, ALLOCATABLE :: COST_FUNC_SAV(:) + REAL*8, ALLOCATABLE :: STT_ADJ_FD(:) + INTEGER :: NOBS + INTEGER :: NSPAN + REAL*8 :: INV_NSPAN + INTEGER :: NOBS_CSPEC + + REAL*8, ALLOCATABLE :: ICS_SF(:,:,:,:) + REAL*8, ALLOCATABLE :: STT_ORIG(:,:,:,:) + REAL*8, ALLOCATABLE :: ICS_SF0(:,:,:,:) + !REAL*8 :: ICS_SF_tmp + REAL*8, ALLOCATABLE :: EMS_SF(:,:,:,:) + REAL*8, ALLOCATABLE :: EMS_SF0(:,:,:,:) + !REAL*8 :: EMS_SF_tmp + REAL*8, ALLOCATABLE :: ICS_SF_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: EMS_SF_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: TEMP2(:,:,:,:) + REAL*8, ALLOCATABLE :: EMS_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: REG_PARAM_EMS(:) + REAL*8, ALLOCATABLE :: REG_PARAM_ICS(:) + + INTEGER :: SAT + INTEGER :: OBS_FREQ + INTEGER, ALLOCATABLE:: ID_ADEMS(:) + LOGICAL, ALLOCATABLE:: OPT_THIS_TRACER(:) + LOGICAL, ALLOCATABLE:: OBS_THIS_SPECIES(:) + LOGICAL, ALLOCATABLE:: OBS_THIS_TRACER(:) + LOGICAL, ALLOCATABLE:: OPT_THIS_EMS(:) + CHARACTER(LEN=14), ALLOCATABLE :: ADEMS_NAME(:) + CHARACTER(LEN=14), ALLOCATABLE :: CNAME(:) + + REAL*8, ALLOCATABLE :: REMIS_ADJ(:,:) + REAL*8, ALLOCATABLE :: DEPSAV_ADJ(:,:,:) + + REAL*8, ALLOCATABLE :: O3_PROF_SAV(:,:,:) + + REAL*8, ALLOCATABLE :: ICS_SF_DEFAULT(:) + REAL*8, ALLOCATABLE :: EMS_SF_DEFAULT(:) + REAL*8, ALLOCATABLE :: IDCSPEC_ADJ(:) + REAL*8, ALLOCATABLE :: ID2C(:) + + ! added for apriori constraints (dkh, 01/11/11) + REAL*8, ALLOCATABLE :: EMS_ERROR(:) + REAL*8, ALLOCATABLE :: ICS_ERROR(:) + REAL*8, ALLOCATABLE :: COV_ERROR_LX(:), COV_ERROR_LY(:) + + INTEGER :: DAYS + INTEGER :: DAY_OF_SIM + + ! Strat prod and loss (hml, dkh, 02/14/12, adj32_025) + INTEGER :: NSTPL + INTEGER :: STRFD + REAL*8, ALLOCATABLE :: PROD_SF(:,:,:,:) + REAL*8, ALLOCATABLE :: PROD_SF0(:,:,:,:) + REAL*8, ALLOCATABLE :: PROD_SF_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: P_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: LOSS_SF(:,:,:,:) + REAL*8, ALLOCATABLE :: LOSS_SF0(:,:,:,:) + REAL*8, ALLOCATABLE :: LOSS_SF_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: k_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: REG_PARAM_PROD(:) + REAL*8, ALLOCATABLE :: REG_PARAM_LOSS(:) + + REAL*8, ALLOCATABLE :: VAR_FD(:,:) + REAL*8, ALLOCATABLE :: RCONST_FD(:,:) + + INTEGER, ALLOCATABLE:: ID_PROD(:) + INTEGER, ALLOCATABLE:: ID_LOSS(:) + LOGICAL, ALLOCATABLE:: OPT_THIS_PROD(:) + LOGICAL, ALLOCATABLE:: OPT_THIS_LOSS(:) + CHARACTER(LEN=14), ALLOCATABLE :: PROD_NAME(:) + CHARACTER(LEN=14), ALLOCATABLE :: LOSS_NAME(:) + REAL*8, ALLOCATABLE :: PROD_SF_DEFAULT(:) + REAL*8, ALLOCATABLE :: LOSS_SF_DEFAULT(:) + REAL*8, ALLOCATABLE :: PROD_ERROR(:) + REAL*8, ALLOCATABLE :: LOSS_ERROR(:) + + ! for wetdep adj (fp, dkh, 03/04/13) + REAL*8 :: ADJOINT_AREA_M2 + INTEGER, ALLOCATABLE:: TRACER_IND(:) + REAL*8, ALLOCATABLE :: NHX_ADJ_FORCE(:,:) + + REAL*8, ALLOCATABLE :: TR_DDEP_CONV(:,:) + REAL*8, ALLOCATABLE :: CS_DDEP_CONV(:,:) + REAL*8, ALLOCATABLE :: TR_WDEP_CONV(:,:) + INTEGER,ALLOCATABLE :: NOBS2NDEP(:) + INTEGER,ALLOCATABLE :: NOBSCSPEC2NDEP(:) + INTEGER,ALLOCATABLE :: NOBS2NWDEP(:) + INTEGER,ALLOCATABLE :: NTR2NOBS(:) + REAL*8, ALLOCATABLE :: DDEP_TRACER(:,:,:) + REAL*8, ALLOCATABLE :: DDEP_CSPEC(:,:,:) + REAL*8, ALLOCATABLE :: WDEP_CV(:,:,:) + REAL*8, ALLOCATABLE :: WDEP_LS(:,:,:) + REAL*8, ALLOCATABLE :: AD44_OLD(:,:,:) + REAL*8, ALLOCATABLE :: AD44_CSPEC_OLD(:,:,:) + REAL*8, ALLOCATABLE :: AD38_OLD(:,:,:) + REAL*8, ALLOCATABLE :: AD39_OLD(:,:,:) + + CHARACTER(LEN=255) :: DEP_UNIT + + CHARACTER(LEN=255) :: FORCING_MASK_FILE + CHARACTER(LEN=255) :: FORCING_MASK_FILE_NC + CHARACTER(LEN=255), ALLOCATABLE :: FORCING_MASK_VARIABLE(:) + INTEGER :: NB_MASK_VAR + + + ! Adj Emission IDs + ! CO + INTEGER :: ADCOEMS, ADCOVOX + + ! CH4 (kjw, dkh, 02/12/12, adj32_023) + INTEGER :: ADCH4EMS + + ! tagged Ox (lzh, 12/12/2009) + INTEGER :: IDADJ_POx + + ! FULL CHEM + INTEGER :: IDADJ_ENH3_bb + INTEGER :: IDADJ_ENH3_bf + INTEGER :: IDADJ_ENH3_an + INTEGER :: IDADJ_ENH3_na + INTEGER :: IDADJ_EBCPI_an + INTEGER :: IDADJ_EBCPO_an + INTEGER :: IDADJ_EOCPI_an + INTEGER :: IDADJ_EOCPO_an + INTEGER :: IDADJ_EBCPI_bb + INTEGER :: IDADJ_EBCPO_bb + INTEGER :: IDADJ_EOCPI_bb + INTEGER :: IDADJ_EOCPO_bb + INTEGER :: IDADJ_EBCPI_bf + INTEGER :: IDADJ_EBCPO_bf + INTEGER :: IDADJ_EOCPI_bf + INTEGER :: IDADJ_EOCPO_bf + INTEGER :: IDADJ_ESO2_an1 + INTEGER :: IDADJ_ESO2_an2 + INTEGER :: IDADJ_ESO2_bb + INTEGER :: IDADJ_ESO2_bf + INTEGER :: IDADJ_ESO2_sh + + ! gas-phase emissions + INTEGER :: IDADJ_ENOX_so + INTEGER :: IDADJ_ENOX_li + INTEGER :: IDADJ_ENOX_ac + INTEGER :: IDADJ_ENOX_an + INTEGER :: IDADJ_ENOX_bf + INTEGER :: IDADJ_ENOX_bb + INTEGER :: IDADJ_ECO_an + INTEGER :: IDADJ_ECO_bf + INTEGER :: IDADJ_ECO_bb + INTEGER :: IDADJ_EISOP_an + INTEGER :: IDADJ_EISOP_bb + INTEGER :: IDADJ_EISOP_bf + + ! add more VOCs (knl, dkh, 11/03/11, adj32_014) + INTEGER :: IDADJ_EALK4_an + INTEGER :: IDADJ_EALK4_bb + INTEGER :: IDADJ_EALK4_bf + + INTEGER :: IDADJ_EACET_an + INTEGER :: IDADJ_EACET_bb + INTEGER :: IDADJ_EACET_bf + + INTEGER :: IDADJ_EMEK_an + INTEGER :: IDADJ_EMEK_bb + INTEGER :: IDADJ_EMEK_bf + + INTEGER :: IDADJ_EALD2_an + INTEGER :: IDADJ_EALD2_bb + INTEGER :: IDADJ_EALD2_bf + + INTEGER :: IDADJ_EPRPE_an + INTEGER :: IDADJ_EPRPE_bb + INTEGER :: IDADJ_EPRPE_bf + + INTEGER :: IDADJ_EC3H8_an + INTEGER :: IDADJ_EC3H8_bb + INTEGER :: IDADJ_EC3H8_bf + + INTEGER :: IDADJ_ECH2O_an + INTEGER :: IDADJ_ECH2O_bb + INTEGER :: IDADJ_ECH2O_bf + + INTEGER :: IDADJ_EC2H6_an + INTEGER :: IDADJ_EC2H6_bb + INTEGER :: IDADJ_EC2H6_bf + + ! CO2 emissions + INTEGER :: IDADJ_ECO2ff + INTEGER :: IDADJ_ECO2ocn + INTEGER :: IDADJ_ECO2bal + INTEGER :: IDADJ_ECO2bb + INTEGER :: IDADJ_ECO2bf + INTEGER :: IDADJ_ECO2nte + INTEGER :: IDADJ_ECO2shp + INTEGER :: IDADJ_ECO2pln + INTEGER :: IDADJ_ECO2che + INTEGER :: IDADJ_ECO2sur + + + INTEGER, ALLOCATABLE :: NADJ_EANTHRO(:) + INTEGER, ALLOCATABLE :: NADJ_EBIOMASS(:) + INTEGER, ALLOCATABLE :: NADJ_EBIOFUEL(:) + + ! (dkh, 11/11/09) + INTEGER :: N_CARB_EMS_ADJ + INTEGER :: N_SULF_EMS_ADJ + LOGICAL :: IS_CARB_EMS_ADJ + LOGICAL :: IS_SULF_EMS_ADJ + + ! Dust emissions (xxu, dkh, 01/09/12, adj32_011) + INTEGER :: IDADJ_EDST1 + INTEGER :: IDADJ_EDST2 + INTEGER :: IDADJ_EDST3 + INTEGER :: IDADJ_EDST4 + INTEGER :: N_DUST_EMS_ADJ + LOGICAL :: IS_DUST_EMS_ADJ + + ! Strat prod and loss tacer (hml, dkh, 02/14/12, ad32_025) + INTEGER :: NOx_p + INTEGER :: Ox_p + INTEGER :: PAN_p + INTEGER :: CO_p + INTEGER :: ALK4_p + INTEGER :: ISOP_p + INTEGER :: HNO3_p + INTEGER :: H2O2_p + INTEGER :: ACET_p + INTEGER :: MEK_p + INTEGER :: ALD2_p + INTEGER :: RCHO_p + INTEGER :: MVK_p + INTEGER :: MACR_p + INTEGER :: PMN_p + INTEGER :: PPN_p + INTEGER :: R4N2_p + INTEGER :: PRPE_p + INTEGER :: C3H8_p + INTEGER :: CH2O_p + INTEGER :: C2H6_p + INTEGER :: N2O5_p + INTEGER :: HNO4_p + INTEGER :: MP_p + + INTEGER :: NOx_l + INTEGER :: Ox_l + INTEGER :: PAN_l + INTEGER :: CO_l + INTEGER :: ALK4_l + INTEGER :: ISOP_l + INTEGER :: HNO3_l + INTEGER :: H2O2_l + INTEGER :: ACET_l + INTEGER :: MEK_l + INTEGER :: ALD2_l + INTEGER :: RCHO_l + INTEGER :: MVK_l + INTEGER :: MACR_l + INTEGER :: PMN_l + INTEGER :: PPN_l + INTEGER :: R4N2_l + INTEGER :: PRPE_l + INTEGER :: C3H8_l + INTEGER :: CH2O_l + INTEGER :: C2H6_l + INTEGER :: N2O5_l + INTEGER :: HNO4_l + INTEGER :: MP_l + + INTEGER :: N_STR_PROD_ADJ + INTEGER :: N_STR_LOSS_ADJ + + ! Added for reaction rate sensitivities (tww, 05/08/12) + INTEGER :: NRRATES + INTEGER :: RATFD + REAL*8, ALLOCATABLE :: RATE_SF(:,:,:,:) + REAL*8, ALLOCATABLE :: RATE_SF0(:,:,:,:) + REAL*8, ALLOCATABLE :: RATE_SF_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: REG_PARAM_RATE(:) + REAL*8, ALLOCATABLE :: RATE_ERROR(:) + REAL*8, ALLOCATABLE :: RATE_SF_DEFAULT(:) + INTEGER, ALLOCATABLE :: ID_RRATES(:) + !CHARACTER(LEN=14), ALLOCATABLE :: RRATES_NAME(:) + CHARACTER(LEN=25), ALLOCATABLE :: RRATES_NAME(:)!(hml, 04/03/13) + LOGICAL, ALLOCATABLE :: OPT_THIS_RATE(:) + + + ! NOR obsolete (zhej, dkh, 01/16/12, adj32_015) + !! Nested Observation Region (zhe 1/19/11) + !INTEGER :: NOR(4) + + ! Problem when HMAX defined here so now in inv_hessian_lbfgs_mod.f + ! (nab, 24/03/12 ) + ! INTEGER :: HMAX + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_ADJ_EMS +!****************************************************************************** +! Subroutine INIT_ADJ_EMS initializes adj emission names and IDs +! (adj_group, 6/08/09) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" +# include "define_adj.h" + + ! Local variables + INTEGER :: AS + + !================================================================= + ! Allocate arrays + !================================================================= + ALLOCATE( ID_ADEMS( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_ADEMS' ) + ID_ADEMS = 0 + + ALLOCATE( ADEMS_NAME( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADEMS_NAME' ) + ADEMS_NAME = '' + + ALLOCATE( OPT_THIS_EMS( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OPT_THIS_EMS' ) + OPT_THIS_EMS = .FALSE. + + ALLOCATE( REG_PARAM_EMS( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REG_PARAM_EMS' ) + REG_PARAM_EMS= 1d0 + + ALLOCATE( EMS_ERROR( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_ERROR' ) + EMS_ERROR = 1d0 +#if defined ( LOG_OPT ) + EMS_ERROR = EXP(1d0) +#endif + + ALLOCATE( COV_ERROR_LX( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COV_ERROR_LX' ) + COV_ERROR_LX = 1d0 +#if defined ( LOG_OPT ) + COV_ERROR_LX = EXP(1d0) +#endif + + + ALLOCATE( COV_ERROR_LY( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COV_ERROR_LY' ) + COV_ERROR_LY = 1d0 +#if defined ( LOG_OPT ) + COV_ERROR_LY = EXP(1d0) +#endif + + ALLOCATE( EMS_SF_DEFAULT( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF_DEFAULT' ) + EMS_SF_DEFAULT = 1d0 + + ! Return to calling program + END SUBROUTINE INIT_ADJ_EMS + +!----------------------------------------------------------------------------- + + + SUBROUTINE INIT_ADJ_RRATES +!****************************************************************************** +! Subroutine INIT_ADJ_RRATES initializes adj reaction rates names and IDs +! (tww, 05/08/12) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" +# include "define_adj.h" + + ! Local variables + INTEGER :: AS + + !================================================================= + ! Allocate arrays + !================================================================= + ALLOCATE( ID_RRATES( NRRATES ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_RRATES' ) + ID_RRATES = 0 + + ALLOCATE( RRATES_NAME( NRRATES ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RRATES_NAME' ) + RRATES_NAME = '' + + ALLOCATE( OPT_THIS_RATE( NRRATES ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OPT_THIS_RATE' ) + OPT_THIS_RATE=.FALSE. + + ALLOCATE( RATE_SF_DEFAULT( NRRATES ), STAT=AS ) + IF ( AS /=0 ) CALL ALLOC_ERR( 'RATE_SF_DEFAULT' ) + RATE_SF_DEFAULT = 1d0 + + ALLOCATE( REG_PARAM_RATE( NRRATES ), STAT=AS ) + IF ( AS /=0 ) CALL ALLOC_ERR( 'REG_PARAM_RATE' ) + REG_PARAM_RATE = 1d0 + + ALLOCATE( RATE_ERROR( NRRATES ), STAT=AS ) + IF ( AS /=0 ) CALL ALLOC_ERR( 'RATE_ERROR' ) + RATE_ERROR = 1d0 +#if defined ( LOG_OPT ) + RATE_ERROR = EXP(1d0) +#endif + + ! Return to calling program + END SUBROUTINE INIT_ADJ_RRATES + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_TRACERID_ADJ +! +!****************************************************************************** +! Subroutine INIT_TRACERID zeroes module variables. (mak, 6/14/09) +! +! NOTES: +! (1 ) Now include NH3 emissions ID #'s (dkh, 11/04/09) +! (2 ) Now include CO2 emissions ID #'s (dkh, 05/06/10) +! (3 ) Now inlcude more VOCs ID #'s (knl, dkh, 11/03/11, adj32_014) +! (3 ) Now inlcude dust ID #'s (xxu, dkh, 01/09/12, adj32_011) +! (3 ) Now inlcude CH4 ID #'s (kjw, dkh, 02/12/12, adj32_023) +! (3 ) Now inlcude strat flux ID #'s (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! reference to f90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + + ! local variables + INTEGER :: AS + + ! GEOS-CHEM Adjoint Emission ID #'s + ADCOEMS = 0 + ADCOVOX = 0 + IDADJ_ENH3_an = 0 + IDADJ_ENH3_bb = 0 + IDADJ_ENH3_bf = 0 + IDADJ_ENH3_na = 0 + IDADJ_ESO2_an1 = 0 + IDADJ_ESO2_an2 = 0 + IDADJ_ESO2_bb = 0 + IDADJ_ESO2_bf = 0 + IDADJ_ESO2_sh = 0 + IDADJ_EBCPI_an = 0 + IDADJ_EBCPO_an = 0 + IDADJ_EOCPI_an = 0 + IDADJ_EOCPO_an = 0 + IDADJ_EBCPI_bb = 0 + IDADJ_EBCPO_bb = 0 + IDADJ_EOCPI_bb = 0 + IDADJ_EOCPO_bb = 0 + IDADJ_EBCPI_bf = 0 + IDADJ_EBCPO_bf = 0 + IDADJ_EOCPI_bf = 0 + IDADJ_EOCPO_bf = 0 + + IDADJ_ENOX_so = 0 + IDADJ_ENOX_li = 0 + IDADJ_ENOX_ac = 0 + IDADJ_ENOX_an = 0 + IDADJ_ENOX_bf = 0 + IDADJ_ENOX_bb = 0 + IDADJ_ECO_an = 0 + IDADJ_ECO_bf = 0 + IDADJ_ECO_bb = 0 + IDADJ_EISOP_an = 0 + IDADJ_EISOP_bf = 0 + IDADJ_EISOP_bb = 0 + + ! add more VOCs (knl, dkh, 11/03/11, adj32_014) + IDADJ_EALK4_an = 0 + IDADJ_EALK4_bf = 0 + IDADJ_EALK4_bb = 0 + IDADJ_EACET_an = 0 + IDADJ_EACET_bb = 0 + IDADJ_EACET_bf = 0 + IDADJ_EMEK_an = 0 + IDADJ_EMEK_bb = 0 + IDADJ_EMEK_bf = 0 + IDADJ_EALD2_an = 0 + IDADJ_EALD2_bb = 0 + IDADJ_EALD2_bf = 0 + IDADJ_EPRPE_an = 0 + IDADJ_EPRPE_bf = 0 + IDADJ_EPRPE_bb = 0 + IDADJ_EC3H8_an = 0 + IDADJ_EC3H8_bf = 0 + IDADJ_EC3H8_bb = 0 + IDADJ_ECH2O_an = 0 + IDADJ_ECH2O_bf = 0 + IDADJ_ECH2O_bb = 0 + IDADJ_EC2H6_an = 0 + IDADJ_EC2H6_bf = 0 + IDADJ_EC2H6_bb = 0 + IDADJ_ECO2ff = 0 + IDADJ_ECO2ocn = 0 + IDADJ_ECO2bal = 0 + IDADJ_ECO2bb = 0 + IDADJ_ECO2bf = 0 + IDADJ_ECO2nte = 0 + IDADJ_ECO2shp = 0 + IDADJ_ECO2pln = 0 + IDADJ_ECO2che = 0 + IDADJ_ECO2sur = 0 + + ! (xxu, dkh, 01/09/12, adj32_011) + IDADJ_EDST1 = 0 + IDADJ_EDST2 = 0 + IDADJ_EDST3 = 0 + IDADJ_EDST4 = 0 + + + ! (kjw, dkh, 02/12/12, adj32_023) + ADCH4EMS = 1 + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + ALLOCATE( NADJ_EANTHRO( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NADJ_EANTHRO' ) + NADJ_EANTHRO = 0d0 + + ALLOCATE( NADJ_EBIOMASS( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NADJ_EBIOMASS' ) + NADJ_EBIOMASS = 0d0 + + ALLOCATE( NADJ_EBIOFUEL( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NADJ_EBIOFUEL' ) + NADJ_EBIOFUEL = 0d0 + + ENDIF + + IDADJ_POx = 0 + + + ! GEOS-CHEM Adjoint Strat prod and loss tacer ID #'s (hml, adj32_025) + NOx_p = 0 + Ox_p = 0 + PAN_p = 0 + CO_p = 0 + ALK4_p = 0 + ISOP_p = 0 + HNO3_p = 0 + H2O2_p = 0 + ACET_p = 0 + MEK_p = 0 + ALD2_p = 0 + RCHO_p = 0 + MVK_p = 0 + MACR_p = 0 + PMN_p = 0 + PPN_p = 0 + R4N2_p = 0 + PRPE_p = 0 + C3H8_p = 0 + CH2O_p = 0 + C2H6_p = 0 + N2O5_p = 0 + HNO4_p = 0 + MP_p = 0 + + NOx_l = 0 + Ox_l = 0 + PAN_l = 0 + CO_l = 0 + ALK4_l = 0 + ISOP_l = 0 + HNO3_l = 0 + H2O2_l = 0 + ACET_l = 0 + MEK_l = 0 + ALD2_l = 0 + RCHO_l = 0 + MVK_l = 0 + MACR_l = 0 + PMN_l = 0 + PPN_l = 0 + R4N2_l = 0 + PRPE_l = 0 + C3H8_l = 0 + CH2O_l = 0 + C2H6_l = 0 + N2O5_l = 0 + HNO4_l = 0 + MP_l = 0 + + ! Return to calling program + END SUBROUTINE INIT_TRACERID_ADJ + +!------------------------------------------------------------------------------ + SUBROUTINE TRACERID_ADJ +!******************************************************************************* +! This subroutine initializes adjoint emission IDs read in from "input.gcadj" +! +! (mak, 6/17/09) +! +! Notes +! (1 ) Now include NH3 emission ID #'s (dkh, 11/04/09) +! (2 ) Now include BC/OC emission ID #'s (dkh, 11/10/09) +! (3 ) Add counting of active emissions for groups of species (dkh, 11/11/09) +! (4 ) Now include CO2 emission ID #'s (dkh, 05/06/10) +!******************************************************************************* + + ! reference to f90 modules + USE TRACERID_MOD + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! IDEMS + + ! Local variables + INTEGER :: N, NN + CHARACTER(LEN=14) :: NAME + + ! Initialize counters + N_CARB_EMS_ADJ = 0 + N_SULF_EMS_ADJ = 0 + ! (xxu, dkh, 01/09/12, adj32_011) + N_DUST_EMS_ADJ = 0 + + DO N =1, NNEMS + + NAME = ADEMS_NAME(N) + + SELECT CASE ( TRIM( NAME ) ) + + ! tagged CO + CASE ( 'ADCOEMS' ) + ADCOEMS = ID_ADEMS(N) + CASE( 'ADCOVOX' ) + ADCOVOX = ID_ADEMS(N) + + ! tagged CO + CASE ( 'IDADJ_POx' ) + IDADJ_POx = ID_ADEMS(N) + + ! Methane, CH4 (kjw, dkh, 02/12/12, adj32_023) + CASE( 'ADCH4EMS' ) + ADCH4EMS = ID_ADEMS(N) + + ! sulfate aerosol + CASE( 'IDADJ_ENH3_an' ) + IDADJ_ENH3_an = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ENH3_bb' ) + IDADJ_ENH3_bb = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ENH3_bf' ) + IDADJ_ENH3_bf = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ENH3_na' ) + IDADJ_ENH3_na = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ESO2_an1' ) + IDADJ_ESO2_an1 = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ESO2_an2' ) + IDADJ_ESO2_an2 = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ESO2_bb' ) + IDADJ_ESO2_bb = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ESO2_bf' ) + IDADJ_ESO2_bf = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ESO2_sh' ) + IDADJ_ESO2_sh = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + + + ! carbon arerosol + CASE( 'IDADJ_EBCPI_an' ) + IDADJ_EBCPI_an = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EBCPO_an' ) + IDADJ_EBCPO_an = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPI_an' ) + IDADJ_EOCPI_an = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPO_an' ) + IDADJ_EOCPO_an = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EBCPI_bb' ) + IDADJ_EBCPI_bb = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EBCPO_bb' ) + IDADJ_EBCPO_bb = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPI_bb' ) + IDADJ_EOCPI_bb = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPO_bb' ) + IDADJ_EOCPO_bb = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EBCPI_bf' ) + IDADJ_EBCPI_bf = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EBCPO_bf' ) + IDADJ_EBCPO_bf = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPI_bf' ) + IDADJ_EOCPI_bf = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPO_bf' ) + IDADJ_EOCPO_bf = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + + ! specific NOx emissions + CASE( 'IDADJ_ENOX_so' ) + IDADJ_ENOX_so = ID_ADEMS(N) + CASE( 'IDADJ_ENOX_li' ) + IDADJ_ENOX_li = ID_ADEMS(N) + CASE( 'IDADJ_ENOX_ac' ) + IDADJ_ENOX_ac = ID_ADEMS(N) + + ! gas-phase emissions . Corresponds to + ! any species in SMVGEAR / KPP with an + ! emissions reaction + CASE( 'IDADJ_ENOX_an' ) + IDADJ_ENOX_an = ID_ADEMS(N) + NN = IDEMS(IDENOX) + NADJ_EANTHRO(NN) = IDADJ_ENOX_an + CASE( 'IDADJ_ECO_an' ) + IDADJ_ECO_an = ID_ADEMS(N) + NN = IDEMS(IDECO) + NADJ_EANTHRO(NN) = IDADJ_ECO_an + CASE( 'IDADJ_EISOP_an' ) + IDADJ_EISOP_an = ID_ADEMS(N) + NN = IDEMS(IDEISOP) + NADJ_EANTHRO(NN) = IDADJ_EISOP_an + + ! add more VOCs (knl, dkh, 11/03/11i, adj32_014) + CASE( 'IDADJ_EALK4_an' ) + IDADJ_EALK4_an = ID_ADEMS(N) + NN = IDEMS(IDEALK4) + NADJ_EANTHRO(NN) = IDADJ_EALK4_an + CASE( 'IDADJ_EACET_an' ) + IDADJ_EACET_an = ID_ADEMS(N) + NN = IDEMS(IDEACET) + NADJ_EANTHRO(NN) = IDADJ_EACET_an + CASE( 'IDADJ_EMEK_an' ) + IDADJ_EMEK_an = ID_ADEMS(N) + NN = IDEMS(IDEMEK) + NADJ_EANTHRO(NN) = IDADJ_EMEK_an + CASE( 'IDADJ_EALD2_an' ) + IDADJ_EALD2_an = ID_ADEMS(N) + NN = IDEMS(IDEALD2) + NADJ_EANTHRO(NN) = IDADJ_EALD2_an + CASE( 'IDADJ_EPRPE_an' ) + IDADJ_EPRPE_an = ID_ADEMS(N) + NN = IDEMS(IDEPRPE) + NADJ_EANTHRO(NN) = IDADJ_EPRPE_an + CASE( 'IDADJ_EC3H8_an' ) + IDADJ_EC3H8_an = ID_ADEMS(N) + NN = IDEMS(IDEC3H8) + NADJ_EANTHRO(NN) = IDADJ_EC3H8_an + CASE( 'IDADJ_ECH2O_an' ) + IDADJ_ECH2O_an = ID_ADEMS(N) + NN = IDEMS(IDECH2O) + NADJ_EANTHRO(NN) = IDADJ_ECH2O_an + CASE( 'IDADJ_EC2H6_an' ) + IDADJ_EC2H6_an = ID_ADEMS(N) + NN = IDEMS(IDEC2H6) + NADJ_EANTHRO(NN) = IDADJ_EC2H6_an + + + CASE( 'IDADJ_ENOX_bb' ) + IDADJ_ENOX_bb = ID_ADEMS(N) + NN = IDEMS(IDENOX) + NADJ_EBIOMASS(NN) = IDADJ_ENOX_bb + CASE( 'IDADJ_ECO_bb' ) + IDADJ_ECO_bb = ID_ADEMS(N) + NN = IDEMS(IDECO) + NADJ_EBIOMASS(NN) = IDADJ_ECO_bb + CASE( 'IDADJ_EISOP_bb' ) + IDADJ_EISOP_bb = ID_ADEMS(N) + NN = IDEMS(IDEISOP) + NADJ_EBIOMASS(NN) = IDADJ_EISOP_bb + + ! add more VOCs (knl, dkh, 11/03/11, adj32_014) + CASE( 'IDADJ_EALK4_bb' ) + IDADJ_EALK4_bb = ID_ADEMS(N) + NN = IDEMS(IDEALK4) + NADJ_EBIOMASS(NN) = IDADJ_EALK4_bb + CASE( 'IDADJ_EACET_bb' ) + IDADJ_EACET_bb = ID_ADEMS(N) + NN = IDEMS(IDEACET) + NADJ_EBIOMASS(NN) = IDADJ_EACET_bb + CASE( 'IDADJ_EMEK_bb' ) + IDADJ_EMEK_bb = ID_ADEMS(N) + NN = IDEMS(IDEMEK) + NADJ_EBIOMASS(NN) = IDADJ_EMEK_bb + CASE( 'IDADJ_EALD2_bb' ) + IDADJ_EALD2_bb = ID_ADEMS(N) + NN = IDEMS(IDEALD2) + NADJ_EBIOMASS(NN) = IDADJ_EALD2_bb + CASE( 'IDADJ_EPRPE_bb' ) + IDADJ_EPRPE_bb = ID_ADEMS(N) + NN = IDEMS(IDEPRPE) + NADJ_EBIOMASS(NN) = IDADJ_EPRPE_bb + CASE( 'IDADJ_EC3H8_bb' ) + IDADJ_EC3H8_bb = ID_ADEMS(N) + NN = IDEMS(IDEC3H8) + NADJ_EBIOMASS(NN) = IDADJ_EC3H8_bb + CASE( 'IDADJ_ECH2O_bb' ) + IDADJ_ECH2O_bb = ID_ADEMS(N) + NN = IDEMS(IDECH2O) + NADJ_EBIOMASS(NN) = IDADJ_ECH2O_bb + CASE( 'IDADJ_EC2H6_bb' ) + IDADJ_EC2H6_bb = ID_ADEMS(N) + NN = IDEMS(IDEC2H6) + NADJ_EBIOMASS(NN) = IDADJ_EC2H6_bb + + + CASE( 'IDADJ_ENOX_bf' ) + IDADJ_ENOX_bf = ID_ADEMS(N) + NN = IDEMS(IDENOX) + NADJ_EBIOFUEL(NN) = IDADJ_ENOX_bf + CASE( 'IDADJ_ECO_bf' ) + IDADJ_ECO_bf = ID_ADEMS(N) + NN = IDEMS(IDECO) + NADJ_EBIOFUEL(NN) = IDADJ_ECO_bf + CASE( 'IDADJ_EISOP_bf' ) + IDADJ_EISOP_bf = ID_ADEMS(N) + NN = IDEMS(IDEISOP) + NADJ_EBIOFUEL(NN) = IDADJ_EISOP_bf + + ! add more VOCs (knl, dkh, 11/03/11, adj32_014) + CASE( 'IDADJ_EALK4_bf' ) + IDADJ_EALK4_bf = ID_ADEMS(N) + NN = IDEMS(IDEALK4) + NADJ_EBIOFUEL(NN) = IDADJ_EALK4_bf + CASE( 'IDADJ_EACET_bf' ) + IDADJ_EACET_bf = ID_ADEMS(N) + NN = IDEMS(IDEACET) + NADJ_EBIOFUEL(NN) = IDADJ_EACET_bf + CASE( 'IDADJ_EMEK_bf' ) + IDADJ_EMEK_bf = ID_ADEMS(N) + NN = IDEMS(IDEMEK) + NADJ_EBIOFUEL(NN) = IDADJ_EMEK_bf + CASE( 'IDADJ_EALD2_bf' ) + IDADJ_EALD2_bf = ID_ADEMS(N) + NN = IDEMS(IDEALD2) + NADJ_EBIOFUEL(NN) = IDADJ_EALD2_bf + CASE( 'IDADJ_EPRPE_bf' ) + IDADJ_EPRPE_bf = ID_ADEMS(N) + NN = IDEMS(IDEPRPE) + NADJ_EBIOFUEL(NN) = IDADJ_EPRPE_bf + CASE( 'IDADJ_EC3H8_bf' ) + IDADJ_EC3H8_bf = ID_ADEMS(N) + NN = IDEMS(IDEC3H8) + NADJ_EBIOFUEL(NN) = IDADJ_EC3H8_bf + CASE( 'IDADJ_ECH2O_bf' ) + IDADJ_ECH2O_bf = ID_ADEMS(N) + NN = IDEMS(IDECH2O) + NADJ_EBIOFUEL(NN) = IDADJ_ECH2O_bf + CASE( 'IDADJ_EC2H6_bf' ) + IDADJ_EC2H6_bf = ID_ADEMS(N) + NN = IDEMS(IDEC2H6) + NADJ_EBIOFUEL(NN) = IDADJ_EC2H6_bf + + ! CO2 emissions + CASE( 'IDADJ_ECO2ff' ) + IDADJ_ECO2ff = ID_ADEMS(N) + CASE( 'IDADJ_ECO2ocn' ) + IDADJ_ECO2ocn = ID_ADEMS(N) + CASE( 'IDADJ_ECO2bal' ) + IDADJ_ECO2bal = ID_ADEMS(N) + CASE( 'IDADJ_ECO2bb' ) + IDADJ_ECO2bb = ID_ADEMS(N) + CASE( 'IDADJ_ECO2bf' ) + IDADJ_ECO2bf = ID_ADEMS(N) + CASE( 'IDADJ_ECO2nte' ) + IDADJ_ECO2nte = ID_ADEMS(N) + CASE( 'IDADJ_ECO2shp' ) + IDADJ_ECO2shp = ID_ADEMS(N) + CASE( 'IDADJ_ECO2pln' ) + IDADJ_ECO2pln = ID_ADEMS(N) + CASE( 'IDADJ_ECO2che' ) + IDADJ_ECO2che = ID_ADEMS(N) + CASE( 'IDADJ_ECO2sur' ) + IDADJ_ECO2sur = ID_ADEMS(N) + + ! Dust emissions (xxu, dkh, 01/09/12, adj32_011) + CASE( 'IDADJ_EDST1' ) + IDADJ_EDST1 = ID_ADEMS(N) + N_DUST_EMS_ADJ = N_DUST_EMS_ADJ + 1 + CASE( 'IDADJ_EDST2' ) + IDADJ_EDST2 = ID_ADEMS(N) + N_DUST_EMS_ADJ = N_DUST_EMS_ADJ + 1 + CASE( 'IDADJ_EDST3' ) + IDADJ_EDST3 = ID_ADEMS(N) + N_DUST_EMS_ADJ = N_DUST_EMS_ADJ + 1 + CASE( 'IDADJ_EDST4' ) + IDADJ_EDST4 = ID_ADEMS(N) + N_DUST_EMS_ADJ = N_DUST_EMS_ADJ + 1 + END SELECT + + ENDDO + + END SUBROUTINE TRACERID_ADJ + +!------------------------------------------------------------------------------ + SUBROUTINE STRPID_ADJ +! +!******************************************************************************* +! This subroutine initializes adjoint strat prod IDs read in from +! "input.gcadj" (hml, dkh, 02/14/12, adj32_025) +! +! Notes +! (1 ) +!******************************************************************************* + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! IDEMS + + ! Local variables + INTEGER :: N + CHARACTER(LEN=12) :: NAME + + ! Initialize counters + N_STR_PROD_ADJ = 0 + + ! For production + DO N =1, NSTPL + + NAME = PROD_NAME(N) + + SELECT CASE ( TRIM( NAME ) ) + + CASE( 'NOx_p' ) + NOx_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'Ox_p' ) + Ox_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'PAN_p' ) + PAN_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'CO_p' ) + CO_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'ALK4_p' ) + ALK4_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'ISOP_p' ) + ISOP_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'HNO3_p' ) + HNO3_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'H2O2_p' ) + H2O2_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'ACET_p' ) + ACET_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'MEK_p' ) + MEK_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'ALD2_p' ) + ALD2_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'RCHO_p' ) + RCHO_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'MVK_p' ) + MVK_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'MACR_p' ) + MACR_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'PMN_p' ) + PMN_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'PPN_p' ) + PPN_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'R4N2_p' ) + R4N2_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'PRPE_p' ) + PRPE_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'C3H8_p' ) + C3H8_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'CH2O_p' ) + CH2O_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'C2H6_p' ) + C2H6_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'N2O5_p' ) + N2O5_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'HNO4_p' ) + HNO4_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'MP_p' ) + MP_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + + END SELECT + + ENDDO + + END SUBROUTINE STRPID_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE STRLID_ADJ +! +!******************************************************************************* +! This subroutine initializes adjoint strat loss IDs read in from +! "input.gcadj" (hml, dkh, 02/14/12, adj32_025) +! +! Notes +! (1 ) +!******************************************************************************* + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! IDEMS + + ! Local variables + INTEGER :: N + CHARACTER(LEN=12) :: NAME + + ! Initialize counters + N_STR_LOSS_ADJ = 0 + + ! For production + DO N =1, NSTPL + + NAME = LOSS_NAME(N) + + SELECT CASE ( TRIM( NAME ) ) + + CASE( 'NOx_l' ) + NOx_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'Ox_l' ) + Ox_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'PAN_l' ) + PAN_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'CO_l' ) + CO_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'ALK4_l' ) + ALK4_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'ISOP_l' ) + ISOP_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'HNO3_l' ) + HNO3_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'H2O2_l' ) + H2O2_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'ACET_l' ) + ACET_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'MEK_l' ) + MEK_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'ALD2_l' ) + ALD2_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'RCHO_l' ) + RCHO_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'MVK_l' ) + MVK_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'MACR_l' ) + MACR_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'PMN_l' ) + PMN_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'PPN_l' ) + PPN_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'R4N2_l' ) + R4N2_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'PRPE_l' ) + PRPE_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'C3H8_l' ) + C3H8_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'CH2O_l' ) + CH2O_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'C2H6_l' ) + C2H6_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'N2O5_l' ) + N2O5_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'HNO4_l' ) + HNO4_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'MP_l' ) + MP_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + + END SELECT + + ENDDO + + END SUBROUTINE STRLID_ADJ + +!------------------------------------------------------------------------------ + SUBROUTINE INIT_ADJ_ARRAYS +! +!****************************************************************************** +! Subroutine INIT_ADJ_ARRAYS initializes and zeroes all module arrays.! +! (mak, bmy, 3/14/06) +! +! NOTES: +! (1 ) Update for merged v8 adjoint. (dkh, mak, 06/08/09) +! (2 ) Add support for LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (3 ) Move VAR_FD and RCONST_FD here (dkh, 02/23/12, adj32_026) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE GCKPP_ADJ_PARAMETERS, ONLY : NVAR, NREACT + USE TIME_MOD, ONLY : CALC_RUN_DAYS + USE TIME_MOD, ONLY : GET_TAUb + USE TIME_MOD, ONLY : GET_TAUe + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS, LDCOSAT + USE LOGICAL_ADJ_MOD, ONLY : LEMS_ABS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + USE GCKPP_ADJ_GLOBAL, ONLY : NCOEFF + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ !fp + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NEMIS, NCS +# include "define_adj.h" ! NEMIS, NCS + + + INTEGER :: AS + INTEGER :: NCHEM_MAX + REAL*8 :: TOTAL_MINUTES + + + !================================================================= + ! INIT_ADJ_ARRAYS begins here! + !================================================================= + + IF ( LDCOSAT ) THEN + CALL CALC_NUM_SAT + ENDIF + + DAYS = CALC_RUN_DAYS() + DAY_OF_SIM = -1 + + IF ( LADJ ) THEN + + ALLOCATE( FORCING( IIPAR, JJPAR, DAYS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'FORCING' ) + FORCING = 0d0 + + ALLOCATE( SHIPO3DEP_ADJ( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SHIPO3DEP_ADJ' ) + SHIPO3DEP_ADJ = 0d0 + + ALLOCATE( MOP_MOD_DIFF( IIPAR, JJPAR, DAYS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MOP_MOD_DIFF' ) + MOP_MOD_DIFF = 0d0 + + ALLOCATE( MODEL_BIAS( IIPAR, JJPAR, DAYS,sat ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MODEL_BIAS' ) + MODEL_BIAS = 0d0 + + ALLOCATE( MODEL( IIPAR, JJPAR, DAYS,sat ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MODEL' ) + MODEL = -999d0 + + ALLOCATE( SAT_DOFS( IIPAR, JJPAR, DAYS,sat ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SAT_DOFS' ) + SAT_DOFS = -999d0 + + ALLOCATE( OBS( IIPAR, JJPAR, DAYS, sat ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS' ) + OBS = -999d0 + + ALLOCATE( COST_ARRAY(IIPAR, JJPAR, DAYS ), + & STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COST_ARRAY' ) + COST_ARRAY(:,:,:) = 0d0 + + ALLOCATE( EMS_orig( IIPAR, JJPAR, MMSCL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_orig' ) + EMS_orig = 0d0 + + ALLOCATE( OBS_COUNT(IIPAR, JJPAR ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS_COUNT' ) + OBS_COUNT(:,:) = 0 + + ALLOCATE( REMIS_ADJ( ITLOOP, MAXGL3 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REMIS_ADJ' ) + REMIS_ADJ = 0d0 + + ENDIF + + ALLOCATE( ICS_SF(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_SF' ) + ICS_SF = 0d0 + + ALLOCATE( ICS_SF0(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_SF0' ) + ICS_SF0 = 0d0 + + IF ( LADJ ) THEN + + ALLOCATE( ICS_SF_ADJ(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_SF_ADJ' ) + ICS_SF_ADJ = 0d0 + + ALLOCATE( OBS_STT(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS_STT' ) + OBS_STT = 0d0 + + ALLOCATE( STT_ADJ(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'STT_ADJ' ) + STT_ADJ = 0d0 + + ALLOCATE( CF_REGION(IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CF_REGION' ) + CF_REGION = 0d0 + + ALLOCATE( ADJ_FORCE(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADJ_FOCE' ) + ADJ_FORCE = 0d0 + + ALLOCATE( COST_FUNC_SAV( N_CALC_STOP ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COST_FUNC_SAV' ) + + ALLOCATE( STT_ADJ_FD( N_CALC_STOP ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'STT_ADJ_FD' ) + STT_ADJ_FD = 0d0 + + ALLOCATE( STT_ORIG(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'STT_ORIG' ) + STT_ORIG = 0d0 + + ENDIF + + IF ( LADJ_EMS ) THEN + ALLOCATE( EMS_SF(IIPAR, JJPAR, MMSCL, NNEMS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF' ) + EMS_SF = 0d0 + + ALLOCATE( EMS_SF0(IIPAR, JJPAR, MMSCL, NNEMS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF0' ) + EMS_SF0 = 0d0 + + IF ( LADJ ) THEN + + ALLOCATE( EMS_SF_ADJ(IIPAR, JJPAR, MMSCL, NNEMS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF_ADJ' ) + EMS_SF_ADJ = 0d0 + + ALLOCATE( TEMP2(IIPAR, JJPAR, MMSCL, NNEMS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TEMP2' ) + TEMP2 = 0d0 + + ENDIF + + IF ( LEMS_ABS ) THEN + ALLOCATE( EMS_ADJ(IIPAR, JJPAR, MMSCL, NNEMS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_ADJ' ) + EMS_ADJ = 0d0 + ENDIF + + ! Strat prod and loss (hml, 07/26/11, adj32_025) + IF ( LADJ_STRAT ) THEN + ALLOCATE( PROD_SF(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_SF' ) + PROD_SF = 0d0 + + ALLOCATE( PROD_SF0(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_SF0' ) + PROD_SF0 = 0d0 + + ALLOCATE( LOSS_SF(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_SF' ) + LOSS_SF = 0d0 + + ALLOCATE( LOSS_SF0(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_SF0' ) + LOSS_SF0 = 0d0 + + ALLOCATE( PROD_SF_ADJ(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_SF_ADJ' ) + PROD_SF_ADJ = 0d0 + + ALLOCATE( P_ADJ(IIPAR, JJPAR, LLPAR, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'P_ADJ' ) + P_ADJ = 0d0 + + ALLOCATE( LOSS_SF_ADJ(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_SF_ADJ' ) + LOSS_SF_ADJ = 0d0 + + ALLOCATE( k_ADJ(IIPAR, JJPAR, LLPAR, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'k_ADJ' ) + k_ADJ = 0d0 + + ENDIF + + ! tww, 05/15/12 + IF (LADJ_RRATE) THEN + ALLOCATE( RATE_SF(IIPAR,JJPAR,LLPAR,NRRATES), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RATE_SF' ) + RATE_SF = 0d0 + + ALLOCATE( RATE_SF0(IIPAR,JJPAR,LLPAR,NRRATES), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RATE_SF0' ) + RATE_SF0 = 0d0 + ENDIF + + ENDIF + + ! fullchem emissions adjoint arrays (dkh, 03/30/10) + IF ( ITS_A_FULLCHEM_SIM() .and. LADJ ) THEN + + !d!IF ( LADJ_EMS ) THEN + + ALLOCATE( DEPSAV_ADJ( IIPAR, JJPAR, MAXGL3 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DEPSAV_ADJ' ) + DEPSAV_ADJ = 0d0 + + !d!ENDIF + + IF (LADJ_RRATE ) THEN + ! Added for reaction rate sensitivities (tww, 05/08/12) + ! Debug (hml, 04/07/13) NCOEFF -> NRRATES + !ALLOCATE( RATE_SF_ADJ( IIPAR, JJPAR, LLPAR, NCOEFF ), STAT=AS) + ALLOCATE( RATE_SF_ADJ( IIPAR, JJPAR, LLPAR, NRRATES ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RATE_SF_ADJ' ) + RATE_SF_ADJ = 0d0 + ENDIF + + ! Determine max number of chemical time steps and allocate arrays + ! (dkh, 02/23/12, adj32_026) + ! Calculate minute per simulation + TOTAL_MINUTES = 60d0 * ( GET_TAUe() - GET_TAUb() ) + + ! Calculate # of chemical time steps, add 1 to be safe + NCHEM_MAX = INT(TOTAL_MINUTES / GET_TS_CHEM()) + 1 + + ! debug + print*, ' in CINSPECT , NCHEM_MAX = ', NCHEM_MAX, TOTAL_MINUTES + + ! Allocate arrays + ALLOCATE( VAR_FD( NVAR, NCHEM_MAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'VAR_FD' ) + VAR_FD = 0d0 + + ALLOCATE( RCONST_FD( NREACT, NCHEM_MAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RCONST_FD' ) + RCONST_FD = 0d0 + + ENDIF + +#if defined( TES_O3_OBS ) || defined ( LIDORT ) || defined ( TES_O3_IRK ) + + ! O3 profiles for comparison in strat + ALLOCATE( O3_PROF_SAV( IIPAR, JJPAR, LLPAR+1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'O3_PROF_SAV' ) + O3_PROF_SAV = 0d0 + +#endif + +#if defined(EANET_OBS) || defined(EMEP_OBS) || defined(NADP_OBS) + ALLOCATE( NHX_ADJ_FORCE( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NHX_ADJ_FORCE' ) + NHX_ADJ_FORCE = 0d0 +#endif + + +! NOR obsolete (zhej, dkh, 01/16/12, adj32_015) +!#if defined( NESTED_CH ) +! NOR(1) = 8 !W_Lon (zhe 1/19/11) +! NOR(2) = 114 !E_Lon +! NOR(3) = 44 !S_Lat +! NOR(4) = 124 !N_Lat +!#endif +!#if defined( NESTED_NA ) +! NOR(1) = 8 +! NOR(2) = ??? +! NOR(2) = 10 +! NOR(2) = ??? +!#endif + + INV_NSPAN = REAL( 1d0 / NSPAN, 8 ) + + ! total dimension in 1D (dkh, 01/12/12) + ! Problems when HMAX is defined here + !so now defines that in inv_hessian_lbfgs_mod.f + ! need to be put back here later + ! (nab, 03/28/12, ) + + ! HMAX = IIPAR * JJPAR * MMSCL * NNEMS + + + IF ( LADJ_FDEP ) THEN + + IF ( LADJ_DDEP_TRACER ) THEN + + ALLOCATE( DDEP_TRACER( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DDEP_TRACER' ) + DDEP_TRACER = 0d0 + + ALLOCATE( AD44_OLD( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD44_OLD' ) + AD44_OLD = 0d0 + + ENDIF + + IF ( LADJ_DDEP_CSPEC ) THEN + + ALLOCATE( DDEP_CSPEC( IIPAR, JJPAR, NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DDEP_CSPEC' ) + DDEP_CSPEC = 0d0 + + ALLOCATE( AD44_CSPEC_OLD( IIPAR, JJPAR, NOBS_CSPEC ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD44_CSPEC_OLD' ) + AD44_CSPEC_OLD = 0d0 + + ENDIF + + IF ( LADJ_WDEP_CV ) THEN + + ALLOCATE( WDEP_CV( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'WDEP_CV' ) + WDEP_CV = 0d0 + + ALLOCATE( AD38_OLD( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD38_OLD' ) + AD38_OLD = 0d0 + + ENDIF + + IF ( LADJ_WDEP_LS ) THEN + + ALLOCATE( WDEP_LS( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'WDEP_LS' ) + WDEP_LS = 0d0 + + ALLOCATE( AD39_OLD( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD39_OLD' ) + AD39_OLD = 0d0 + + ENDIF + ENDIF + + ! Return to calling program + END SUBROUTINE INIT_ADJ_ARRAYS + +!-------------------------------------------------------------------------------- + + SUBROUTINE INIT_UNITS_DEP +! +!****************************************************************************** +! Subroutine INIT_UNITS_DEP sets the arrays which handle unit conversion +! for the deposition based cost function (fp, dkh, 04/18/13) +! +! NOTES: +! (1 ) Add special treatment for N2O5 (2N) +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE LOGICAL_ADJ_MOD, ONLY : LKGNHAYR + USE LOGICAL_ADJ_MOD, ONLY : LEQHAYR + USE LOGICAL_ADJ_MOD, ONLY : LMOLECCM2S + USE LOGICAL_ADJ_MOD, ONLY : LKGS + USE LOGICAL_ADJ_MOD, ONLY : LFORCE_MASK + USE TRACER_MOD, ONLY : N_TRACERS, TRACER_MW_KG + USE TRACER_MOD, ONLY : TRACER_NAME + USE TRACERID_MOD, ONLY : IDTSO4, IDTN2O5, IDTSO2 + +# include "CMN_SIZE" ! Size params + + ! local variables + INTEGER :: AS, J, N + + !================================================================= + ! INIT_UNITS_DEP begins here! + !================================================================= + + IF ( LADJ_DDEP_TRACER ) THEN + + ALLOCATE( TR_DDEP_CONV(JJPAR,N_TRACERS), STAT = AS ) + IF ( AS /=0 ) CALL ALLOC_ERR('TR_DDEP_CONV') + TR_DDEP_CONV(:,:) = 0d0 + + IF ( LMOLECCM2S ) THEN + IF ( LFORCE_MASK ) THEN + DO J = 1, JJPAR + TR_DDEP_CONV(J,:) = + & GET_AREA_CM2(J) / ADJOINT_AREA_M2 * 1D-4 + ENDDO + ELSE + TR_DDEP_CONV(:,:) = 1d0 + ENDIF + ENDIF + + IF ( LKGS ) THEN + DO N = 1, N_TRACERS + IF ( OBS_THIS_TRACER(N) ) THEN + DO J = 1, JJPAR + TR_DDEP_CONV(J,N) = + & TRACER_MW_KG(N) / 6.022D23 * GET_AREA_CM2(J) + ENDDO + ENDIF + ENDDO + ENDIF + + IF ( LKGNHAYR ) THEN + IF ( LFORCE_MASK ) THEN + DO J=1,JJPAR + + ! cm2 -> ha + TR_DDEP_CONV(J,:) = 1d4 + & / ADJOINT_AREA_M2 + & * GET_AREA_CM2(J) + + ! molec -> kgN + TR_DDEP_CONV(J,:) = TR_DDEP_CONV(J,:) + & * 14D-3 / 6.022D23 + + ! s -> yr + TR_DDEP_CONV(J,:) = TR_DDEP_CONV(J,:) + & * 86400D0 * 365D0 + + ENDDO + ELSE + DO J = 1, JJPAR + TR_DDEP_CONV(J,:) = 1d8 + & * 14D-3 / 6.022D23 * 86400D0 * 365D0 + ENDDO + ENDIF + + ENDIF + + !equivalent ha(-1) yr(-1) + IF ( LEQHAYR ) THEN + IF ( LFORCE_MASK ) THEN + DO N = 1, N_TRACERS + IF ( OBS_THIS_TRACER(N) ) THEN + DO J = 1, JJPAR + TR_DDEP_CONV(J,N) = + & 1D0 / 6.022D23 + & * 86400D0 * 365D0 + & * 1D4 / ADJOINT_AREA_M2 + & * GET_AREA_CM2(J) + + IF ( N .EQ. IDTSO4 + & .OR. N .EQ. IDTSO2) THEN + TR_DDEP_CONV(J,N) = TR_DDEP_CONV(J,N) + & * 2D0 + IF ( J .EQ. 1) THEN + WRITE(6,100) TRIM(TRACER_NAME(N)) + ENDIF + ENDIF + + ENDDO + ENDIF + ENDDO + + ELSE + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + DO J= 1, JJPAR + TR_DDEP_CONV(J,N) = 1d0 + & / 6.022D23 + & * 86400D0 * 365D0 * 1D8 + + IF ( N .EQ. IDTSO4 + & .OR. N .EQ. IDTSO2 ) THEN + + TR_DDEP_CONV(J,N) = TR_DDEP_CONV(J,N) + & * 2D0 + + IF ( J .EQ. 1) THEN + WRITE(6,100) TRIM(TRACER_NAME(N)) + ENDIF + + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ENDIF + ENDIF + + IF ( LADJ_DDEP_CSPEC ) THEN + + ALLOCATE( CS_DDEP_CONV(JJPAR,NOBS_CSPEC), STAT = AS ) + IF ( AS /=0 ) CALL ALLOC_ERR('CS_DDEP_CONV') + + CS_DDEP_CONV(:,:) = 0D0 + + !default unit + IF ( LMOLECCM2S ) THEN + IF ( LFORCE_MASK ) THEN + DO J = 1, JJPAR + CS_DDEP_CONV(J,:) = + & GET_AREA_CM2(J) / ADJOINT_AREA_M2 * 1D-4 + ENDDO + ELSE + CS_DDEP_CONV(:,:) = 1d0 + ENDIF + ENDIF + +! IF ( LKGS ) THEN +! DO N = 1, NOBS_CSPEC +! DO J = 1, JJPAR +!this requires to know the molecular weight of cspec species. +!I don't think there is a way to know that without further user input. +!for now make it impossible to turn on lkgs when observing cspec +! TR_DDEP_CONV(J,:) = +! & TRACER_MW_CSPEC(N)/6.022D23*GET_AREA_CM2(J) +! ENDDO +! ENDDO +! ENDIF + + ! kg N / ha / yr + IF ( LKGNHAYR ) THEN + + ! a receptor region is defined + IF ( LFORCE_MASK ) THEN + + DO N = 1, NOBS_CSPEC + + DO J = 1, JJPAR + + ! area conversion + CS_DDEP_CONV(J,N) = GET_AREA_CM2(J) + & * 1D4 / ADJOINT_AREA_M2 + + ! time conversion + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 86400D0 * 365D0 + + ! molec->kgN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 14D-3 / 6.022D23 + + IF (TRIM(CNAME(N)) .EQ. 'DRYN2O5') THEN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 2D0 + IF ( J .EQ. 1 ) THEN + WRITE(*,*) '-> 2N in N2O5' !fp check + ENDIF + ENDIF + + ENDDO + + ENDDO + + ELSE + + DO N = 1,NOBS_CSPEC + + DO J=1,JJPAR + + ! area conversion (cm2->ha) + CS_DDEP_CONV(J,N) = 1D8 + + ! time conversion + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 86400D0 * 365D0 + + ! molec->kgN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 14D-3 / 6.022D23 + + IF (CNAME(N) .EQ. 'DRYN2O5') THEN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 2D0 + IF ( J .EQ. 1 ) THEN + WRITE(*,*) '-> 2N in N2O5' !fp check + ENDIF + ENDIF + + ENDDO + + ENDDO + + ENDIF + + ENDIF + + IF ( LEQHAYR ) THEN + + ! a receptor region is defined + IF ( LFORCE_MASK ) THEN + + DO N = 1,NOBS_CSPEC + + DO J = 1, JJPAR + + ! area conversion + CS_DDEP_CONV(J,N) = GET_AREA_CM2(J) + & * 1D4 / ADJOINT_AREA_M2 + + ! time conversion + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 86400D0 * 365D0 + + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 1D0 / 6.022D23 + + IF (CNAME(N) .EQ. 'DRYN2O5') THEN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 2D0 + IF ( J .EQ. 1 ) THEN + WRITE(6,100) 'N2O5' + ENDIF + ENDIF + + ENDDO + + ENDDO + + ELSE + + DO N = 1, NOBS_CSPEC + + DO J = 1, JJPAR + + ! area conversion (cm2->ha) + CS_DDEP_CONV(J,N) = 1D8 + + ! time conversion + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 86400D0 * 365D0 + + ! molec->mueq + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 1D0 / 6.022D23 + IF (TRIM(CNAME(N)) .EQ. 'DRYN2O5') THEN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 2D0 + IF ( J .EQ. 1 ) THEN + WRITE(6,100) 'N2O5' + ENDIF + ENDIF + + ENDDO + + ENDDO + + ENDIF + + ENDIF + + ENDIF + + ! Use the same unit conversion array for both convective and large-scale + ! precipitation + IF ( LADJ_WDEP_CV .or. LADJ_WDEP_LS ) THEN + + ALLOCATE( TR_WDEP_CONV(JJPAR,N_TRACERS), STAT = AS ) + IF (AS /=0) CALL ALLOC_ERR('TR_WDEP_CONV') + + TR_WDEP_CONV(:,:) = 0d0 + + ! from kg/s to molec/cm2/s + IF ( LMOLECCM2S ) THEN + + IF ( LFORCE_MASK ) THEN + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + ! kg -> molec + TR_WDEP_CONV(:,N) = + & 6.022D23 * 1D0 / TRACER_MW_KG(N) + + ! to cm2 + TR_WDEP_CONV(:,N) = 1D-4 / ADJOINT_AREA_M2 + & * TR_WDEP_CONV(:,N) + + ENDIF + + ENDDO + + ELSE + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + ! kg -> molec + TR_WDEP_CONV(:,N) = 6.022D23 * 1D0 + & / TRACER_MW_KG(N) + ! to cm2 + DO J = 1, JJPAR + TR_WDEP_CONV(J,N) = 1D0 / GET_AREA_CM2(J) + & * TR_WDEP_CONV(J,N) + ENDDO + + ENDIF + + ENDDO + + ENDIF + + ENDIF + + IF ( LKGS ) THEN + TR_WDEP_CONV(:,:) = 1D0 + ENDIF + + ! convert from kg/s to kgn/ha/yr + IF ( LKGNHAYR ) THEN + + IF ( LFORCE_MASK ) THEN + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + ! kg->kgN !NOTE THIS ASSUMES ONLY ONE N PER MOLECULE (by default) + TR_WDEP_CONV(:,N) = 14D-3 / TRACER_MW_KG(N) + + !for N2O5 account for 2N + IF ( N .eq. IDTN2O5 ) + & TR_WDEP_CONV(:,N) = TR_WDEP_CONV(:,N) * 2D0 + + ! s to yr + TR_WDEP_CONV(:,N) = 86400D0 * 365D0 + & *TR_WDEP_CONV(:,N) + + ! to ha + TR_WDEP_CONV(:,N) = 1D4 / ADJOINT_AREA_M2 + & * TR_WDEP_CONV(:,N) + + ENDIF + + ENDDO + + ELSE + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + DO J = 1, JJPAR + + ! kg->kgN !NOTE THIS ASSUMES ONLY ONE N PER MOLECULE + TR_WDEP_CONV(J,N) = 14D-3 / TRACER_MW_KG(N) + + !for N2O5 account for 2N + IF ( N .eq. IDTN2O5 ) + & TR_WDEP_CONV(J,N) = TR_WDEP_CONV(J,N) * 2D0 + + ! s to yr + TR_WDEP_CONV(J,N) = 86400D0 * 365D0 + & * TR_WDEP_CONV(J,N) !s to yr + + ! to ha + TR_WDEP_CONV(J,N) = 1D8 / GET_AREA_CM2(J) + & * TR_WDEP_CONV(J,N) + + ENDDO + + ENDIF + + ENDDO + + ENDIF + + ENDIF + + IF ( LEQHAYR ) THEN + + ! convert from kg/s to eq/ha/yr + IF ( LFORCE_MASK ) THEN + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + DO J = 1, JJPAR + + !kg -> mole + TR_WDEP_CONV(J,N) = 1D0 + & / TRACER_MW_KG(N) + + IF ( IDTSO4 .EQ. N + & .OR. IDTSO2 .EQ. N + & .OR. IDTN2O5 .EQ. N) THEN + TR_WDEP_CONV(J,N) = TR_WDEP_CONV(J,N) + & * 2d0 + ENDIF + + ! s to yr + TR_WDEP_CONV(J,N) = 86400D0 * 365D0 + & * TR_WDEP_CONV(J,N) + + ! to ha + TR_WDEP_CONV(J,N) = 1D4 / ADJOINT_AREA_M2 + & * TR_WDEP_CONV(J,N) + + ENDDO + + ENDIF + + ENDDO + + ELSE + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + DO J = 1, JJPAR + + !convert to moles from kg + TR_WDEP_CONV(J,N) = 1D0 + & / TRACER_MW_KG(N) + + IF ( IDTSO4 .EQ. N + & .OR. IDTSO2 .EQ. N + & .OR. IDTN2O5 .EQ. N) THEN + TR_WDEP_CONV(J,N) = TR_WDEP_CONV(J,N) + & * 2d0 + ENDIF + + ! s to yr + TR_WDEP_CONV(J,N) = 86400D0 * 365D0 + & * TR_WDEP_CONV(J,N) + ! to ha + TR_WDEP_CONV(J,N) = 1D8 / GET_AREA_CM2(J) + & * TR_WDEP_CONV(J,N) + + ENDDO + + ENDIF + + ENDDO + + ENDIF + + ENDIF + + ENDIF + + 100 FORMAT('2 equivalents in ',a) + + ! return to calling program + END SUBROUTINE INIT_UNITS_DEP + +!------------------------------------------------------------------------------ + SUBROUTINE INIT_CF_REGION +! +!****************************************************************************** +! Subroutine INIT_CF_REGION assigns values to CF_REGION, which determines the +! 3D spatial domain over which to evaluation the cost function. +! +! NOTES: +! (1 ) Setting weight = 1 is equivalent to saying that the uncertainty in each +! observation is of order 1 / OBS^2. +! (2 ) Add OBS_THIS_SPECIES and OPT_THIS_SPECIES, both default FALSE. +! (dkh, 03/25/05) +! (3 ) Add OPT_THIS_EMS. (dkh, 03/29/05) +! (4 ) Replace RETURN with IFELSE so that safety catches at the end are always +! checked (dkh, 06/07/05) +! (5 ) Updated for v8 ajd (dkh, ks, mak, cs 06/12/09) +! (6 ) Add support for LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (7 ) Replaced WEIGHT with CF_REGION (dkh, 03/13/13) +!****************************************************************************** +! + ! Reference to f90 modules + USE DAO_MOD, ONLY : IS_LAND + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_AREA_M2 + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE LOGICAL_ADJ_MOD, ONLY : LICS + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_OBS + USE LOGICAL_ADJ_MOD, ONLY : LFORCE_MASK + USE LOGICAL_ADJ_MOD, ONLY : LFORCE_MASK_BPCH, LFORCE_MASK_NC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_MOD, ONLY : LRCPTR_MASK + USE TRACER_MOD, ONLY : N_TRACERS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CL + USE CRITICAL_LOAD_MOD,ONLY : GET_CL_EXCEEDENCE + ! add for reaction rates (tww, 05/15/12) + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + +# include "CMN_SIZE" ! Size params +# include "define_adj.h" ! the obs operators + + ! Local variables + LOGICAL :: AT_LEAST_ONE = .FALSE. + INTEGER :: I, J, L, N + REAL*8 :: MASK(IIPAR,JJPAR) + REAL*8 :: MASK_CL(IIPAR,JJPAR) + + !================================================================= + ! INIT_CF_REGION begins here! + !================================================================= + + WRITE(6,*) ' SET CF_REGION ' + + ! Quickly define the weight array for the FD case + IF ( LFDTEST ) THEN + + IF ( LFD_GLOB ) THEN + WRITE( 6, * ) 'USE OBSERVATIONS IN LFD' + CF_REGION(:,:,LFD) = 1d0 + + IF ( LADJ_FDEP ) CF_REGION(:,:,:) = 1D0 + + ELSEIF ( LFD_SPOT ) THEN + WRITE( 6, * ) 'USE OBSERVATIONS ONLY IN FINITE DIFF CELLS' + WRITE( 6, * ) ' (IFD, JFD, LFD, NFD) = ', IFD,JFD,LFD,NFD + CF_REGION(IFD,JFD,LFD) = 1d0 + + IF ( LCSPEC_OBS ) CF_REGION(IFD,JFD,:) = 1d0 + + ENDIF + + ! Reset defaults so that NFD overides observation menu (dkh, 02/11/11) + OBS_THIS_TRACER(:) = .FALSE. + OBS_THIS_TRACER(NFD) = .TRUE. + + IF ( LCSPEC_OBS ) THEN + OBS_THIS_SPECIES(:) = .FALSE. + OBS_THIS_SPECIES(NFD) = .TRUE. + ENDIF + + IF ( LADJ_EMS ) THEN + + ! Reset defaults so that EMSFD overides control variable menu (dkh, 02/11/11) + OPT_THIS_EMS(:) = .FALSE. + + OPT_THIS_EMS(EMSFD) = .TRUE. + + ! Add support for strat fluxes (hml, dkh, 02/14/12, adj32_025) + IF ( LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + + ! Reset defaults so that STRFD overides control variabel menu (hml, 08/11/11) + OPT_THIS_EMS(EMSFD) = .FALSE. + OPT_THIS_PROD(:) = .FALSE. + OPT_THIS_LOSS(:) = .FALSE. + + ! By default, test the adjoints for the LOSS terms. + !OPT_THIS_PROD(STRFD) = .TRUE. + OPT_THIS_LOSS(STRFD) = .TRUE. + + ENDIF + + ! Add support for reaction rates (tww, 05/15/12) + ! To make LADJ_RRATE as a default when EMS, STRAT, and RRATE are all T (hml, 06/08/13) + IF ( LADJ_RRATE ) THEN + + OPT_THIS_EMS(EMSFD) = .FALSE. + OPT_THIS_RATE(:) = .FALSE. + OPT_THIS_PROD(:) = .FALSE. + OPT_THIS_LOSS(:) = .FALSE. + + OPT_THIS_RATE(RATFD) = .TRUE. + + ENDIF + + + ELSEIF ( LICS ) THEN + + ! Reset defaults so that ICSFD overides control variabel menu (dkh, 02/11/11) + OPT_THIS_TRACER(:) = .FALSE. + + OPT_THIS_TRACER(ICSFD) = .TRUE. + + ENDIF + + ! Manually define things for other cases + + ! Spatial domain of cost function + ELSE + + IF ( LFORCE_MASK .OR. LADJ_CL .OR. LRCPTR_MASK ) THEN + + IF ( LADJ_CL ) THEN + CALL GET_CL_EXCEEDENCE( MASK ) + ELSEIF ( LRCPTR_MASK ) THEN + MASK = READ_MASK_HTAP() + CALL GET_CL_EXCEEDENCE( MASK_CL ) + ELSE + MASK_CL(:,:) = 1D0 + END IF + + IF ( LFORCE_MASK ) THEN + IF ( LFORCE_MASK_BPCH ) THEN + MASK = READ_MASK( FORCING_MASK_FILE ) + ELSEIF ( LFORCE_MASK_NC ) THEN + CALL READ_MASK_NC( MASK ) + ENDIF + ELSE + MASK(:,:) = 1D0 + ENDIF + + + IF ( LRCPTR_MASK ) MASK = READ_MASK_HTAP() + + CF_REGION(:,:,:) = 0d0 + + ! 2D mask defining cost function region + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Extend mask throughout the column + IF ( MASK(I,J) > 0d0 ) THEN + CF_REGION(I,J,:) = MASK(I,J)*MASK_CL(I,J) + ENDIF + + ENDDO + ENDDO + + ELSE + + CF_REGION(:,:,:) = 1d0 + + ENDIF + + ENDIF + + + + IF ( LADJ_FDEP .and. LFORCE_MASK) THEN + + ADJOINT_AREA_M2 = 0d0 + + DO J = 1, JJPAR + DO I = 1, IIPAR + ADJOINT_AREA_M2 = ADJOINT_AREA_M2 + & + GET_AREA_M2( J ) + & * CF_REGION(I,J,1) + ENDDO + ENDDO + + WRITE(*,*) 'ADJOINT AREA (M2)',ADJOINT_AREA_M2 + + ELSE + + ADJOINT_AREA_M2 = 0d0 + + ENDIF + +!! Some compilers won't do this loop in parallel (dkh, mak) +!!!$OMP PARALLEL DO +!!!$OMP+DEFAULT( SHARED ) +!!!$OMP+PRIVATE( I, J, L, N ) +! DO N = 1, N_TRACERS +! !! dkh debug -- this is really strange +! !print*, ' if i dont print something here i will crash ' +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! IF ( OBS_THIS_TRACER(N) ) THEN +!! & .and. IS_LAND(I,J) ! Only the land species +!! & .and. ( MOD( I, 2 ) == 0 ) ! Only in every other cell +!! & .and. L == 1 ! Only at the surface +!! & .and. J >= 10 ! Not in antarctica +!! & .and. I < 42 .and. I > 34 ! IN +!! & .and. J > 32 .and. J < 39 ! EUROPE +!! & .and. I > 18 .and. I < 23 ! IN +!! & .and. J > 30 .and. J < 35 ! Eastern US +!! & .and. I > 11 .and. I < 23 ! IN +!! & .and. J > 30 .and. J < 35 ! US +!! & .and. I > 58 .and. I < 63 ! IN +!! & .and. J > 30 .and. J < 34 ! Eastern China +!! & .and. J >= 32 .and. J <= 33 ! +!! & .and. I >= 20 .and. I <= 21 ! +!! & ) THEN +! +! WEIGHT(I,J,L,N) = 1d0 +! !if ( n == 1 ) print*, 'observe in ',i, j +! +! ELSE +! +! WEIGHT(I,J,L,N) = 0d0 +! +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +! ENDDO +!!!$OMP END PARALLEL DO +! +! ENDIF + + ! BUG FIX: Only check this if no real obs operators are turned on (dkh, 07/30/10) + ! Now support IMPROVE_BC_OC_OBS (yhmao, dkh, 01/16/12, adj32_013) + ! Now support MOPITT_V5_CO_OBS (zhej, dkh, 01/16/12, adj32_016) + ! Now support CH4 operators (kjw, dkh, 02/12/12, adj32_023) +#if !defined(MOPITT_V5_CO_OBS) && !defined(MOPITT_V6_CO_OBS) && !defined(MOPITT_V7_CO_OBS) && !defined(AIRS_CO_OBS) && !defined(SCIA_BRE_CO_OBS) && !defined(TES_NH3_OBS)&& !defined(SCIA_DAL_SO2_OBS) && !defined(PM_ATTAINMENT) && !defined(IMPROVE_SO4_NIT_OBS) && !defined(CASTNET_NH4_OBS) && !defined(SOMO35_ATTAINMENT) && !defined(TES_O3_OBS)&& !defined(SCIA_KNMI_NO2_OBS) && !defined(SCIA_DAL_NO2_OBS) && !defined(GOSAT_CO2_OBS) && !defined(IMPROVE_BC_OC_OBS) && !defined(TES_CH4_OBS) && !defined(SCIA_CH4_OBS) && !defined(MEM_CH4_OBS) && !defined (LEO_CH4_OBS) && !defined(GEOCAPE_CH4_OBS) && !defined(TES_O3_IRK) && !defined( OMI_SO2_OBS ) && !defined( OMI_NO2_OBS ) + + ! Check to make sure that at least something is being observed somewhere + IF ( MAXVAL( CF_REGION(:,:,:) ) == 0d0 ) THEN + CALL ERROR_STOP( ' No observations! ', + & ' INIT_CF_REGION, adjoint_mod.f ') + ENDIF + + ! Check to make sure at least one species or emission is being optimized + DO N = 1, N_TRACERS + IF ( OPT_THIS_TRACER(N) ) THEN + AT_LEAST_ONE = .TRUE. + ENDIF + ENDDO + +!#endif + + ! added this (dkh, 10/17/06) + IF ( LADJ_EMS ) THEN + DO N = 1, NNEMS + IF ( OPT_THIS_EMS(N) ) THEN + AT_LEAST_ONE = .TRUE. + ENDIF + ENDDO + + ! added this (hml, 08/20/11, adj32_025) + IF ( LADJ_STRAT ) THEN + DO N = 1, NSTPL + ! prod and loss cannot be perturbed at the same time + IF ( OPT_THIS_PROD(N) .OR. OPT_THIS_LOSS(N) ) THEN + AT_LEAST_ONE = .TRUE. + ENDIF + ENDDO + ENDIF + + ! added this (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN + DO N = 1, NRRATES + IF ( OPT_THIS_RATE(N) ) THEN + AT_LEAST_ONE = .TRUE. + ENDIF + ENDDO + ENDIF + + + ENDIF + + ! Error stop if no species are optimized + IF ( .not. AT_LEAST_ONE ) THEN + CALL ERROR_STOP( ' No variables to optimize!', + & ' INIT_CF_REGION, adjoint_mod.f' ) + ENDIF + + ! move this to here to allow for sensitivity studies of LICS with obs operators + ! (dkh, 08/25/10) +#endif + + ! Return to calling program + END SUBROUTINE INIT_CF_REGION + +!----------------------------------------------------------------------------- + + FUNCTION GET_CF_REGION(I,J,L) RESULT( W ) +! +!****************************************************************************** +! Function GET_CF_REGION returns the value of the cost function weighting +! array, CF_WEIGHT. (dkh, 06/12/09) +! +! NOTES: +! (1 ) Replace WEIGHT with CF_REGION (dkh, 03/13/13) +! +!****************************************************************************** +! + ! Function value + REAL*8 :: W + + ! Function arguments + INTEGER :: I, J, L, N + + !================================================================= + ! GET_CF_REGION begins here! + !================================================================= + + W = CF_REGION(I,J,L) + + ! Return to calling program + + END FUNCTION GET_CF_REGION +!----------------------------------------------------------------------------- + + FUNCTION ITS_TIME_FOR_OBS() RESULT( FLAG ) +! +!****************************************************************************** +! Function ITS_TIME_FOR_OBS returns TRUE if it is time for and +! observation +! and false otherwise. (dkh, 8/31/04) +! +! NOTES: +! (1 ) Add the L_NO_FIRST_OBS flag to make optional inclusion of the +! first time step +! as an observation time step. dkh, 02/21/05 +! (2 ) Add support for L_YES_LAST_OBS flag to force an observation at +! the second to +! last dynamic time step (the first step of the backwd +! integration) +! (dkh, 03/07/05) +! (3 ) Reorder IFELSE structure so that now L_YES_LAST_OBS overides +! L_NO_FIRST_OBS +! if the simulation is only one TS_CHEM long, ensuring that an +! observation +! will be made in this case (dkh, 06/11/05). +! (4 ) Add support for CH4 (kjw, dkh, 02/12/12, adj32_023) +!****************************************************************************** +! + ! Reference to f90 modules + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST + USE TIME_MOD, ONLY : GET_ELAPSED_MIN + USE TIME_MOD, ONLY : GET_TIME_AHEAD + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM + + +# include "CMN_SIZE" ! Size params for CMN_ADJ + + ! Function value + LOGICAL :: FLAG + + ! Local variables + INTEGER :: DATE(2) + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! ITS_TIME_FOR_OBS begins here! + !================================================================= + + ! Now for FDTEST force FLAG to TRUE on the first attempt during + ! the adjoint integration and false otherwise (dkh, 06/24/09) + IF ( LFDTEST ) THEN + + ! BUG FIS: only force it to be TRUE on the first chemistry + ! time step. (dkh, 07/14/09) + !IF ( FIRST ) THEN + IF ( MOD( GET_ELAPSED_MIN(), GET_TS_CHEM() ) == 0 + & .and. FIRST ) THEN + + FLAG = .TRUE. + FIRST = .FALSE. + + ELSE + + FLAG = .FALSE. + + ENDIF + + ! Return to calling program + RETURN + + ELSE + + FLAG = ( MOD( GET_ELAPSED_MIN(), OBS_FREQ ) == 0 ) + + ENDIF + + ! Return to calling program + + END FUNCTION ITS_TIME_FOR_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_NUM_SAT + +# include "define_adj.h" + + SAT = 0 + + ! Now support MOPITT_V5_CO_OBS (zhej, dkh, 01/16/12, adj32_016) +#if defined (MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS) || defined (MOPITT_V7_CO_OBS) + SAT = 1 + !Print*, 'ONLY MOPITT OBS, sat is:', SAT +#endif + +#if defined (SCIA_BRE_CO_OBS) + SAT = 2 + !Print*, 'SCIA BRE OBS, sat is:', SAT +#endif + +#if defined (AIRS_CO_OBS) + SAT = 3 + !Print*, 'AIRS OBS, sat is:', SAT +#endif + + END SUBROUTINE CALC_NUM_SAT + +!------------------------------------------------------------------------------ + + SUBROUTINE SET_EMS_ORIG( I, J, K, VALUE ) +! +!****************************************************************************** +! Subroutine SET_EMS_ORIG writes a value to EMS_orig. (mak, bmy, 3/14/06) +! Now lump all emissions by getting rid of one dimension (mak, 1/19/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 2nd dimension of array +! (3 ) K (INTEGER) : Index for time step dimension of array max=MMSCL +! (5 ) VALUE (REAL* ) : Value to store in (I,J,K)th element of array +! +! NOTES: +!****************************************************************************** +! + !USE TIME_MOD, ONLY : GET_DAY, GET_HOUR + + ! Arguments + INTEGER, INTENT(IN) :: I, J, K + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_EMS_orig begins here! + !================================================================= + EMS_orig(I,J,K) = EMS_orig(I,J,K) + VALUE + + ! for hourly emissions saving +! EMS_orig(I,J,GET_DAY(), GET_HOUR()) = +! & EMS_orig(I,J,GET_DAY(), GET_HOUR()) + VALUE + + ! Return to calling program + END SUBROUTINE SET_EMS_ORIG + +!----------------------------------------------------------------------------- + + FUNCTION GET_EMS_ORIG( I, J, K ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_EMS_ORIG gets a value from EMS_orig. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) K (INTEGER) : Index of chem/ems time steps of the simulation +! (4 ) N (INTEGER) : Index of ems/source types to be optimized +! (5 ) VALUE (REAL*8 ) : Value to store in (I,J,K,N)th element of array +! +! NOTES: +!****************************************************************************** +! + !USE TIME_MOD, ONLY : GET_DAY, GET_HOUR + + ! Arguments + INTEGER, INTENT(IN) :: I, J, K + + ! Function value + REAL*8 :: VALUE + + !================================================================= + ! GET_EMS_orig begins here! + !================================================================= + VALUE = EMS_orig(I,J,K) + + ! Return to calling program + END FUNCTION GET_EMS_ORIG + +!----------------------------------------------------------------------------- + + + SUBROUTINE SET_FORCING( I, J, D, VALUE ) +! +!****************************************************************************** +! Subroutine SET_FORCING writes a value to FORCING. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_FORCING begins here! + !================================================================= + FORCING(I,J,D) = FORCING(I,J,D) + VALUE + + ! Return to calling program + END SUBROUTINE SET_FORCING + +!----------------------------------------------------------------------------- + + FUNCTION GET_FORCING( I, J, D ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_FORCING gets a value from FORCING. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_FORCING begins here! + !================================================================= + VALUE = FORCING(I,J,D) + + ! Return to calling program + END FUNCTION GET_FORCING + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_MOP_MOD_DIFF( I, J, D, VALUE ) +! +!****************************************************************************** +! Subroutine SET_MOP_MOD_DIFF writes a value to MOP_MOD_DIFF. +! (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_MOP_MOD_DIFF begins here! + !================================================================= + MOP_MOD_DIFF(I,J,D) = MOP_MOD_DIFF(I,J,D) + VALUE + + ! Return to calling program + END SUBROUTINE SET_MOP_MOD_DIFF + +!----------------------------------------------------------------------------- + + FUNCTION GET_MOP_MOD_DIFF( I, J, D ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_MOP_MOD_DIFF gets a value from MOP_MOD_DIFF. +! (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_MOP_MOD_DIFF begins here! + !================================================================= + VALUE = MOP_MOD_DIFF(I,J,D) + + ! Return to calling program + END FUNCTION GET_MOP_MOD_DIFF + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_MODEL_BIAS( I, J, D, N, VALUE ) +! +!****************************************************************************** +! Subroutine SET_MODEL_BIAS writes a value to MODEL_BIAS. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, N + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_MODEL_BIAS begins here! + !================================================================= + MODEL_BIAS(I,J,D,N) = MODEL_BIAS(I,J,D, N) + VALUE + + ! Return to calling program + END SUBROUTINE SET_MODEL_BIAS + +!----------------------------------------------------------------------------- + + FUNCTION GET_MODEL_BIAS( I, J, D,n ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_MODEL_BIAS gets a value from MODEL_BIAS. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, N + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_MODEL_BIAS begins here! + !================================================================= + VALUE = MODEL_BIAS(I,J,D, N) + + ! Return to calling program + END FUNCTION GET_MODEL_BIAS + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_MODEL( I, J, D, s, VALUE ) +! +!****************************************************************************** +! Subroutine SET_MODEL_BIAS writes a value to MODEL. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_MODEL begins here! + !================================================================= + MODEL(I,J,D,s) = VALUE + + ! Return to calling program + END SUBROUTINE SET_MODEL + +!----------------------------------------------------------------------------- + + FUNCTION GET_MODEL( I, J, D, s ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_MODEL gets a value from MODEL. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_MODEL begins here! + !================================================================= + VALUE = MODEL(I,J,D,s) + + ! Return to calling program + END FUNCTION GET_MODEL + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_OBS( I, J, D, s, VALUE ) +! +!****************************************************************************** +! Subroutine SET_OBS writes a value to OBS. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) s (INTEGER) : Index for SATELLITE DATASET NUMBER +! (5 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_OBS begins here! + !================================================================= + OBS(I,J,D,s) = VALUE + + ! Return to calling program + END SUBROUTINE SET_OBS + +!----------------------------------------------------------------------------- + + FUNCTION GET_OBS( I, J, D, s ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_OBS gets a value from OBS. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for LAT +! (2 ) J (INTEGER) : Index for LON +! (3 ) D (INTEGER) : Index for DAY OF SIMULATION +! (4 ) s (INTEGER) : Index for SATELLITE DATASET NUMBER +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_OBS begins here! + !================================================================= + VALUE = OBS(I,J,D,s) + + ! Return to calling program + END FUNCTION GET_OBS + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_DOFS( I, J, D, s, VALUE ) +! +!****************************************************************************** +! Subroutine SET_DOFS writes a value to SAT_DOFS. (mak, bmy, 3/14/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_MODEL begins here! + !================================================================= + SAT_DOFS(I,J,D,s) = VALUE + + ! Return to calling program + END SUBROUTINE SET_DOFS + +!----------------------------------------------------------------------------- + + FUNCTION GET_DOFS( I, J, D, s ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_DOFS gets a value from SAT_DOFS. (mak, bmy, 3/14/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_MODEL begins here! + !================================================================= + VALUE = SAT_DOFS(I,J,D,s) + + ! Return to calling program + END FUNCTION GET_DOFS + +!----------------------------------------------------------------------------- + + SUBROUTINE CHECK_STT_ADJ( LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK_STT_ADJ checks the STT_ADJ array for +! NaN values, or Infinity values. If any of these are found, the code +! will stop with an error message. (bmy, 3/8/01, 10/3/05) +! (dkh, ks, mak, cs 06/12/09) +! +! Arguments as Input: +! ============================================================================ +! (1) LOCATION (CHARACTER) : String describing location of error in code +! +! NOTES: +! (1 ) Based on CHECK_STT from the forward model. +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE ERROR_MOD, ONLY : IT_IS_NAN + USE ERROR_MOD, ONLY : IT_IS_FINITE + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: LOCATION + + ! Local variables + LOGICAL :: LNAN, LINF + INTEGER :: I, J, L, N + + !================================================================= + ! CHECK_STT_ADJ begins here! + !================================================================= + + ! Initialize + LNAN = .FALSE. + LINF = .FALSE. + + ! Loop over grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + !--------------------------- + ! Check for NaN's + !--------------------------- + IF ( IT_IS_NAN( STT_ADJ(I,J,L,N) ) ) THEN +!$OMP CRITICAL + LNAN = .TRUE. + WRITE( 6, 100 ) I, J, L, N, STT_ADJ(I,J,L,N) +!$OMP END CRITICAL + + !---------------------------- + ! Check STT's for Infinities + !---------------------------- + ELSE IF ( .not. IT_IS_FINITE( STT_ADJ(I,J,L,N) ) ) THEN +!$OMP CRITICAL + LINF = .TRUE. + WRITE( 6, 100 ) I, J, L, N, STT_ADJ(I,J,L,N) +!$OMP END CRITICAL + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Stop the run if any of LNAN, LINF is true + !================================================================= + IF ( LNAN .or. LINF ) THEN + WRITE( 6, 120 ) TRIM( LOCATION ) + CALL GEOS_CHEM_STOP + ENDIF + + !================================================================= + ! FORMAT statements + !================================================================= + 100 FORMAT( 'CHECK_STT_ADJ: STT_ADJ(',i3,',',i3,',',i3,',',i3,') = ', + & f13.6 ) + 120 FORMAT( 'CHECK_STT_ADJ: STOP at ', a ) + + ! Return to calling program + END SUBROUTINE CHECK_STT_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_STT_05x0666_ADJ( LOCATION ) + +!****************************************************************************** +! +! Subroutine CHECK\_STT\_05x0666_ADJ checks the STT tracer array for +! NaN values, or Infinity values. If any of these are found, +! the STT array will be set to a specified value. +! +! Arguments as Input: +! ============================================================================ +! (1) LOCATION (CHARACTER) : String describing location of error in code +! +! NOTES: +! 23 May 2013 - Y. Davila - Initial version based on CHECK_STT_ADJ and updates +! for nested grid by Yuxuan Wang. +!****************************************************************************** + + ! References to F90 modules + USE ERROR_MOD, ONLY : IT_IS_NAN + USE ERROR_MOD, ONLY : IT_IS_FINITE + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: LOCATION + + + + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! CHECK_STT_05x0666_ADJ begins here! + !================================================================= + + ! Loop over grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + +! In CHECK_STT_ADJ we don't check for negatives values (yd 5/23/2013) +! !--------------------------- +! ! Check for Negatives +! !--------------------------- +! IF ( STT(I,J,L,N) < 0d0 ) THEN +!!$OMP CRITICAL +! WRITE( 6, 100 ) I, J, L, N, STT_ADJ(I,J,L,N) +! PRINT*, 'Neg STT_ADJ ' // TRIM( LOCATION ) // +! & '. SET STT_ADJ TO BE ZERO.' +! STT_ADJ(I,J,L,N) = 0d0 +!!$OMP END CRITICAL + + !--------------------------- + ! Check for NaN's + !--------------------------- + IF ( IT_IS_NAN( STT_ADJ(I,J,L,N) ) ) THEN +!$OMP CRITICAL + WRITE( 6, 100 ) I, J, L, N, STT_ADJ(I,J,L,N) + PRINT*, 'NaN STT_ADJ ' // TRIM( LOCATION ) // + & '. SET STT_ADJ TO BE LOWER LEVEL.' + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L-1,N) +!$OMP END CRITICAL + + !---------------------------- + ! Check STT's for Infinities + !---------------------------- + ELSE IF ( .not. IT_IS_FINITE( STT_ADJ(I,J,L,N) ) ) THEN +!$OMP CRITICAL + WRITE( 6, 100 ) I, J, L, N, STT_ADJ(I,J,L,N) + PRINT*, 'Inf STT_ADJ ' // TRIM( LOCATION ) // + & '. SET STT_ADJ TO BE LOWER LEVEL.' + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L-1,N) +!$OMP END CRITICAL + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + 100 FORMAT( ' STT_ADJ(',i3,',',i3,',',i3,',',i3,') = ', f13.6 ) + + END SUBROUTINE CHECK_STT_05x0666_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE EXPAND_NAME( FILENAME, N_ITRN ) +! +!****************************************************************************** +! Subroutine EXPAND_DATE replaces "NN" token within +! a filename string with the actual values. (bmy, 6/27/02, 12/2/03) +! (dkh, 9/22/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Filename with tokens to replace +! (2 ) N_ITRN (INTEGER ) : Current iteration number +! +! +! Arguments as Output: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Modified filename +! +! NOTES: +! (1 ) Based on EXPAND_DATE +! +!****************************************************************************** +! + ! References to F90 modules + USE CHARPAK_MOD, ONLY : STRREPL + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "define.h" + + ! Arguments + CHARACTER(LEN=*), INTENT(INOUT) :: FILENAME + INTEGER, INTENT(IN) :: N_ITRN + + ! Local variables + CHARACTER(LEN=2) :: NN_STR + + !================================================================= + ! EXPAND_NAME begins here! + !================================================================= + +#if defined( LINUX_PGI ) + + ! Use ENCODE statement for PGI/Linux (bmy, 9/29/03) + ENCODE( 2, '(i2.2)', NN_STR ) N_ITRN + +#else + + ! For other platforms, use an F90 internal write (bmy, 9/29/03) + WRITE( NN_STR, '(i2.2)' ) N_ITRN + +#endif + + ! Replace NN token w/ actual value + CALL STRREPL( FILENAME, 'NN', NN_STR ) + + + ! Return to calling program + END SUBROUTINE EXPAND_NAME + +!----------------------------------------------------------------------------- + + FUNCTION GET_SCALE_GROUP( ) RESULT( CURRENT_GROUP ) +! +!******************************************************************************** +! Subroutine GET_SCALE_GROUP determines which predifined scaling index corresponds +! to the current time and location (dkh, 12/02/04) +! +! NOTES +! (1 ) CURRENT_GROUP is currently only a function of TAU +! (2 ) Get rid of I,J as argument. (dkh, 03/28/05) +! +!******************************************************************************** + + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD,ONLY : LICS + +# include "CMN_SIZE" ! Size stuff + + ! Arguments + INTEGER :: CURRENT_GROUP + + ! Local Variables + + !============================================================ + ! GET_SCALE_GROUP begins here! + !============================================================ + + ! Currently there is no spatial grouping + IF ( LICS ) THEN + print*, ' SET MMSLC = 1 for LICS ' + CURRENT_GROUP = 1 + RETURN + ENDIF + + ! Determine temporal grouping + IF ( MMSCL == 1 ) THEN + CURRENT_GROUP = 1 + RETURN + ELSE + print*, ' M = ', MMSCL + CALL ERROR_STOP(' GET_SCALE_GROUP', 'adj_arrays_mod.f') + ENDIF + + END FUNCTION GET_SCALE_GROUP + +!----------------------------------------------------------------------------------------- + + SUBROUTINE INIT_CSPEC_ADJ( ) +! +!****************************************************************************** +! Subroutine INIT_CSPEC_ADJ initializes arrays for the adjoint that depend +! uppon arrays from SMVGEAR. (dkh, 02/10/11) +! +! NOTES: +! (1 ) Now move error checking for the TES_O3_OBS simulation here +! (nb, dkh, 01/06/12, adj32_011) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE ERROR_MOD, ONLY : ERROR_STOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + + +# include "CMN_SIZE" +# include "comode.h" + + ! Local variables + INTEGER :: N + INTEGER :: AS + INTEGER :: JJ + INTEGER :: NK + LOGICAL :: FOUND + + !================================================================= + ! INIT_CSPEC_ADJ begins here! + !================================================================= + + + ! First allocate IDCSPEC_ADJ to be the number of obs from CSPEC + ALLOCATE( IDCSPEC_ADJ( NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'IDCSPEC_ADJ' ) + IDCSPEC_ADJ = 0 + + + ! allocate reverse mapping + ALLOCATE( ID2C( IGAS ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID2C' ) + ID2C = 0d0 + + ! Now we can allocate these sub-arrays of CSPEC as well + ALLOCATE( CSPEC_AFTER_CHEM( ITLOOP, NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CSPEC_AFTER_CHEM' ) + CSPEC_AFTER_CHEM = 0d0 + + + ALLOCATE( CSPEC_AFTER_CHEM_ADJ( ITLOOP, NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CSPEC_AFTER_CHEM_ADJ' ) + CSPEC_AFTER_CHEM_ADJ = 0d0 + + + DO N = 1, NOBS_CSPEC + + ! get species id number + IDCSPEC_ADJ(N) = GET_SPEC( CNAME(N) ) + + ! save reverse mapping + ID2C(IDCSPEC_ADJ(N)) = N + + ENDDO + + ! Now check that we can run TES_O3_OBS here (nb, dkh, 01/06/12, adj32_002) +#if defined ( TES_O3_OBS ) || defined( TES_O3_IRK ) + ! Since the O3 obs operators will pass adjoints back + ! to CSPEC via CSPEC_AFTER_CHEM_ADJ, we need to make sure that + ! these species are listed as observed species + FOUND = .FALSE. + DO N = 1, NOBS_CSPEC + + IF ( TRIM( NAMEGAS( IDCSPEC_ADJ(N) ) ) == 'O3' ) THEN + FOUND = .TRUE. + ENDIF + + ENDDO + IF ( .not. FOUND ) THEN + + CALL ERROR_STOP( ' Need to list O3 as observed species', + & ' adj_arrays_mod ' ) + ENDIF +#endif + + + ! Return to calling program + END SUBROUTINE INIT_CSPEC_ADJ + +!----------------------------------------------------------------------------------------- + + SUBROUTINE INIT_ADJ_STRAT + +!***************************************************************************** +! Subroutine INIT_ADJ_STRAT initializes stratohspheric adj prod & loss names +! and IDs (hml, dkh, 02/14/12, adj32_025) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" +# include "define_adj.h" + + ! Local variables + INTEGER :: AS + + !================================================================= + ! Allocate arrays + !================================================================= + + ALLOCATE( ID_PROD( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_PROD' ) + ID_PROD = 0 + + ALLOCATE( PROD_NAME( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_NAME' ) + PROD_NAME = '' + + ALLOCATE( OPT_THIS_PROD( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OPT_THIS_PROD' ) + OPT_THIS_PROD = .FALSE. + + ALLOCATE( REG_PARAM_PROD( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REG_PARAM_PROD' ) + REG_PARAM_PROD = 1d0 + + ALLOCATE( ID_LOSS( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_LOSS' ) + ID_LOSS = 0 + + ALLOCATE( LOSS_NAME( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_NAME' ) + LOSS_NAME = '' + + ALLOCATE( OPT_THIS_LOSS( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OPT_THIS_LOSS' ) + OPT_THIS_LOSS = .FALSE. + + ALLOCATE( REG_PARAM_LOSS( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REG_PARAM_LOSS' ) + REG_PARAM_LOSS = 1d0 + + ALLOCATE( PROD_ERROR( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_ERROR' ) + PROD_ERROR = 1d0 +#if defined ( LOG_OPT ) + PROD_ERROR = EXP(1d0) +#endif + + ALLOCATE( LOSS_ERROR( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_ERROR' ) + LOSS_ERROR = 1d0 +#if defined ( LOG_OPT ) + LOSS_ERROR = EXP(1d0) +#endif + + ALLOCATE( PROD_SF_DEFAULT( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RPOD_SF_DEFAULT' ) + PROD_SF_DEFAULT = 1d0 + + ALLOCATE( LOSS_SF_DEFAULT( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_SF_DEFAULT' ) + LOSS_SF_DEFAULT = 1d0 + + ! Return to calling program + END SUBROUTINE INIT_ADJ_STRAT + +!----------------------------------------------------------------------------- + + FUNCTION GET_SPEC( SPEC_NAME ) RESULT ( I ) +! +!****************************************************************************** +! Function GET_SPEC return the index of the CSPEC species array given +! a species name (dkh, 02/09/11) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) SPEC_NAME (Character) : Species name +! +! Result as Output: +! ============================================================================ +! (1 ) I (INTEGER) : Index of this specis in CSPEC array +! +! NOTES: +! (1 ) Needs to match SETTRACE in tracerid_mod +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NSPEC, NAMEGAS + + ! Function arguemtn + CHARACTER(LEN=14) :: SPEC_NAME + + ! Function return value + INTEGER :: I + + ! Local variables + INTEGER :: N + LOGICAL :: FOUND + + !================================================================= + ! GET_SPEC begins here! + !================================================================= + + FOUND = .FALSE. + + DO N = 1, NSPEC(NCSURBAN) + IF ( TRIM(NAMEGAS(N)) == TRIM( SPEC_NAME ) ) THEN + I = N + FOUND = .TRUE. + WRITE(*,*) 'SPEC_NAME',TRIM(NAMEGAS(N)) + ENDIF + ENDDO + + IF ( .not. FOUND ) THEN + CALL ERROR_STOP('name not found in GET_SPEC', + & 'adj_arrays_mod.f' ) + ENDIF + + ! Return to calling program + END FUNCTION GET_SPEC + +!------------------------------------------------------------------------------ + + FUNCTION DO_CHK_FILE() RESULT( DO_CHECKPOINT ) +! +!****************************************************************************** +! Function DO_CHK_FILE returns TRUE if it *.chk.* files are needed +! and false otherwise. (yd, 10/29/12) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST, LADJ + + ! Function value + LOGICAL :: DO_CHECKPOINT + + !================================================================= + ! DO_CHK_FILE begins here! + !================================================================= + + IF ( N_CALC > 0 .and. LADJ .and. + & ( .not. (LFDTEST .and. N_CALC > 1 ))) THEN + DO_CHECKPOINT = .TRUE. + ELSE + DO_CHECKPOINT = .FALSE. + ENDIF + + ! Return to calling program + + END FUNCTION DO_CHK_FILE + +!------------------------------------------------------------------------------ + FUNCTION READ_MASK( FILENAME ) RESULT ( MASK ) + +!****************************************************************************** +! Function READ_MASK reads the mask from disk for user defined +! FORCING_MASK_FILE in input.gcadj +! (dkh, 10/11/12) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to F90 modules + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=255) :: FILENAME + REAL*4 :: MASK(IGLOB,JGLOB) + + ! Local variables + REAL*4 :: ARRAY(IGLOB,JGLOB,1) + REAL*8 :: XTAU + + !================================================================= + ! READ_MASK begins here! + !================================================================= + + ! File name + + ! binary mask + !FILENAME = TRIM( REGION ) // '.bpch' + !! Get TAU0 for Jan 1985 + XTAU = GET_TAU0( 1, 1, 1985 ) + + ! Get TAU0 for Jan 1985 + !XTAU = GET_TAU0( 1, 1, 2006 ) + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_MASK: Reading ', a ) + + ! Mask is stored as 2 + !CALL READ_BPCH2( FILENAME, 'LANDMAP', 1, + CALL READ_BPCH2( FILENAME, 'LANDMAP', 2, + & XTAU, IGLOB, JGLOB, + & 1, ARRAY, QUIET=.TRUE. ) + + MASK = ARRAY(:,:,1) + + ! ensure range + IF ( MAXVAL(MASK) > 1d0 .or. MINVAL(MASK) < 0d0 ) THEN + CALL ERROR_STOP(' bad mask in READ_MASK', 'adj_arrays_mod.f') + ENDIF + + + ! Return to calling program + END FUNCTION READ_MASK + +!------------------------------------------------------------------------------ + FUNCTION READ_MASK_HTAP( ) RESULT ( MASK ) + +!****************************************************************************** +! Function READ_MASK_HTAP reads the receptor mask from disk. +! (yd, 10/12/13) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE REGRID_A2A_MOD, ONLY : DO_REGRID_DKH + USE HTAP_MOD, ONLY : LOCN20, LOCN21, LOCN22, LOCN23, LOCN24 + USE HTAP_MOD, ONLY : LOCN25, LOCN26, LOCN27, LOCN28 + USE HTAP_MOD, ONLY : LNAM31, LNAM32, LNAM33, LNAM34, LNAM35 + USE HTAP_MOD, ONLY : LNAM36, LEUR41, LEUR42, LEUR43, LEUR44 + USE HTAP_MOD, ONLY : LSAS51, LSAS52, LSAS53, LEAS61, LEAS62 + USE HTAP_MOD, ONLY : LEAS63, LEAS64, LEAS65, LEAS66, LSEA71 + USE HTAP_MOD, ONLY : LSEA72, LPAN81, LPAN82, LPAN83, LNAF91 + USE HTAP_MOD, ONLY : LNAF92, LNAF93, LMDE112 + USE HTAP_MOD, ONLY : LSAF101, LSAF102, LSAF103, LMDE111 + USE HTAP_MOD, ONLY : LMDE113, LMCA121, LMCA122, LMCA123 + USE HTAP_MOD, ONLY : LSAM131, LSAM132, LSAM133, LSAM134 + USE HTAP_MOD, ONLY : LRBU142, LRBU143, LCAS151, LNPO150 + USE HTAP_MOD, ONLY : LSPO161, LSPO160, LRBU141, LMCA124 + USE m_netcdf_io_open + USE m_netcdf_io_read + USE m_netcdf_io_readattr + USE m_netcdf_io_close + USE m_netcdf_io_get_dimlen + +# include "CMN_SIZE" ! Size parameters +# include "define.h" ! Grid Size + + ! Arguments + REAL*8 :: MASK(IGLOB,JGLOB) + + ! Local variables + INTEGER, PARAMETER :: I01x01 = 3600, J01x01 = 1800 + INTEGER :: I, J, II, JJ, fId1 + REAL*8 :: ARRAY(I01x01,J01x01) + REAL*8 :: TMP_ARRAY(I01x01,J01x01) + CHARACTER(LEN=255) :: LLFILENAME, FILENAME + + + !================================================================= + ! READ_MASK_HTAP begins here! + !================================================================= + + ! File name + ! File with lat/lon edges for regridding + LLFILENAME = TRIM( DATA_DIR_1x1) // + & 'MAP_A2A_Regrid_201203/MAP_HTAP.nc' + + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'HTAP/MASKS/HTAP_Phase2_tier2NC01x01.nc' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_MASK: Reading ', a ) + + ! Set Mask + MASK = 0d0 + ARRAY = 0d0 + + ! Open model_ready mask from netCDF file + CALL Ncop_Rd(fId1, TRIM( FILENAME )) + + ! Read model_ready data from netCDF file + CALL NcRd(TMP_ARRAY, fId1, 'region_code', + &(/ 1, 1 /), !Start + &(/ I01x01, J01x01/) ) !Count lon/lat + + ! Close netCDF file + CALL NcCl( fId1 ) + + ! Apply Source Mask Scaling + DO I = 1, I01x01 + + ! I on mask is -180->180 , but I on GEOS_01x01 is 0->360 + IF (I .LT. 1800 ) THEN + II = I + 1800 + ELSE IF (I .GE. 1801) THEN + II = I - 1800 + ENDIF + + ! J on mask is N->S, but I on GEOS_01x01 is S->N + JJ = J01x01 + + DO J = 1, J01x01 + + IF ( LOCN20 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 20d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN21 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 21d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN22 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 22d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN23 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 23d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN24 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 24d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN25 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 25d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN26 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 26d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN27 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 27d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN28 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 28d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM31 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 31d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM32 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 32d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM33 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 33d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM34 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 34d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM35 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 35d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM36 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 36d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEUR41 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 41d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEUR42 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 42d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEUR43 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 43d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEUR44 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 44d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAS51 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 51d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAS52 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 52d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAS53 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 53d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS61 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 61d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS62 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 62d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS63 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 63d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS64 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 64d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS65 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 65d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS66 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 66d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSEA71 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 71d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSEA72 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 72d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LPAN81 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 81d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LPAN82 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 82d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LPAN83 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 83d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAF91 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 91d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAF92 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 92d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAF93 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 93d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAF101 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 101d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAF102 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 102d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAF103 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 103d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMDE111 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 111d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMDE112 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 112d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMDE113 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 113d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMCA121 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 121d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMCA122 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 122d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMCA123 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 123d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMCA124 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 124d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAM131 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 131d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAM132 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 132d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAM133 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 133d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAM134 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 134d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LRBU141 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 141d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LRBU142 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 142d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LRBU143 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 143d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LCAS151 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 151d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNPO150 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 150d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSPO160 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 160d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSPO161 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 161d0 ) ARRAY(I,J) = 1d0 + ENDIF + + JJ = JJ - 1 + ENDDO + ENDDO + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, + & ARRAY, MASK, IS_MASS=1, + & netCDF=.TRUE.) + +#if defined ( GRID4x5) + MASK = MASK / 2000d0 +#elif defined ( GRID2x25) + MASK = MASK / 500d0 +#elif defined ( GRID1x125) + MASK = MASK / 125d0 +#elif defined ( GRID1x1) + MASK = MASK / 10d0 +#endif + + ! ensure range +! IF ( MAXVAL(MASK) > 1d0 .or. MINVAL(MASK) < 0d0 ) THEN +! CALL ERROR_STOP(' bad mask in READ_MASK_HTAP', +! & 'adj_arrays_mod.f') +! ENDIF + + + ! Return to calling program + END FUNCTION READ_MASK_HTAP + +!----------------------------------------------------------------------------------------- + + SUBROUTINE READ_MASK_NC ( MASK ) + +!****************************************************************************** +! Function READ_MASK_NC reads the mask from disk for user defined +! FORCING_MASK_FILE_NC in input.gcadj +! (fp 2013) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + USE m_netcdf_io_open + USE m_netcdf_io_read + USE m_netcdf_io_readattr + USE m_netcdf_io_close + USE m_netcdf_io_get_dimlen + +# include "CMN_SIZE" ! Size parameters +# include "netcdf.inc" + + ! Arguments + REAL*4 :: MASK_TEMP(IGLOB,JGLOB) + REAL*8, INTENT(OUT):: MASK(IGLOB,JGLOB) + CHARACTER*255 :: VARNAME + + ! Local variables + INTEGER :: FID, N + + !================================================================= + ! READ_MASK_NC begins here! + !================================================================= + + ! open file + CALL Ncop_Rd(FID, TRIM(FORCING_MASK_FILE_NC) ) + + MASK = 0d0 + + DO N = 1, NB_MASK_VAR + + VARNAME = FORCING_MASK_VARIABLE(N) + + ! Echo info + WRITE( 6, 100 ) TRIM( FORCING_MASK_FILE_NC ), TRIM( VARNAME ) + + CALL NcRd( MASK_TEMP, FID, TRIM( VARNAME ), + & (/ 1, 1 /), + & (/ IGLOB, JGLOB /) ) + + MASK = MASK + MASK_TEMP + + ENDDO + + !with multiple variables, I don't think we should require mask to be <=1 + !so just force it for now (fp) + + IF ( MAXVAL(MASK) .gt. 1d0 .and. NB_MASK_VAR .GT. 1 ) THEN + + WHERE( MASK .GT. 1D0) + MASK = 1D0 + END WHERE + + WRITE(*,*) 'Force cumulative mask to be <=1' + + ENDIF + + + 100 FORMAT( ' - READ_MASK: Reading ', a , 1x, a) + + ! ensure range + IF ( MAXVAL(MASK) > 1d0 .or. MINVAL(MASK) < 0d0 ) THEN + CALL ERROR_STOP(' bad mask in READ_MASK_NC', + & 'adj_arrays_mod.f') + ENDIF + + + ! Return to calling program + END SUBROUTINE READ_MASK_NC + +!----------------------------------------------------------------------------------------- + + SUBROUTINE CLEANUP_ADJ_ARRAYS + + !================================================================= + ! Subroutine CLEANUP_ADJ_ARRAYS deallocates arrays + !================================================================= + IF ( ALLOCATED( FORCING ) ) DEALLOCATE( FORCING ) + IF ( ALLOCATED( SHIPO3DEP_ADJ ) ) DEALLOCATE( SHIPO3DEP_ADJ ) + IF ( ALLOCATED( MOP_MOD_DIFF ) ) DEALLOCATE( MOP_MOD_DIFF ) + IF ( ALLOCATED( MODEL_BIAS ) ) DEALLOCATE( MODEL_BIAS ) + IF ( ALLOCATED( MODEL ) ) DEALLOCATE( MODEL ) + IF ( ALLOCATED( SAT_DOFS ) ) DEALLOCATE( SAT_DOFS ) + IF ( ALLOCATED( OBS ) ) DEALLOCATE( OBS ) + IF ( ALLOCATED( COST_ARRAY ) ) DEALLOCATE( COST_ARRAY ) + IF ( ALLOCATED( OBS_COUNT ) ) DEALLOCATE( OBS_COUNT ) + IF ( ALLOCATED( OBS_STT ) ) DEALLOCATE( OBS_STT ) + IF ( ALLOCATED( STT_ADJ ) ) DEALLOCATE( STT_ADJ ) + IF ( ALLOCATED( STT_ORIG ) ) DEALLOCATE( STT_ORIG ) + IF ( ALLOCATED( EMS_orig ) ) DEALLOCATE( EMS_orig ) + IF ( ALLOCATED( CF_REGION ) ) DEALLOCATE( CF_REGION ) + IF ( ALLOCATED( COST_FUNC_SAV ) ) DEALLOCATE( COST_FUNC_SAV ) + IF ( ALLOCATED( ICS_SF ) ) DEALLOCATE( ICS_SF ) + IF ( ALLOCATED( ICS_SF0 ) ) DEALLOCATE( ICS_SF0 ) + IF ( ALLOCATED( EMS_SF ) ) DEALLOCATE( EMS_SF ) + IF ( ALLOCATED( EMS_SF0 ) ) DEALLOCATE( EMS_SF0 ) + IF ( ALLOCATED( REG_PARAM_EMS ) ) DEALLOCATE( REG_PARAM_EMS ) + IF ( ALLOCATED( REG_PARAM_ICS ) ) DEALLOCATE( REG_PARAM_ICS ) + IF ( ALLOCATED( ID_ADEMS ) ) DEALLOCATE( ID_ADEMS ) + IF ( ALLOCATED( OPT_THIS_TRACER ) ) DEALLOCATE( OPT_THIS_TRACER ) + IF ( ALLOCATED( OBS_THIS_SPECIES) ) DEALLOCATE( OBS_THIS_SPECIES ) + IF ( ALLOCATED( OBS_THIS_TRACER ) ) DEALLOCATE( OBS_THIS_TRACER ) + IF ( ALLOCATED( OPT_THIS_EMS ) ) DEALLOCATE( OPT_THIS_EMS ) + IF ( ALLOCATED( REMIS_ADJ ) ) DEALLOCATE( REMIS_ADJ ) + IF ( ALLOCATED( DEPSAV_ADJ ) ) DEALLOCATE( DEPSAV_ADJ ) + IF ( ALLOCATED( EMS_SF_DEFAULT ) ) DEALLOCATE( EMS_SF_DEFAULT ) + IF ( ALLOCATED( ICS_SF_DEFAULT ) ) DEALLOCATE( ICS_SF_DEFAULT ) + IF ( ALLOCATED( IDCSPEC_ADJ ) ) DEALLOCATE( IDCSPEC_ADJ ) + IF ( ALLOCATED( ID2C ) ) DEALLOCATE( ID2C ) + IF ( ALLOCATED( EMS_ERROR ) ) DEALLOCATE( EMS_ERROR ) + IF ( ALLOCATED( COV_ERROR_LX ) ) DEALLOCATE( COV_ERROR_LX ) + IF ( ALLOCATED( COV_ERROR_LY ) ) DEALLOCATE( COV_ERROR_LY ) + IF ( ALLOCATED( ICS_ERROR ) ) DEALLOCATE( ICS_ERROR ) + IF ( ALLOCATED( CNAME ) ) DEALLOCATE( CNAME ) + IF ( ALLOCATED( EMS_SF_ADJ ) ) DEALLOCATE( EMS_SF_ADJ ) + IF ( ALLOCATED( TEMP2 ) ) DEALLOCATE( TEMP2 ) + IF ( ALLOCATED( EMS_ADJ ) ) DEALLOCATE( EMS_ADJ ) + IF ( ALLOCATED( PROD_SF ) ) DEALLOCATE( PROD_SF ) + IF ( ALLOCATED( PROD_SF_ADJ ) ) DEALLOCATE( PROD_SF_ADJ ) + IF ( ALLOCATED( PROD_SF_DEFAULT ) ) DEALLOCATE( PROD_SF_DEFAULT ) + IF ( ALLOCATED( LOSS_SF ) ) DEALLOCATE( LOSS_SF ) + IF ( ALLOCATED( LOSS_SF_ADJ ) ) DEALLOCATE( LOSS_SF_ADJ ) + IF ( ALLOCATED( LOSS_SF_DEFAULT ) ) DEALLOCATE( LOSS_SF_DEFAULT ) + IF ( ALLOCATED( OPT_THIS_PROD ) ) DEALLOCATE( OPT_THIS_PROD ) + IF ( ALLOCATED( OPT_THIS_LOSS ) ) DEALLOCATE( OPT_THIS_LOSS ) + IF ( ALLOCATED( PROD_SF0 ) ) DEALLOCATE( PROD_SF0 ) + IF ( ALLOCATED( LOSS_SF0 ) ) DEALLOCATE( LOSS_SF0 ) + IF ( ALLOCATED( P_ADJ ) ) DEALLOCATE( P_ADJ ) + IF ( ALLOCATED( k_ADJ ) ) DEALLOCATE( k_ADJ ) + IF ( ALLOCATED( VAR_FD ) ) DEALLOCATE( VAR_FD ) + IF ( ALLOCATED( RCONST_FD ) ) DEALLOCATE( RCONST_FD ) + IF ( ALLOCATED( RATE_SF_ADJ ) ) DEALLOCATE( RATE_SF_ADJ ) + IF ( ALLOCATED( OPT_THIS_RATE ) ) DEALLOCATE( OPT_THIS_RATE ) + IF ( ALLOCATED( RATE_SF_DEFAULT ) ) DEALLOCATE( RATE_SF_DEFAULT ) + IF ( ALLOCATED( REG_PARAM_RATE ) ) DEALLOCATE( REG_PARAM_RATE ) + IF ( ALLOCATED( RATE_ERROR ) ) DEALLOCATE( RATE_ERROR ) + IF ( ALLOCATED( RATE_SF ) ) DEALLOCATE( RATE_SF ) + IF ( ALLOCATED( RATE_SF0 ) ) DEALLOCATE( RATE_SF0 ) + IF ( ALLOCATED( NHX_ADJ_FORCE ) ) DEALLOCATE( NHX_ADJ_FORCE ) + IF ( ALLOCATED( TR_DDEP_CONV )) DEALLOCATE( TR_DDEP_CONV ) + IF ( ALLOCATED( CS_DDEP_CONV )) DEALLOCATE( CS_DDEP_CONV ) + IF ( ALLOCATED( TR_WDEP_CONV )) DEALLOCATE( TR_WDEP_CONV ) + + ! Return to calling program + END SUBROUTINE CLEANUP_ADJ_ARRAYS + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE ADJ_ARRAYS_MOD diff --git a/code/adjoint/adj_arrays_mod.f~ b/code/adjoint/adj_arrays_mod.f~ new file mode 100644 index 0000000..83367ce --- /dev/null +++ b/code/adjoint/adj_arrays_mod.f~ @@ -0,0 +1,4180 @@ +! $Id: adj_arrays_mod.f,v 1.26 2012/08/10 22:08:22 nicolas Exp $ + MODULE ADJ_ARRAYS_MOD +! +!****************************************************************************** +! Module ADJ_ARRAYS_MOD contains arrays for the GEOS-CHEM adjoint model, +! as well as routines to initialize, set, get, and destroy the arrays. +! These arrays are initialized at the beginning of the inverse driver. +! (mak, bmy, 3/14/06, 3/29/06, mak, 6/14/09) +! +! Module Variables: +! ============================================================================ +! (1 ) EMS_orig (REAL*8) : can store original emissions +! (2 ) FORCING (REAL*8) : holds (ym-yo)^2/err for all days +! (3 ) MOP_MOD_DIFF (REAL*8) : holds (ym-yo) for all days +! (4 ) MODEL_BIAS (REAL*8) : holds (ym-yo)/ym for all days +! (5 ) MODEL (REAL*8) : holds H(ym) +! (6 ) OBS (REAL*8) : holds h(yo) +! (7 ) COST_ARRAY (REAL*8) : holds J(I,J), assumes column obs +! (8 ) OBS_COUNT (REAL*8) : holds #obs/box +! (9 ) OBS_STT (REAL*4) : Array with psedudo observations +! (10) STT_ADJ (REAL*8) : Adjoint tracer array (STT equivalent in fwd) +! (11) CF_REGION (REAL*8) : Array with regional weight for pseudo obs and sensitivity +! (12) NOPT (INTEGER) : Size of control vector +! (13) N_CALC (INTEGER) : optimization iteration counter +! (14) N_CALC_STOP (INTEGER) : end iteration for current optimization +! (14bis) N_CALC_TOTAL (INTEGER) : total number of iterations in optimization +! (15) MMSCL (INTEGER) : number of temporal groups in control vector +! (17) FD_DIFF (INTEGER) : scaling for initial conditions +! (18) IFD (INTEGER) : lon gridbox for FD and debugging +! (19) LONFD (REAL*8) : lon for FD and debugging +! (20) JFD (INTEGER) : lat gridbox for FD and debugging +! (21) LATFD (REAL*8) : lat for FD and debugging +! (22) LFD (INTEGER) : vert level for FD and debugging +! (23) MFD (INTEGER) : temporal group for FD and debugging +! (24) NFD (INTEGER) : species for FD and debugging +! (25) EMSFD (INTEGER) : emission group for FD and debugging +! (26) COST FUNC (REAL*8) : scalar cost function +! (27) NOBS (INTEGER) : Number of obs datasets used +! (28) ICS_SF (REAL*8) : array of initial conditions +! (29) ICS_SF0 (REAL*8) : array of first guess for initial conditions +! (30) ICS_SF_DEFAULT (R*8) : scalar first guess for initial conditions +! (31) EMS_SF (REAL*8) : array of emission scaling +! (32) EMS_SF0 (REAL*8) : array of first guess for emission scaling +! (33) ICS_SF_DEFAULT (R*8) : Initial condition scaling factors at iteration 1 +! (34) ICS_SF_ADJ (REAL*8) : dJ/dICS_SF +! (35) EMS_SF_ADJ (REAL*8) : dJ/dEMS_SF +! (36) SAT (INTEGER) : number of sat data used +! (37) OBS_FREQ (INTEGER) : observation frequency, usually 60 (minutes) +! (38) DAYS (INTEGER) : number of days in simulation +! (39) DAY_OF_SIM (INTEGER) : day of the simulation, updated throughout +! (40) REG_PARAM_EMS(REAL*8) : regularization parameter for a priori/background term +! (41) REG_PARAM_ICS(REAL*8) : regularization parameter for a priori/background term +! (42) ICSFD (INTEGER) : initial condition species for FD tests +! (43) STT_ORIG (REAL*8) : Original unscaled values of STT +! (44) REMIS_ADJ (REAL*8) : Adjoint of REMIS +! (45) DEPSAV_ADJ (REAL*8) : Adjoint of DEPSAV +! (46) O3_PROF_SAV (REAL*8) : TOMS O3 profile from set_prof +! (47) EMS_ERROR (REAL*8) : standard error for for a priori/background term +! (48) OBS_THIS_SPECIES (L) : observe this species in cost function +! (49) OBS_THIS_TRACER (L) : observe this tracer in cost function +! (50) NSPAN (INTEGER) : total number of observations to include in CF +! (50) NOBS_CSPEC (INTEGER) : total number of species observed in CSPEC +! (51) IDCSPEC_ADJ (INTEGER) : index of species observed in CSPEC +! (52) ID2C (INTEGER) : reverse mapping of IDCSPEC_ADJ +! (53) OPT_THIS_TRACER (L) : Which tracer initial values to optimize, replace +! OPT_THIS_SPECIES +! (54) CNAME (CHARACTER) : names of species in cspec to observe +! (55) INV_NSPAN (REAL*8) : The inverse of NSPAN +! (56) EMS_ADJ (REAL*8) : dJ/dEMS +! (57) ICS_ERROR (REAL*8) : standard error for for a priori/background term +! (58) HMAX (INTEGER) : Total length of 1D gradient vector +! (59) VAR_FD (REAL*8) : Concentrations for chem adjoint debugging +! (60) RCONST_FD (REAL*8) : Reaction rates for chem adjoint debugging +! (61) TR_DDEP_CONV : Unit conversion array for ddep adjoint +! (62) CS_DDEP_CONV : Unit conversion array for ddep adjoint +! (63) TR_WDEP_CONV : Unit conversion array for Wdep adjoint +! (64) NOBS2NDEP : Mapping array from NOBS to drydep ID +! (65) NOBSCSPEC2NDEP : Mapping array from NOBS_CSPEC to drydep ID +! (66) NOBS2NWDEP : Mapping array from NOBS to wetdep ID +! (67) NTR2NOBS : Mapping array from NOBS to tracer (opposite TRACER_IND) +! (68) COV_ERROR_LY (REAL*8) : +! (69) COV_ERROR_LY (REAL*8) : +! (70) TEMP2 (REAL*8) : +! +! Module Routines: +! ============================================================================ +! ( 1) INIT_ADJ_EMS : Initializes adj ems arrays +! ( 2) INIT_TRACERID_ADJ : Zeroes all ems variables +! ( 3) TRACERID_ADJ : Defines adj tracers and emission ID numbers +! ( 4) INIT_ADJ_ARRAYS : Allocates & zeroes all module arrays +! ( 5) INIT_CF_REGION : Sets the domain for sensitivity/twin exp. runs +! ( 6) GET_CF_REGION : Gets regional cost function weight +! ( 7) ITS_TIME_FOR_OBS : Returns true if it's time for obs +! ( 8) CALC_NUM_SAT : Calculates # sat datasets (CO only now) +! ( 9) SET_EMS_ORIG : Writes a value into EMS_ORIG +! (10) GET_EMS_ORIG : Gets a value from EMS_ORIG +! (11) SET_FORCING : Writes a value into FORCING +! (12) GET_FORCING : Gets a value from FORCING +! (13) SET_MOP_MOD_DIFF : Writes a value into MOP_MOD_DIFF +! (14) GET_MOP_MOD_DIFFG : Gets a value from MOP_MOD_DIFF +! (15) SET_MODEL_BIAS : Writes a value into MODEL_BIAS +! (16) GET_MODEL_BIAS : Gets a value from MODEL_BIAS +! (17) SET_MODEL : Writes a value into MODEL +! (18) GET_MODEL : Gets a value from MODEL +! (19) SET_OBS : Writes a value into OBS +! (20) GET_OBS : Gets a value from OBS +! (21) CHECK_STT_ADJ : Checks STT_ADJ for NaNs and infinity +! (22) EXPAND_NAME : Replace NN token with current iteration +! (23) CLEANUP_ADJ_ARRAYS : Deallcoates all module arrays +! +! GEOS-Chem modules referenced by "adj_arrays_mod.f" +! ============================================================================ +! (1 ) "error_mod.f" : Module w/ NaN and error checks +! +! NOTES: +! (1 ) Clean up, make everthing public (mak, 6/14/09) +! (2 ) Move DIRECTION to time_mod.f (dkh, 04/28/10) +! (3 ) Now include CO2 emission ID #'s (dkh, 05/06/10) +! (4 ) Add EMS_SF_DEFAULT and ICS_SF_DEFAULT, EMS_ERROR, OBS_THIS_TRACER +! NSPAN, NOBS_CSPEC, IDCSPEC_ADJ, CNAME,INV_NSPAN, ICS_ERROR (dkh, 02/09/11) +! (5 ) Add EMS_ADJ (dkh, 02/17/11) +! (6 ) Add dust EMS_ADJ (xxu, dkh, 01/09/12, adj32_011) +! (7 ) add more VOCs (knl, dkh, 01/13/12, adj32_014) +! (8 ) Add support for strat chem adjoint (hml, dkh, 02/14/12, adj32_025) +! (9 ) Move VAR_FD and RCONST_FD here for dynamic allocation +! (dkh, 02/23/12, adj32_026) +! (10 ) Add N_CALC_TOTAL, which is the total number of iterations for the optimization +! Useful for L-BFGS inverse Hessian calculation (nab, 03/27/12 ) +!****************************************************************************** +! + IMPLICIT NONE + + + !================================================================= + ! MODULE PRIVATE DECLARATIONS + !================================================================= + + ! Make everything PUBLIC ... + PUBLIC + + !================================================================= + ! MODULE VARIABLES + !================================================================= + REAL*8, ALLOCATABLE :: EMS_orig(:,:,:) + REAL*8, ALLOCATABLE :: FORCING(:,:,:) + REAL*8, ALLOCATABLE :: MOP_MOD_DIFF(:,:,:) + REAL*8, ALLOCATABLE :: MODEL_BIAS(:,:,:,:) + REAL*8, ALLOCATABLE :: MODEL(:,:,:,:) + REAL*4, ALLOCATABLE :: SAT_DOFS(:,:,:,:) + REAL*8, ALLOCATABLE :: OBS(:,:,:,:) + REAL*8, ALLOCATABLE :: COST_ARRAY(:,:,:) + REAL*8, ALLOCATABLE :: OBS_COUNT(:,:) + REAL*4, ALLOCATABLE :: OBS_STT(:,:,:,:) + REAL*8, ALLOCATABLE :: STT_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: CF_REGION(:,:,:) + REAL*8, ALLOCATABLE :: ADJ_FORCE(:,:,:,:) + REAL*8, ALLOCATABLE :: SHIPO3DEP_ADJ(:,:) + + INTEGER :: NOPT + INTEGER :: N_CALC + INTEGER :: N_CALC_STOP + INTEGER :: N_CALC_TOTAL + + + ! FROM INPUT.GCADJ + INTEGER :: MMSCL + INTEGER :: NNEMS + REAL*8 :: FD_DIFF + INTEGER :: IFD + REAL*8 :: LONFD + INTEGER :: JFD + REAL*8 :: LATFD + INTEGER :: LFD + INTEGER :: MFD + INTEGER :: NFD + INTEGER :: EMSFD + INTEGER :: ICSFD + REAL*8 :: COST_FUNC + REAL*8, ALLOCATABLE :: COST_FUNC_SAV(:) + REAL*8, ALLOCATABLE :: STT_ADJ_FD(:) + INTEGER :: NOBS + INTEGER :: NSPAN + REAL*8 :: INV_NSPAN + INTEGER :: NOBS_CSPEC + + REAL*8, ALLOCATABLE :: ICS_SF(:,:,:,:) + REAL*8, ALLOCATABLE :: STT_ORIG(:,:,:,:) + REAL*8, ALLOCATABLE :: ICS_SF0(:,:,:,:) + !REAL*8 :: ICS_SF_tmp + REAL*8, ALLOCATABLE :: EMS_SF(:,:,:,:) + REAL*8, ALLOCATABLE :: EMS_SF0(:,:,:,:) + !REAL*8 :: EMS_SF_tmp + REAL*8, ALLOCATABLE :: ICS_SF_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: EMS_SF_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: TEMP2(:,:,:,:) + REAL*8, ALLOCATABLE :: EMS_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: REG_PARAM_EMS(:) + REAL*8, ALLOCATABLE :: REG_PARAM_ICS(:) + + INTEGER :: SAT + INTEGER :: OBS_FREQ + INTEGER, ALLOCATABLE:: ID_ADEMS(:) + LOGICAL, ALLOCATABLE:: OPT_THIS_TRACER(:) + LOGICAL, ALLOCATABLE:: OBS_THIS_SPECIES(:) + LOGICAL, ALLOCATABLE:: OBS_THIS_TRACER(:) + LOGICAL, ALLOCATABLE:: OPT_THIS_EMS(:) + CHARACTER(LEN=14), ALLOCATABLE :: ADEMS_NAME(:) + CHARACTER(LEN=14), ALLOCATABLE :: CNAME(:) + + REAL*8, ALLOCATABLE :: REMIS_ADJ(:,:) + REAL*8, ALLOCATABLE :: DEPSAV_ADJ(:,:,:) + + REAL*8, ALLOCATABLE :: O3_PROF_SAV(:,:,:) + + REAL*8, ALLOCATABLE :: ICS_SF_DEFAULT(:) + REAL*8, ALLOCATABLE :: EMS_SF_DEFAULT(:) + REAL*8, ALLOCATABLE :: IDCSPEC_ADJ(:) + REAL*8, ALLOCATABLE :: ID2C(:) + + ! added for apriori constraints (dkh, 01/11/11) + REAL*8, ALLOCATABLE :: EMS_ERROR(:) + REAL*8, ALLOCATABLE :: ICS_ERROR(:) + REAL*8, ALLOCATABLE :: COV_ERROR_LX(:), COV_ERROR_LY(:) + + INTEGER :: DAYS + INTEGER :: DAY_OF_SIM + + ! Strat prod and loss (hml, dkh, 02/14/12, adj32_025) + INTEGER :: NSTPL + INTEGER :: STRFD + REAL*8, ALLOCATABLE :: PROD_SF(:,:,:,:) + REAL*8, ALLOCATABLE :: PROD_SF0(:,:,:,:) + REAL*8, ALLOCATABLE :: PROD_SF_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: P_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: LOSS_SF(:,:,:,:) + REAL*8, ALLOCATABLE :: LOSS_SF0(:,:,:,:) + REAL*8, ALLOCATABLE :: LOSS_SF_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: k_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: REG_PARAM_PROD(:) + REAL*8, ALLOCATABLE :: REG_PARAM_LOSS(:) + + REAL*8, ALLOCATABLE :: VAR_FD(:,:) + REAL*8, ALLOCATABLE :: RCONST_FD(:,:) + + INTEGER, ALLOCATABLE:: ID_PROD(:) + INTEGER, ALLOCATABLE:: ID_LOSS(:) + LOGICAL, ALLOCATABLE:: OPT_THIS_PROD(:) + LOGICAL, ALLOCATABLE:: OPT_THIS_LOSS(:) + CHARACTER(LEN=14), ALLOCATABLE :: PROD_NAME(:) + CHARACTER(LEN=14), ALLOCATABLE :: LOSS_NAME(:) + REAL*8, ALLOCATABLE :: PROD_SF_DEFAULT(:) + REAL*8, ALLOCATABLE :: LOSS_SF_DEFAULT(:) + REAL*8, ALLOCATABLE :: PROD_ERROR(:) + REAL*8, ALLOCATABLE :: LOSS_ERROR(:) + + ! for wetdep adj (fp, dkh, 03/04/13) + REAL*8 :: ADJOINT_AREA_M2 + INTEGER, ALLOCATABLE:: TRACER_IND(:) + REAL*8, ALLOCATABLE :: NHX_ADJ_FORCE(:,:) + + REAL*8, ALLOCATABLE :: TR_DDEP_CONV(:,:) + REAL*8, ALLOCATABLE :: CS_DDEP_CONV(:,:) + REAL*8, ALLOCATABLE :: TR_WDEP_CONV(:,:) + INTEGER,ALLOCATABLE :: NOBS2NDEP(:) + INTEGER,ALLOCATABLE :: NOBSCSPEC2NDEP(:) + INTEGER,ALLOCATABLE :: NOBS2NWDEP(:) + INTEGER,ALLOCATABLE :: NTR2NOBS(:) + REAL*8, ALLOCATABLE :: DDEP_TRACER(:,:,:) + REAL*8, ALLOCATABLE :: DDEP_CSPEC(:,:,:) + REAL*8, ALLOCATABLE :: WDEP_CV(:,:,:) + REAL*8, ALLOCATABLE :: WDEP_LS(:,:,:) + REAL*8, ALLOCATABLE :: AD44_OLD(:,:,:) + REAL*8, ALLOCATABLE :: AD44_CSPEC_OLD(:,:,:) + REAL*8, ALLOCATABLE :: AD38_OLD(:,:,:) + REAL*8, ALLOCATABLE :: AD39_OLD(:,:,:) + + CHARACTER(LEN=255) :: DEP_UNIT + + CHARACTER(LEN=255) :: FORCING_MASK_FILE + CHARACTER(LEN=255) :: FORCING_MASK_FILE_NC + CHARACTER(LEN=255), ALLOCATABLE :: FORCING_MASK_VARIABLE(:) + INTEGER :: NB_MASK_VAR + + + ! Adj Emission IDs + ! CO + INTEGER :: ADCOEMS, ADCOVOX + + ! CH4 (kjw, dkh, 02/12/12, adj32_023) + INTEGER :: ADCH4EMS + + ! tagged Ox (lzh, 12/12/2009) + INTEGER :: IDADJ_POx + + ! FULL CHEM + INTEGER :: IDADJ_ENH3_bb + INTEGER :: IDADJ_ENH3_bf + INTEGER :: IDADJ_ENH3_an + INTEGER :: IDADJ_ENH3_na + INTEGER :: IDADJ_EBCPI_an + INTEGER :: IDADJ_EBCPO_an + INTEGER :: IDADJ_EOCPI_an + INTEGER :: IDADJ_EOCPO_an + INTEGER :: IDADJ_EBCPI_bb + INTEGER :: IDADJ_EBCPO_bb + INTEGER :: IDADJ_EOCPI_bb + INTEGER :: IDADJ_EOCPO_bb + INTEGER :: IDADJ_EBCPI_bf + INTEGER :: IDADJ_EBCPO_bf + INTEGER :: IDADJ_EOCPI_bf + INTEGER :: IDADJ_EOCPO_bf + INTEGER :: IDADJ_ESO2_an1 + INTEGER :: IDADJ_ESO2_an2 + INTEGER :: IDADJ_ESO2_bb + INTEGER :: IDADJ_ESO2_bf + INTEGER :: IDADJ_ESO2_sh + + ! gas-phase emissions + INTEGER :: IDADJ_ENOX_so + INTEGER :: IDADJ_ENOX_li + INTEGER :: IDADJ_ENOX_ac + INTEGER :: IDADJ_ENOX_an + INTEGER :: IDADJ_ENOX_bf + INTEGER :: IDADJ_ENOX_bb + INTEGER :: IDADJ_ECO_an + INTEGER :: IDADJ_ECO_bf + INTEGER :: IDADJ_ECO_bb + INTEGER :: IDADJ_EISOP_an + INTEGER :: IDADJ_EISOP_bb + INTEGER :: IDADJ_EISOP_bf + + ! add more VOCs (knl, dkh, 11/03/11, adj32_014) + INTEGER :: IDADJ_EALK4_an + INTEGER :: IDADJ_EALK4_bb + INTEGER :: IDADJ_EALK4_bf + + INTEGER :: IDADJ_EACET_an + INTEGER :: IDADJ_EACET_bb + INTEGER :: IDADJ_EACET_bf + + INTEGER :: IDADJ_EMEK_an + INTEGER :: IDADJ_EMEK_bb + INTEGER :: IDADJ_EMEK_bf + + INTEGER :: IDADJ_EALD2_an + INTEGER :: IDADJ_EALD2_bb + INTEGER :: IDADJ_EALD2_bf + + INTEGER :: IDADJ_EPRPE_an + INTEGER :: IDADJ_EPRPE_bb + INTEGER :: IDADJ_EPRPE_bf + + INTEGER :: IDADJ_EC3H8_an + INTEGER :: IDADJ_EC3H8_bb + INTEGER :: IDADJ_EC3H8_bf + + INTEGER :: IDADJ_ECH2O_an + INTEGER :: IDADJ_ECH2O_bb + INTEGER :: IDADJ_ECH2O_bf + + INTEGER :: IDADJ_EC2H6_an + INTEGER :: IDADJ_EC2H6_bb + INTEGER :: IDADJ_EC2H6_bf + + ! CO2 emissions + INTEGER :: IDADJ_ECO2ff + INTEGER :: IDADJ_ECO2ocn + INTEGER :: IDADJ_ECO2bal + INTEGER :: IDADJ_ECO2bb + INTEGER :: IDADJ_ECO2bf + INTEGER :: IDADJ_ECO2nte + INTEGER :: IDADJ_ECO2shp + INTEGER :: IDADJ_ECO2pln + INTEGER :: IDADJ_ECO2che + INTEGER :: IDADJ_ECO2sur + + + INTEGER, ALLOCATABLE :: NADJ_EANTHRO(:) + INTEGER, ALLOCATABLE :: NADJ_EBIOMASS(:) + INTEGER, ALLOCATABLE :: NADJ_EBIOFUEL(:) + + ! (dkh, 11/11/09) + INTEGER :: N_CARB_EMS_ADJ + INTEGER :: N_SULF_EMS_ADJ + LOGICAL :: IS_CARB_EMS_ADJ + LOGICAL :: IS_SULF_EMS_ADJ + + ! Dust emissions (xxu, dkh, 01/09/12, adj32_011) + INTEGER :: IDADJ_EDST1 + INTEGER :: IDADJ_EDST2 + INTEGER :: IDADJ_EDST3 + INTEGER :: IDADJ_EDST4 + INTEGER :: N_DUST_EMS_ADJ + LOGICAL :: IS_DUST_EMS_ADJ + + ! Strat prod and loss tacer (hml, dkh, 02/14/12, ad32_025) + INTEGER :: NOx_p + INTEGER :: Ox_p + INTEGER :: PAN_p + INTEGER :: CO_p + INTEGER :: ALK4_p + INTEGER :: ISOP_p + INTEGER :: HNO3_p + INTEGER :: H2O2_p + INTEGER :: ACET_p + INTEGER :: MEK_p + INTEGER :: ALD2_p + INTEGER :: RCHO_p + INTEGER :: MVK_p + INTEGER :: MACR_p + INTEGER :: PMN_p + INTEGER :: PPN_p + INTEGER :: R4N2_p + INTEGER :: PRPE_p + INTEGER :: C3H8_p + INTEGER :: CH2O_p + INTEGER :: C2H6_p + INTEGER :: N2O5_p + INTEGER :: HNO4_p + INTEGER :: MP_p + + INTEGER :: NOx_l + INTEGER :: Ox_l + INTEGER :: PAN_l + INTEGER :: CO_l + INTEGER :: ALK4_l + INTEGER :: ISOP_l + INTEGER :: HNO3_l + INTEGER :: H2O2_l + INTEGER :: ACET_l + INTEGER :: MEK_l + INTEGER :: ALD2_l + INTEGER :: RCHO_l + INTEGER :: MVK_l + INTEGER :: MACR_l + INTEGER :: PMN_l + INTEGER :: PPN_l + INTEGER :: R4N2_l + INTEGER :: PRPE_l + INTEGER :: C3H8_l + INTEGER :: CH2O_l + INTEGER :: C2H6_l + INTEGER :: N2O5_l + INTEGER :: HNO4_l + INTEGER :: MP_l + + INTEGER :: N_STR_PROD_ADJ + INTEGER :: N_STR_LOSS_ADJ + + ! Added for reaction rate sensitivities (tww, 05/08/12) + INTEGER :: NRRATES + INTEGER :: RATFD + REAL*8, ALLOCATABLE :: RATE_SF(:,:,:,:) + REAL*8, ALLOCATABLE :: RATE_SF0(:,:,:,:) + REAL*8, ALLOCATABLE :: RATE_SF_ADJ(:,:,:,:) + REAL*8, ALLOCATABLE :: REG_PARAM_RATE(:) + REAL*8, ALLOCATABLE :: RATE_ERROR(:) + REAL*8, ALLOCATABLE :: RATE_SF_DEFAULT(:) + INTEGER, ALLOCATABLE :: ID_RRATES(:) + !CHARACTER(LEN=14), ALLOCATABLE :: RRATES_NAME(:) + CHARACTER(LEN=25), ALLOCATABLE :: RRATES_NAME(:)!(hml, 04/03/13) + LOGICAL, ALLOCATABLE :: OPT_THIS_RATE(:) + + + ! NOR obsolete (zhej, dkh, 01/16/12, adj32_015) + !! Nested Observation Region (zhe 1/19/11) + !INTEGER :: NOR(4) + + ! Problem when HMAX defined here so now in inv_hessian_lbfgs_mod.f + ! (nab, 24/03/12 ) + ! INTEGER :: HMAX + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_ADJ_EMS +!****************************************************************************** +! Subroutine INIT_ADJ_EMS initializes adj emission names and IDs +! (adj_group, 6/08/09) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" +# include "define_adj.h" + + ! Local variables + INTEGER :: AS + + !================================================================= + ! Allocate arrays + !================================================================= + ALLOCATE( ID_ADEMS( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_ADEMS' ) + ID_ADEMS = 0 + + ALLOCATE( ADEMS_NAME( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADEMS_NAME' ) + ADEMS_NAME = '' + + ALLOCATE( OPT_THIS_EMS( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OPT_THIS_EMS' ) + OPT_THIS_EMS = .FALSE. + + ALLOCATE( REG_PARAM_EMS( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REG_PARAM_EMS' ) + REG_PARAM_EMS= 1d0 + + ALLOCATE( EMS_ERROR( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_ERROR' ) + EMS_ERROR = 1d0 +#if defined ( LOG_OPT ) + EMS_ERROR = EXP(1d0) +#endif + + ALLOCATE( COV_ERROR_LX( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COV_ERROR_LX' ) + COV_ERROR_LX = 1d0 +#if defined ( LOG_OPT ) + COV_ERROR_LX = EXP(1d0) +#endif + + + ALLOCATE( COV_ERROR_LY( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COV_ERROR_LY' ) + COV_ERROR_LY = 1d0 +#if defined ( LOG_OPT ) + COV_ERROR_LY = EXP(1d0) +#endif + + ALLOCATE( EMS_SF_DEFAULT( NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF_DEFAULT' ) + EMS_SF_DEFAULT = 1d0 + + ! Return to calling program + END SUBROUTINE INIT_ADJ_EMS + +!----------------------------------------------------------------------------- + + + SUBROUTINE INIT_ADJ_RRATES +!****************************************************************************** +! Subroutine INIT_ADJ_RRATES initializes adj reaction rates names and IDs +! (tww, 05/08/12) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" +# include "define_adj.h" + + ! Local variables + INTEGER :: AS + + !================================================================= + ! Allocate arrays + !================================================================= + ALLOCATE( ID_RRATES( NRRATES ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_RRATES' ) + ID_RRATES = 0 + + ALLOCATE( RRATES_NAME( NRRATES ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RRATES_NAME' ) + RRATES_NAME = '' + + ALLOCATE( OPT_THIS_RATE( NRRATES ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OPT_THIS_RATE' ) + OPT_THIS_RATE=.FALSE. + + ALLOCATE( RATE_SF_DEFAULT( NRRATES ), STAT=AS ) + IF ( AS /=0 ) CALL ALLOC_ERR( 'RATE_SF_DEFAULT' ) + RATE_SF_DEFAULT = 1d0 + + ALLOCATE( REG_PARAM_RATE( NRRATES ), STAT=AS ) + IF ( AS /=0 ) CALL ALLOC_ERR( 'REG_PARAM_RATE' ) + REG_PARAM_RATE = 1d0 + + ALLOCATE( RATE_ERROR( NRRATES ), STAT=AS ) + IF ( AS /=0 ) CALL ALLOC_ERR( 'RATE_ERROR' ) + RATE_ERROR = 1d0 +#if defined ( LOG_OPT ) + RATE_ERROR = EXP(1d0) +#endif + + ! Return to calling program + END SUBROUTINE INIT_ADJ_RRATES + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_TRACERID_ADJ +! +!****************************************************************************** +! Subroutine INIT_TRACERID zeroes module variables. (mak, 6/14/09) +! +! NOTES: +! (1 ) Now include NH3 emissions ID #'s (dkh, 11/04/09) +! (2 ) Now include CO2 emissions ID #'s (dkh, 05/06/10) +! (3 ) Now inlcude more VOCs ID #'s (knl, dkh, 11/03/11, adj32_014) +! (3 ) Now inlcude dust ID #'s (xxu, dkh, 01/09/12, adj32_011) +! (3 ) Now inlcude CH4 ID #'s (kjw, dkh, 02/12/12, adj32_023) +! (3 ) Now inlcude strat flux ID #'s (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! reference to f90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + + ! local variables + INTEGER :: AS + + ! GEOS-CHEM Adjoint Emission ID #'s + ADCOEMS = 0 + ADCOVOX = 0 + IDADJ_ENH3_an = 0 + IDADJ_ENH3_bb = 0 + IDADJ_ENH3_bf = 0 + IDADJ_ENH3_na = 0 + IDADJ_ESO2_an1 = 0 + IDADJ_ESO2_an2 = 0 + IDADJ_ESO2_bb = 0 + IDADJ_ESO2_bf = 0 + IDADJ_ESO2_sh = 0 + IDADJ_EBCPI_an = 0 + IDADJ_EBCPO_an = 0 + IDADJ_EOCPI_an = 0 + IDADJ_EOCPO_an = 0 + IDADJ_EBCPI_bb = 0 + IDADJ_EBCPO_bb = 0 + IDADJ_EOCPI_bb = 0 + IDADJ_EOCPO_bb = 0 + IDADJ_EBCPI_bf = 0 + IDADJ_EBCPO_bf = 0 + IDADJ_EOCPI_bf = 0 + IDADJ_EOCPO_bf = 0 + + IDADJ_ENOX_so = 0 + IDADJ_ENOX_li = 0 + IDADJ_ENOX_ac = 0 + IDADJ_ENOX_an = 0 + IDADJ_ENOX_bf = 0 + IDADJ_ENOX_bb = 0 + IDADJ_ECO_an = 0 + IDADJ_ECO_bf = 0 + IDADJ_ECO_bb = 0 + IDADJ_EISOP_an = 0 + IDADJ_EISOP_bf = 0 + IDADJ_EISOP_bb = 0 + + ! add more VOCs (knl, dkh, 11/03/11, adj32_014) + IDADJ_EALK4_an = 0 + IDADJ_EALK4_bf = 0 + IDADJ_EALK4_bb = 0 + IDADJ_EACET_an = 0 + IDADJ_EACET_bb = 0 + IDADJ_EACET_bf = 0 + IDADJ_EMEK_an = 0 + IDADJ_EMEK_bb = 0 + IDADJ_EMEK_bf = 0 + IDADJ_EALD2_an = 0 + IDADJ_EALD2_bb = 0 + IDADJ_EALD2_bf = 0 + IDADJ_EPRPE_an = 0 + IDADJ_EPRPE_bf = 0 + IDADJ_EPRPE_bb = 0 + IDADJ_EC3H8_an = 0 + IDADJ_EC3H8_bf = 0 + IDADJ_EC3H8_bb = 0 + IDADJ_ECH2O_an = 0 + IDADJ_ECH2O_bf = 0 + IDADJ_ECH2O_bb = 0 + IDADJ_EC2H6_an = 0 + IDADJ_EC2H6_bf = 0 + IDADJ_EC2H6_bb = 0 + IDADJ_ECO2ff = 0 + IDADJ_ECO2ocn = 0 + IDADJ_ECO2bal = 0 + IDADJ_ECO2bb = 0 + IDADJ_ECO2bf = 0 + IDADJ_ECO2nte = 0 + IDADJ_ECO2shp = 0 + IDADJ_ECO2pln = 0 + IDADJ_ECO2che = 0 + IDADJ_ECO2sur = 0 + + ! (xxu, dkh, 01/09/12, adj32_011) + IDADJ_EDST1 = 0 + IDADJ_EDST2 = 0 + IDADJ_EDST3 = 0 + IDADJ_EDST4 = 0 + + + ! (kjw, dkh, 02/12/12, adj32_023) + ADCH4EMS = 1 + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + ALLOCATE( NADJ_EANTHRO( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NADJ_EANTHRO' ) + NADJ_EANTHRO = 0d0 + + ALLOCATE( NADJ_EBIOMASS( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NADJ_EBIOMASS' ) + NADJ_EBIOMASS = 0d0 + + ALLOCATE( NADJ_EBIOFUEL( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NADJ_EBIOFUEL' ) + NADJ_EBIOFUEL = 0d0 + + ENDIF + + IDADJ_POx = 0 + + + ! GEOS-CHEM Adjoint Strat prod and loss tacer ID #'s (hml, adj32_025) + NOx_p = 0 + Ox_p = 0 + PAN_p = 0 + CO_p = 0 + ALK4_p = 0 + ISOP_p = 0 + HNO3_p = 0 + H2O2_p = 0 + ACET_p = 0 + MEK_p = 0 + ALD2_p = 0 + RCHO_p = 0 + MVK_p = 0 + MACR_p = 0 + PMN_p = 0 + PPN_p = 0 + R4N2_p = 0 + PRPE_p = 0 + C3H8_p = 0 + CH2O_p = 0 + C2H6_p = 0 + N2O5_p = 0 + HNO4_p = 0 + MP_p = 0 + + NOx_l = 0 + Ox_l = 0 + PAN_l = 0 + CO_l = 0 + ALK4_l = 0 + ISOP_l = 0 + HNO3_l = 0 + H2O2_l = 0 + ACET_l = 0 + MEK_l = 0 + ALD2_l = 0 + RCHO_l = 0 + MVK_l = 0 + MACR_l = 0 + PMN_l = 0 + PPN_l = 0 + R4N2_l = 0 + PRPE_l = 0 + C3H8_l = 0 + CH2O_l = 0 + C2H6_l = 0 + N2O5_l = 0 + HNO4_l = 0 + MP_l = 0 + + ! Return to calling program + END SUBROUTINE INIT_TRACERID_ADJ + +!------------------------------------------------------------------------------ + SUBROUTINE TRACERID_ADJ +!******************************************************************************* +! This subroutine initializes adjoint emission IDs read in from "input.gcadj" +! +! (mak, 6/17/09) +! +! Notes +! (1 ) Now include NH3 emission ID #'s (dkh, 11/04/09) +! (2 ) Now include BC/OC emission ID #'s (dkh, 11/10/09) +! (3 ) Add counting of active emissions for groups of species (dkh, 11/11/09) +! (4 ) Now include CO2 emission ID #'s (dkh, 05/06/10) +!******************************************************************************* + + ! reference to f90 modules + USE TRACERID_MOD + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! IDEMS + + ! Local variables + INTEGER :: N, NN + CHARACTER(LEN=14) :: NAME + + ! Initialize counters + N_CARB_EMS_ADJ = 0 + N_SULF_EMS_ADJ = 0 + ! (xxu, dkh, 01/09/12, adj32_011) + N_DUST_EMS_ADJ = 0 + + DO N =1, NNEMS + + NAME = ADEMS_NAME(N) + + SELECT CASE ( TRIM( NAME ) ) + + ! tagged CO + CASE ( 'ADCOEMS' ) + ADCOEMS = ID_ADEMS(N) + CASE( 'ADCOVOX' ) + ADCOVOX = ID_ADEMS(N) + + ! tagged CO + CASE ( 'IDADJ_POx' ) + IDADJ_POx = ID_ADEMS(N) + + ! Methane, CH4 (kjw, dkh, 02/12/12, adj32_023) + CASE( 'ADCH4EMS' ) + ADCH4EMS = ID_ADEMS(N) + + ! sulfate aerosol + CASE( 'IDADJ_ENH3_an' ) + IDADJ_ENH3_an = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ENH3_bb' ) + IDADJ_ENH3_bb = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ENH3_bf' ) + IDADJ_ENH3_bf = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ENH3_na' ) + IDADJ_ENH3_na = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ESO2_an1' ) + IDADJ_ESO2_an1 = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ESO2_an2' ) + IDADJ_ESO2_an2 = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ESO2_bb' ) + IDADJ_ESO2_bb = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ESO2_bf' ) + IDADJ_ESO2_bf = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + CASE( 'IDADJ_ESO2_sh' ) + IDADJ_ESO2_sh = ID_ADEMS(N) + N_SULF_EMS_ADJ = N_SULF_EMS_ADJ + 1 + + + ! carbon arerosol + CASE( 'IDADJ_EBCPI_an' ) + IDADJ_EBCPI_an = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EBCPO_an' ) + IDADJ_EBCPO_an = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPI_an' ) + IDADJ_EOCPI_an = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPO_an' ) + IDADJ_EOCPO_an = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EBCPI_bb' ) + IDADJ_EBCPI_bb = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EBCPO_bb' ) + IDADJ_EBCPO_bb = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPI_bb' ) + IDADJ_EOCPI_bb = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPO_bb' ) + IDADJ_EOCPO_bb = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EBCPI_bf' ) + IDADJ_EBCPI_bf = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EBCPO_bf' ) + IDADJ_EBCPO_bf = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPI_bf' ) + IDADJ_EOCPI_bf = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + CASE( 'IDADJ_EOCPO_bf' ) + IDADJ_EOCPO_bf = ID_ADEMS(N) + N_CARB_EMS_ADJ = N_CARB_EMS_ADJ + 1 + + ! specific NOx emissions + CASE( 'IDADJ_ENOX_so' ) + IDADJ_ENOX_so = ID_ADEMS(N) + CASE( 'IDADJ_ENOX_li' ) + IDADJ_ENOX_li = ID_ADEMS(N) + CASE( 'IDADJ_ENOX_ac' ) + IDADJ_ENOX_ac = ID_ADEMS(N) + + ! gas-phase emissions . Corresponds to + ! any species in SMVGEAR / KPP with an + ! emissions reaction + CASE( 'IDADJ_ENOX_an' ) + IDADJ_ENOX_an = ID_ADEMS(N) + NN = IDEMS(IDENOX) + NADJ_EANTHRO(NN) = IDADJ_ENOX_an + CASE( 'IDADJ_ECO_an' ) + IDADJ_ECO_an = ID_ADEMS(N) + NN = IDEMS(IDECO) + NADJ_EANTHRO(NN) = IDADJ_ECO_an + CASE( 'IDADJ_EISOP_an' ) + IDADJ_EISOP_an = ID_ADEMS(N) + NN = IDEMS(IDEISOP) + NADJ_EANTHRO(NN) = IDADJ_EISOP_an + + ! add more VOCs (knl, dkh, 11/03/11i, adj32_014) + CASE( 'IDADJ_EALK4_an' ) + IDADJ_EALK4_an = ID_ADEMS(N) + NN = IDEMS(IDEALK4) + NADJ_EANTHRO(NN) = IDADJ_EALK4_an + CASE( 'IDADJ_EACET_an' ) + IDADJ_EACET_an = ID_ADEMS(N) + NN = IDEMS(IDEACET) + NADJ_EANTHRO(NN) = IDADJ_EACET_an + CASE( 'IDADJ_EMEK_an' ) + IDADJ_EMEK_an = ID_ADEMS(N) + NN = IDEMS(IDEMEK) + NADJ_EANTHRO(NN) = IDADJ_EMEK_an + CASE( 'IDADJ_EALD2_an' ) + IDADJ_EALD2_an = ID_ADEMS(N) + NN = IDEMS(IDEALD2) + NADJ_EANTHRO(NN) = IDADJ_EALD2_an + CASE( 'IDADJ_EPRPE_an' ) + IDADJ_EPRPE_an = ID_ADEMS(N) + NN = IDEMS(IDEPRPE) + NADJ_EANTHRO(NN) = IDADJ_EPRPE_an + CASE( 'IDADJ_EC3H8_an' ) + IDADJ_EC3H8_an = ID_ADEMS(N) + NN = IDEMS(IDEC3H8) + NADJ_EANTHRO(NN) = IDADJ_EC3H8_an + CASE( 'IDADJ_ECH2O_an' ) + IDADJ_ECH2O_an = ID_ADEMS(N) + NN = IDEMS(IDECH2O) + NADJ_EANTHRO(NN) = IDADJ_ECH2O_an + CASE( 'IDADJ_EC2H6_an' ) + IDADJ_EC2H6_an = ID_ADEMS(N) + NN = IDEMS(IDEC2H6) + NADJ_EANTHRO(NN) = IDADJ_EC2H6_an + + + CASE( 'IDADJ_ENOX_bb' ) + IDADJ_ENOX_bb = ID_ADEMS(N) + NN = IDEMS(IDENOX) + NADJ_EBIOMASS(NN) = IDADJ_ENOX_bb + CASE( 'IDADJ_ECO_bb' ) + IDADJ_ECO_bb = ID_ADEMS(N) + NN = IDEMS(IDECO) + NADJ_EBIOMASS(NN) = IDADJ_ECO_bb + CASE( 'IDADJ_EISOP_bb' ) + IDADJ_EISOP_bb = ID_ADEMS(N) + NN = IDEMS(IDEISOP) + NADJ_EBIOMASS(NN) = IDADJ_EISOP_bb + + ! add more VOCs (knl, dkh, 11/03/11, adj32_014) + CASE( 'IDADJ_EALK4_bb' ) + IDADJ_EALK4_bb = ID_ADEMS(N) + NN = IDEMS(IDEALK4) + NADJ_EBIOMASS(NN) = IDADJ_EALK4_bb + CASE( 'IDADJ_EACET_bb' ) + IDADJ_EACET_bb = ID_ADEMS(N) + NN = IDEMS(IDEACET) + NADJ_EBIOMASS(NN) = IDADJ_EACET_bb + CASE( 'IDADJ_EMEK_bb' ) + IDADJ_EMEK_bb = ID_ADEMS(N) + NN = IDEMS(IDEMEK) + NADJ_EBIOMASS(NN) = IDADJ_EMEK_bb + CASE( 'IDADJ_EALD2_bb' ) + IDADJ_EALD2_bb = ID_ADEMS(N) + NN = IDEMS(IDEALD2) + NADJ_EBIOMASS(NN) = IDADJ_EALD2_bb + CASE( 'IDADJ_EPRPE_bb' ) + IDADJ_EPRPE_bb = ID_ADEMS(N) + NN = IDEMS(IDEPRPE) + NADJ_EBIOMASS(NN) = IDADJ_EPRPE_bb + CASE( 'IDADJ_EC3H8_bb' ) + IDADJ_EC3H8_bb = ID_ADEMS(N) + NN = IDEMS(IDEC3H8) + NADJ_EBIOMASS(NN) = IDADJ_EC3H8_bb + CASE( 'IDADJ_ECH2O_bb' ) + IDADJ_ECH2O_bb = ID_ADEMS(N) + NN = IDEMS(IDECH2O) + NADJ_EBIOMASS(NN) = IDADJ_ECH2O_bb + CASE( 'IDADJ_EC2H6_bb' ) + IDADJ_EC2H6_bb = ID_ADEMS(N) + NN = IDEMS(IDEC2H6) + NADJ_EBIOMASS(NN) = IDADJ_EC2H6_bb + + + CASE( 'IDADJ_ENOX_bf' ) + IDADJ_ENOX_bf = ID_ADEMS(N) + NN = IDEMS(IDENOX) + NADJ_EBIOFUEL(NN) = IDADJ_ENOX_bf + CASE( 'IDADJ_ECO_bf' ) + IDADJ_ECO_bf = ID_ADEMS(N) + NN = IDEMS(IDECO) + NADJ_EBIOFUEL(NN) = IDADJ_ECO_bf + CASE( 'IDADJ_EISOP_bf' ) + IDADJ_EISOP_bf = ID_ADEMS(N) + NN = IDEMS(IDEISOP) + NADJ_EBIOFUEL(NN) = IDADJ_EISOP_bf + + ! add more VOCs (knl, dkh, 11/03/11, adj32_014) + CASE( 'IDADJ_EALK4_bf' ) + IDADJ_EALK4_bf = ID_ADEMS(N) + NN = IDEMS(IDEALK4) + NADJ_EBIOFUEL(NN) = IDADJ_EALK4_bf + CASE( 'IDADJ_EACET_bf' ) + IDADJ_EACET_bf = ID_ADEMS(N) + NN = IDEMS(IDEACET) + NADJ_EBIOFUEL(NN) = IDADJ_EACET_bf + CASE( 'IDADJ_EMEK_bf' ) + IDADJ_EMEK_bf = ID_ADEMS(N) + NN = IDEMS(IDEMEK) + NADJ_EBIOFUEL(NN) = IDADJ_EMEK_bf + CASE( 'IDADJ_EALD2_bf' ) + IDADJ_EALD2_bf = ID_ADEMS(N) + NN = IDEMS(IDEALD2) + NADJ_EBIOFUEL(NN) = IDADJ_EALD2_bf + CASE( 'IDADJ_EPRPE_bf' ) + IDADJ_EPRPE_bf = ID_ADEMS(N) + NN = IDEMS(IDEPRPE) + NADJ_EBIOFUEL(NN) = IDADJ_EPRPE_bf + CASE( 'IDADJ_EC3H8_bf' ) + IDADJ_EC3H8_bf = ID_ADEMS(N) + NN = IDEMS(IDEC3H8) + NADJ_EBIOFUEL(NN) = IDADJ_EC3H8_bf + CASE( 'IDADJ_ECH2O_bf' ) + IDADJ_ECH2O_bf = ID_ADEMS(N) + NN = IDEMS(IDECH2O) + NADJ_EBIOFUEL(NN) = IDADJ_ECH2O_bf + CASE( 'IDADJ_EC2H6_bf' ) + IDADJ_EC2H6_bf = ID_ADEMS(N) + NN = IDEMS(IDEC2H6) + NADJ_EBIOFUEL(NN) = IDADJ_EC2H6_bf + + ! CO2 emissions + CASE( 'IDADJ_ECO2ff' ) + IDADJ_ECO2ff = ID_ADEMS(N) + CASE( 'IDADJ_ECO2ocn' ) + IDADJ_ECO2ocn = ID_ADEMS(N) + CASE( 'IDADJ_ECO2bal' ) + IDADJ_ECO2bal = ID_ADEMS(N) + CASE( 'IDADJ_ECO2bb' ) + IDADJ_ECO2bb = ID_ADEMS(N) + CASE( 'IDADJ_ECO2bf' ) + IDADJ_ECO2bf = ID_ADEMS(N) + CASE( 'IDADJ_ECO2nte' ) + IDADJ_ECO2nte = ID_ADEMS(N) + CASE( 'IDADJ_ECO2shp' ) + IDADJ_ECO2shp = ID_ADEMS(N) + CASE( 'IDADJ_ECO2pln' ) + IDADJ_ECO2pln = ID_ADEMS(N) + CASE( 'IDADJ_ECO2che' ) + IDADJ_ECO2che = ID_ADEMS(N) + CASE( 'IDADJ_ECO2sur' ) + IDADJ_ECO2sur = ID_ADEMS(N) + + ! Dust emissions (xxu, dkh, 01/09/12, adj32_011) + CASE( 'IDADJ_EDST1' ) + IDADJ_EDST1 = ID_ADEMS(N) + N_DUST_EMS_ADJ = N_DUST_EMS_ADJ + 1 + CASE( 'IDADJ_EDST2' ) + IDADJ_EDST2 = ID_ADEMS(N) + N_DUST_EMS_ADJ = N_DUST_EMS_ADJ + 1 + CASE( 'IDADJ_EDST3' ) + IDADJ_EDST3 = ID_ADEMS(N) + N_DUST_EMS_ADJ = N_DUST_EMS_ADJ + 1 + CASE( 'IDADJ_EDST4' ) + IDADJ_EDST4 = ID_ADEMS(N) + N_DUST_EMS_ADJ = N_DUST_EMS_ADJ + 1 + END SELECT + + ENDDO + + END SUBROUTINE TRACERID_ADJ + +!------------------------------------------------------------------------------ + SUBROUTINE STRPID_ADJ +! +!******************************************************************************* +! This subroutine initializes adjoint strat prod IDs read in from +! "input.gcadj" (hml, dkh, 02/14/12, adj32_025) +! +! Notes +! (1 ) +!******************************************************************************* + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! IDEMS + + ! Local variables + INTEGER :: N + CHARACTER(LEN=12) :: NAME + + ! Initialize counters + N_STR_PROD_ADJ = 0 + + ! For production + DO N =1, NSTPL + + NAME = PROD_NAME(N) + + SELECT CASE ( TRIM( NAME ) ) + + CASE( 'NOx_p' ) + NOx_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'Ox_p' ) + Ox_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'PAN_p' ) + PAN_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'CO_p' ) + CO_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'ALK4_p' ) + ALK4_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'ISOP_p' ) + ISOP_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'HNO3_p' ) + HNO3_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'H2O2_p' ) + H2O2_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'ACET_p' ) + ACET_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'MEK_p' ) + MEK_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'ALD2_p' ) + ALD2_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'RCHO_p' ) + RCHO_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'MVK_p' ) + MVK_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'MACR_p' ) + MACR_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'PMN_p' ) + PMN_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'PPN_p' ) + PPN_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'R4N2_p' ) + R4N2_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'PRPE_p' ) + PRPE_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'C3H8_p' ) + C3H8_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'CH2O_p' ) + CH2O_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'C2H6_p' ) + C2H6_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'N2O5_p' ) + N2O5_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'HNO4_p' ) + HNO4_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + CASE( 'MP_p' ) + MP_p = ID_PROD(N) + N_STR_PROD_ADJ = N_STR_PROD_ADJ + 1 + + END SELECT + + ENDDO + + END SUBROUTINE STRPID_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE STRLID_ADJ +! +!******************************************************************************* +! This subroutine initializes adjoint strat loss IDs read in from +! "input.gcadj" (hml, dkh, 02/14/12, adj32_025) +! +! Notes +! (1 ) +!******************************************************************************* + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! IDEMS + + ! Local variables + INTEGER :: N + CHARACTER(LEN=12) :: NAME + + ! Initialize counters + N_STR_LOSS_ADJ = 0 + + ! For production + DO N =1, NSTPL + + NAME = LOSS_NAME(N) + + SELECT CASE ( TRIM( NAME ) ) + + CASE( 'NOx_l' ) + NOx_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'Ox_l' ) + Ox_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'PAN_l' ) + PAN_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'CO_l' ) + CO_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'ALK4_l' ) + ALK4_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'ISOP_l' ) + ISOP_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'HNO3_l' ) + HNO3_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'H2O2_l' ) + H2O2_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'ACET_l' ) + ACET_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'MEK_l' ) + MEK_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'ALD2_l' ) + ALD2_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'RCHO_l' ) + RCHO_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'MVK_l' ) + MVK_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'MACR_l' ) + MACR_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'PMN_l' ) + PMN_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'PPN_l' ) + PPN_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'R4N2_l' ) + R4N2_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'PRPE_l' ) + PRPE_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'C3H8_l' ) + C3H8_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'CH2O_l' ) + CH2O_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'C2H6_l' ) + C2H6_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'N2O5_l' ) + N2O5_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'HNO4_l' ) + HNO4_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + CASE( 'MP_l' ) + MP_l = ID_LOSS(N) + N_STR_LOSS_ADJ = N_STR_LOSS_ADJ + 1 + + END SELECT + + ENDDO + + END SUBROUTINE STRLID_ADJ + +!------------------------------------------------------------------------------ + SUBROUTINE INIT_ADJ_ARRAYS +! +!****************************************************************************** +! Subroutine INIT_ADJ_ARRAYS initializes and zeroes all module arrays.! +! (mak, bmy, 3/14/06) +! +! NOTES: +! (1 ) Update for merged v8 adjoint. (dkh, mak, 06/08/09) +! (2 ) Add support for LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (3 ) Move VAR_FD and RCONST_FD here (dkh, 02/23/12, adj32_026) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE GCKPP_ADJ_PARAMETERS, ONLY : NVAR, NREACT + USE TIME_MOD, ONLY : CALC_RUN_DAYS + USE TIME_MOD, ONLY : GET_TAUb + USE TIME_MOD, ONLY : GET_TAUe + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS, LDCOSAT + USE LOGICAL_ADJ_MOD, ONLY : LEMS_ABS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + USE GCKPP_ADJ_GLOBAL, ONLY : NCOEFF + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ !fp + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NEMIS, NCS +# include "define_adj.h" ! NEMIS, NCS + + + INTEGER :: AS + INTEGER :: NCHEM_MAX + REAL*8 :: TOTAL_MINUTES + + + !================================================================= + ! INIT_ADJ_ARRAYS begins here! + !================================================================= + + IF ( LDCOSAT ) THEN + CALL CALC_NUM_SAT + ENDIF + + DAYS = CALC_RUN_DAYS() + DAY_OF_SIM = -1 + + IF ( LADJ ) THEN + + ALLOCATE( FORCING( IIPAR, JJPAR, DAYS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'FORCING' ) + FORCING = 0d0 + + ALLOCATE( SHIPO3DEP_ADJ( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SHIPO3DEP_ADJ' ) + SHIPO3DEP_ADJ = 0d0 + + ALLOCATE( MOP_MOD_DIFF( IIPAR, JJPAR, DAYS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MOP_MOD_DIFF' ) + MOP_MOD_DIFF = 0d0 + + ALLOCATE( MODEL_BIAS( IIPAR, JJPAR, DAYS,sat ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MODEL_BIAS' ) + MODEL_BIAS = 0d0 + + ALLOCATE( MODEL( IIPAR, JJPAR, DAYS,sat ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MODEL' ) + MODEL = -999d0 + + ALLOCATE( SAT_DOFS( IIPAR, JJPAR, DAYS,sat ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SAT_DOFS' ) + SAT_DOFS = -999d0 + + ALLOCATE( OBS( IIPAR, JJPAR, DAYS, sat ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS' ) + OBS = -999d0 + + ALLOCATE( COST_ARRAY(IIPAR, JJPAR, DAYS ), + & STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COST_ARRAY' ) + COST_ARRAY(:,:,:) = 0d0 + + ALLOCATE( EMS_orig( IIPAR, JJPAR, MMSCL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_orig' ) + EMS_orig = 0d0 + + ALLOCATE( OBS_COUNT(IIPAR, JJPAR ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS_COUNT' ) + OBS_COUNT(:,:) = 0 + + ALLOCATE( REMIS_ADJ( ITLOOP, MAXGL3 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REMIS_ADJ' ) + REMIS_ADJ = 0d0 + + ENDIF + + ALLOCATE( ICS_SF(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_SF' ) + ICS_SF = 0d0 + + ALLOCATE( ICS_SF0(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_SF0' ) + ICS_SF0 = 0d0 + + IF ( LADJ ) THEN + + ALLOCATE( ICS_SF_ADJ(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_SF_ADJ' ) + ICS_SF_ADJ = 0d0 + + ALLOCATE( OBS_STT(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS_STT' ) + OBS_STT = 0d0 + + ALLOCATE( STT_ADJ(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'STT_ADJ' ) + STT_ADJ = 0d0 + + ALLOCATE( CF_REGION(IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CF_REGION' ) + CF_REGION = 0d0 + + ALLOCATE( ADJ_FORCE(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADJ_FOCE' ) + ADJ_FORCE = 0d0 + + ALLOCATE( COST_FUNC_SAV( N_CALC_STOP ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COST_FUNC_SAV' ) + + ALLOCATE( STT_ADJ_FD( N_CALC_STOP ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'STT_ADJ_FD' ) + STT_ADJ_FD = 0d0 + + ALLOCATE( STT_ORIG(IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'STT_ORIG' ) + STT_ORIG = 0d0 + + ENDIF + + IF ( LADJ_EMS ) THEN + ALLOCATE( EMS_SF(IIPAR, JJPAR, MMSCL, NNEMS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF' ) + EMS_SF = 0d0 + + ALLOCATE( EMS_SF0(IIPAR, JJPAR, MMSCL, NNEMS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF0' ) + EMS_SF0 = 0d0 + + IF ( LADJ ) THEN + + ALLOCATE( EMS_SF_ADJ(IIPAR, JJPAR, MMSCL, NNEMS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF_ADJ' ) + EMS_SF_ADJ = 0d0 + + ALLOCATE( TEMP2(IIPAR, JJPAR, MMSCL, NNEMS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TEMP2' ) + TEMP2 = 0d0 + + ENDIF + + IF ( LEMS_ABS ) THEN + ALLOCATE( EMS_ADJ(IIPAR, JJPAR, MMSCL, NNEMS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_ADJ' ) + EMS_ADJ = 0d0 + ENDIF + + ! Strat prod and loss (hml, 07/26/11, adj32_025) + IF ( LADJ_STRAT ) THEN + ALLOCATE( PROD_SF(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_SF' ) + PROD_SF = 0d0 + + ALLOCATE( PROD_SF0(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_SF0' ) + PROD_SF0 = 0d0 + + ALLOCATE( LOSS_SF(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_SF' ) + LOSS_SF = 0d0 + + ALLOCATE( LOSS_SF0(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_SF0' ) + LOSS_SF0 = 0d0 + + ALLOCATE( PROD_SF_ADJ(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_SF_ADJ' ) + PROD_SF_ADJ = 0d0 + + ALLOCATE( P_ADJ(IIPAR, JJPAR, LLPAR, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'P_ADJ' ) + P_ADJ = 0d0 + + ALLOCATE( LOSS_SF_ADJ(IIPAR, JJPAR, MMSCL, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_SF_ADJ' ) + LOSS_SF_ADJ = 0d0 + + ALLOCATE( k_ADJ(IIPAR, JJPAR, LLPAR, NSTPL), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'k_ADJ' ) + k_ADJ = 0d0 + + ENDIF + + ! tww, 05/15/12 + IF (LADJ_RRATE) THEN + ALLOCATE( RATE_SF(IIPAR,JJPAR,LLPAR,NRRATES), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RATE_SF' ) + RATE_SF = 0d0 + + ALLOCATE( RATE_SF0(IIPAR,JJPAR,LLPAR,NRRATES), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RATE_SF0' ) + RATE_SF0 = 0d0 + ENDIF + + ENDIF + + ! fullchem emissions adjoint arrays (dkh, 03/30/10) + IF ( ITS_A_FULLCHEM_SIM() .and. LADJ ) THEN + + !d!IF ( LADJ_EMS ) THEN + + ALLOCATE( DEPSAV_ADJ( IIPAR, JJPAR, MAXGL3 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DEPSAV_ADJ' ) + DEPSAV_ADJ = 0d0 + + !d!ENDIF + + IF (LADJ_RRATE ) THEN + ! Added for reaction rate sensitivities (tww, 05/08/12) + ! Debug (hml, 04/07/13) NCOEFF -> NRRATES + !ALLOCATE( RATE_SF_ADJ( IIPAR, JJPAR, LLPAR, NCOEFF ), STAT=AS) + ALLOCATE( RATE_SF_ADJ( IIPAR, JJPAR, LLPAR, NRRATES ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RATE_SF_ADJ' ) + RATE_SF_ADJ = 0d0 + ENDIF + + ! Determine max number of chemical time steps and allocate arrays + ! (dkh, 02/23/12, adj32_026) + ! Calculate minute per simulation + TOTAL_MINUTES = 60d0 * ( GET_TAUe() - GET_TAUb() ) + + ! Calculate # of chemical time steps, add 1 to be safe + NCHEM_MAX = INT(TOTAL_MINUTES / GET_TS_CHEM()) + 1 + + ! debug + print*, ' in CINSPECT , NCHEM_MAX = ', NCHEM_MAX, TOTAL_MINUTES + + ! Allocate arrays + ALLOCATE( VAR_FD( NVAR, NCHEM_MAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'VAR_FD' ) + VAR_FD = 0d0 + + ALLOCATE( RCONST_FD( NREACT, NCHEM_MAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RCONST_FD' ) + RCONST_FD = 0d0 + + ENDIF + +#if defined( TES_O3_OBS ) || defined ( LIDORT ) || defined ( TES_O3_IRK ) + + ! O3 profiles for comparison in strat + ALLOCATE( O3_PROF_SAV( IIPAR, JJPAR, LLPAR+1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'O3_PROF_SAV' ) + O3_PROF_SAV = 0d0 + +#endif + +#if defined(EANET_OBS) || defined(EMEP_OBS) || defined(NADP_OBS) + ALLOCATE( NHX_ADJ_FORCE( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NHX_ADJ_FORCE' ) + NHX_ADJ_FORCE = 0d0 +#endif + + +! NOR obsolete (zhej, dkh, 01/16/12, adj32_015) +!#if defined( NESTED_CH ) +! NOR(1) = 8 !W_Lon (zhe 1/19/11) +! NOR(2) = 114 !E_Lon +! NOR(3) = 44 !S_Lat +! NOR(4) = 124 !N_Lat +!#endif +!#if defined( NESTED_NA ) +! NOR(1) = 8 +! NOR(2) = ??? +! NOR(2) = 10 +! NOR(2) = ??? +!#endif + + INV_NSPAN = REAL( 1d0 / NSPAN, 8 ) + + ! total dimension in 1D (dkh, 01/12/12) + ! Problems when HMAX is defined here + !so now defines that in inv_hessian_lbfgs_mod.f + ! need to be put back here later + ! (nab, 03/28/12, ) + + ! HMAX = IIPAR * JJPAR * MMSCL * NNEMS + + + IF ( LADJ_FDEP ) THEN + + IF ( LADJ_DDEP_TRACER ) THEN + + ALLOCATE( DDEP_TRACER( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DDEP_TRACER' ) + DDEP_TRACER = 0d0 + + ALLOCATE( AD44_OLD( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD44_OLD' ) + AD44_OLD = 0d0 + + ENDIF + + IF ( LADJ_DDEP_CSPEC ) THEN + + ALLOCATE( DDEP_CSPEC( IIPAR, JJPAR, NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DDEP_CSPEC' ) + DDEP_CSPEC = 0d0 + + ALLOCATE( AD44_CSPEC_OLD( IIPAR, JJPAR, NOBS_CSPEC ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD44_CSPEC_OLD' ) + AD44_CSPEC_OLD = 0d0 + + ENDIF + + IF ( LADJ_WDEP_CV ) THEN + + ALLOCATE( WDEP_CV( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'WDEP_CV' ) + WDEP_CV = 0d0 + + ALLOCATE( AD38_OLD( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD38_OLD' ) + AD38_OLD = 0d0 + + ENDIF + + IF ( LADJ_WDEP_LS ) THEN + + ALLOCATE( WDEP_LS( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'WDEP_LS' ) + WDEP_LS = 0d0 + + ALLOCATE( AD39_OLD( IIPAR, JJPAR, NOBS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD39_OLD' ) + AD39_OLD = 0d0 + + ENDIF + ENDIF + + ! Return to calling program + END SUBROUTINE INIT_ADJ_ARRAYS + +!-------------------------------------------------------------------------------- + + SUBROUTINE INIT_UNITS_DEP +! +!****************************************************************************** +! Subroutine INIT_UNITS_DEP sets the arrays which handle unit conversion +! for the deposition based cost function (fp, dkh, 04/18/13) +! +! NOTES: +! (1 ) Add special treatment for N2O5 (2N) +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE LOGICAL_ADJ_MOD, ONLY : LKGNHAYR + USE LOGICAL_ADJ_MOD, ONLY : LEQHAYR + USE LOGICAL_ADJ_MOD, ONLY : LMOLECCM2S + USE LOGICAL_ADJ_MOD, ONLY : LKGS + USE LOGICAL_ADJ_MOD, ONLY : LFORCE_MASK + USE TRACER_MOD, ONLY : N_TRACERS, TRACER_MW_KG + USE TRACER_MOD, ONLY : TRACER_NAME + USE TRACERID_MOD, ONLY : IDTSO4, IDTN2O5, IDTSO2 + +# include "CMN_SIZE" ! Size params + + ! local variables + INTEGER :: AS, J, N + + !================================================================= + ! INIT_UNITS_DEP begins here! + !================================================================= + + IF ( LADJ_DDEP_TRACER ) THEN + + ALLOCATE( TR_DDEP_CONV(JJPAR,N_TRACERS), STAT = AS ) + IF ( AS /=0 ) CALL ALLOC_ERR('TR_DDEP_CONV') + TR_DDEP_CONV(:,:) = 0d0 + + IF ( LMOLECCM2S ) THEN + IF ( LFORCE_MASK ) THEN + DO J = 1, JJPAR + TR_DDEP_CONV(J,:) = + & GET_AREA_CM2(J) / ADJOINT_AREA_M2 * 1D-4 + ENDDO + ELSE + TR_DDEP_CONV(:,:) = 1d0 + ENDIF + ENDIF + + IF ( LKGS ) THEN + DO N = 1, N_TRACERS + IF ( OBS_THIS_TRACER(N) ) THEN + DO J = 1, JJPAR + TR_DDEP_CONV(J,N) = + & TRACER_MW_KG(N) / 6.022D23 * GET_AREA_CM2(J) + ENDDO + ENDIF + ENDDO + ENDIF + + IF ( LKGNHAYR ) THEN + IF ( LFORCE_MASK ) THEN + DO J=1,JJPAR + + ! cm2 -> ha + TR_DDEP_CONV(J,:) = 1d4 + & / ADJOINT_AREA_M2 + & * GET_AREA_CM2(J) + + ! molec -> kgN + TR_DDEP_CONV(J,:) = TR_DDEP_CONV(J,:) + & * 14D-3 / 6.022D23 + + ! s -> yr + TR_DDEP_CONV(J,:) = TR_DDEP_CONV(J,:) + & * 86400D0 * 365D0 + + ENDDO + ELSE + DO J = 1, JJPAR + TR_DDEP_CONV(J,:) = 1d8 + & * 14D-3 / 6.022D23 * 86400D0 * 365D0 + ENDDO + ENDIF + + ENDIF + + !equivalent ha(-1) yr(-1) + IF ( LEQHAYR ) THEN + IF ( LFORCE_MASK ) THEN + DO N = 1, N_TRACERS + IF ( OBS_THIS_TRACER(N) ) THEN + DO J = 1, JJPAR + TR_DDEP_CONV(J,N) = + & 1D0 / 6.022D23 + & * 86400D0 * 365D0 + & * 1D4 / ADJOINT_AREA_M2 + & * GET_AREA_CM2(J) + + IF ( N .EQ. IDTSO4 + & .OR. N .EQ. IDTSO2) THEN + TR_DDEP_CONV(J,N) = TR_DDEP_CONV(J,N) + & * 2D0 + IF ( J .EQ. 1) THEN + WRITE(6,100) TRIM(TRACER_NAME(N)) + ENDIF + ENDIF + + ENDDO + ENDIF + ENDDO + + ELSE + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + DO J= 1, JJPAR + TR_DDEP_CONV(J,N) = 1d0 + & / 6.022D23 + & * 86400D0 * 365D0 * 1D8 + + IF ( N .EQ. IDTSO4 + & .OR. N .EQ. IDTSO2 ) THEN + + TR_DDEP_CONV(J,N) = TR_DDEP_CONV(J,N) + & * 2D0 + + IF ( J .EQ. 1) THEN + WRITE(6,100) TRIM(TRACER_NAME(N)) + ENDIF + + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ENDIF + ENDIF + + IF ( LADJ_DDEP_CSPEC ) THEN + + ALLOCATE( CS_DDEP_CONV(JJPAR,NOBS_CSPEC), STAT = AS ) + IF ( AS /=0 ) CALL ALLOC_ERR('CS_DDEP_CONV') + + CS_DDEP_CONV(:,:) = 0D0 + + !default unit + IF ( LMOLECCM2S ) THEN + IF ( LFORCE_MASK ) THEN + DO J = 1, JJPAR + CS_DDEP_CONV(J,:) = + & GET_AREA_CM2(J) / ADJOINT_AREA_M2 * 1D-4 + ENDDO + ELSE + CS_DDEP_CONV(:,:) = 1d0 + ENDIF + ENDIF + +! IF ( LKGS ) THEN +! DO N = 1, NOBS_CSPEC +! DO J = 1, JJPAR +!this requires to know the molecular weight of cspec species. +!I don't think there is a way to know that without further user input. +!for now make it impossible to turn on lkgs when observing cspec +! TR_DDEP_CONV(J,:) = +! & TRACER_MW_CSPEC(N)/6.022D23*GET_AREA_CM2(J) +! ENDDO +! ENDDO +! ENDIF + + ! kg N / ha / yr + IF ( LKGNHAYR ) THEN + + ! a receptor region is defined + IF ( LFORCE_MASK ) THEN + + DO N = 1, NOBS_CSPEC + + DO J = 1, JJPAR + + ! area conversion + CS_DDEP_CONV(J,N) = GET_AREA_CM2(J) + & * 1D4 / ADJOINT_AREA_M2 + + ! time conversion + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 86400D0 * 365D0 + + ! molec->kgN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 14D-3 / 6.022D23 + + IF (TRIM(CNAME(N)) .EQ. 'DRYN2O5') THEN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 2D0 + IF ( J .EQ. 1 ) THEN + WRITE(*,*) '-> 2N in N2O5' !fp check + ENDIF + ENDIF + + ENDDO + + ENDDO + + ELSE + + DO N = 1,NOBS_CSPEC + + DO J=1,JJPAR + + ! area conversion (cm2->ha) + CS_DDEP_CONV(J,N) = 1D8 + + ! time conversion + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 86400D0 * 365D0 + + ! molec->kgN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 14D-3 / 6.022D23 + + IF (CNAME(N) .EQ. 'DRYN2O5') THEN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 2D0 + IF ( J .EQ. 1 ) THEN + WRITE(*,*) '-> 2N in N2O5' !fp check + ENDIF + ENDIF + + ENDDO + + ENDDO + + ENDIF + + ENDIF + + IF ( LEQHAYR ) THEN + + ! a receptor region is defined + IF ( LFORCE_MASK ) THEN + + DO N = 1,NOBS_CSPEC + + DO J = 1, JJPAR + + ! area conversion + CS_DDEP_CONV(J,N) = GET_AREA_CM2(J) + & * 1D4 / ADJOINT_AREA_M2 + + ! time conversion + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 86400D0 * 365D0 + + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 1D0 / 6.022D23 + + IF (CNAME(N) .EQ. 'DRYN2O5') THEN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 2D0 + IF ( J .EQ. 1 ) THEN + WRITE(6,100) 'N2O5' + ENDIF + ENDIF + + ENDDO + + ENDDO + + ELSE + + DO N = 1, NOBS_CSPEC + + DO J = 1, JJPAR + + ! area conversion (cm2->ha) + CS_DDEP_CONV(J,N) = 1D8 + + ! time conversion + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 86400D0 * 365D0 + + ! molec->mueq + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 1D0 / 6.022D23 + IF (TRIM(CNAME(N)) .EQ. 'DRYN2O5') THEN + CS_DDEP_CONV(J,N) = CS_DDEP_CONV(J,N) + & * 2D0 + IF ( J .EQ. 1 ) THEN + WRITE(6,100) 'N2O5' + ENDIF + ENDIF + + ENDDO + + ENDDO + + ENDIF + + ENDIF + + ENDIF + + ! Use the same unit conversion array for both convective and large-scale + ! precipitation + IF ( LADJ_WDEP_CV .or. LADJ_WDEP_LS ) THEN + + ALLOCATE( TR_WDEP_CONV(JJPAR,N_TRACERS), STAT = AS ) + IF (AS /=0) CALL ALLOC_ERR('TR_WDEP_CONV') + + TR_WDEP_CONV(:,:) = 0d0 + + ! from kg/s to molec/cm2/s + IF ( LMOLECCM2S ) THEN + + IF ( LFORCE_MASK ) THEN + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + ! kg -> molec + TR_WDEP_CONV(:,N) = + & 6.022D23 * 1D0 / TRACER_MW_KG(N) + + ! to cm2 + TR_WDEP_CONV(:,N) = 1D-4 / ADJOINT_AREA_M2 + & * TR_WDEP_CONV(:,N) + + ENDIF + + ENDDO + + ELSE + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + ! kg -> molec + TR_WDEP_CONV(:,N) = 6.022D23 * 1D0 + & / TRACER_MW_KG(N) + ! to cm2 + DO J = 1, JJPAR + TR_WDEP_CONV(J,N) = 1D0 / GET_AREA_CM2(J) + & * TR_WDEP_CONV(J,N) + ENDDO + + ENDIF + + ENDDO + + ENDIF + + ENDIF + + IF ( LKGS ) THEN + TR_WDEP_CONV(:,:) = 1D0 + ENDIF + + ! convert from kg/s to kgn/ha/yr + IF ( LKGNHAYR ) THEN + + IF ( LFORCE_MASK ) THEN + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + ! kg->kgN !NOTE THIS ASSUMES ONLY ONE N PER MOLECULE (by default) + TR_WDEP_CONV(:,N) = 14D-3 / TRACER_MW_KG(N) + + !for N2O5 account for 2N + IF ( N .eq. IDTN2O5 ) + & TR_WDEP_CONV(:,N) = TR_WDEP_CONV(:,N) * 2D0 + + ! s to yr + TR_WDEP_CONV(:,N) = 86400D0 * 365D0 + & *TR_WDEP_CONV(:,N) + + ! to ha + TR_WDEP_CONV(:,N) = 1D4 / ADJOINT_AREA_M2 + & * TR_WDEP_CONV(:,N) + + ENDIF + + ENDDO + + ELSE + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + DO J = 1, JJPAR + + ! kg->kgN !NOTE THIS ASSUMES ONLY ONE N PER MOLECULE + TR_WDEP_CONV(J,N) = 14D-3 / TRACER_MW_KG(N) + + !for N2O5 account for 2N + IF ( N .eq. IDTN2O5 ) + & TR_WDEP_CONV(J,N) = TR_WDEP_CONV(J,N) * 2D0 + + ! s to yr + TR_WDEP_CONV(J,N) = 86400D0 * 365D0 + & * TR_WDEP_CONV(J,N) !s to yr + + ! to ha + TR_WDEP_CONV(J,N) = 1D8 / GET_AREA_CM2(J) + & * TR_WDEP_CONV(J,N) + + ENDDO + + ENDIF + + ENDDO + + ENDIF + + ENDIF + + IF ( LEQHAYR ) THEN + + ! convert from kg/s to eq/ha/yr + IF ( LFORCE_MASK ) THEN + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + DO J = 1, JJPAR + + !kg -> mole + TR_WDEP_CONV(J,N) = 1D0 + & / TRACER_MW_KG(N) + + IF ( IDTSO4 .EQ. N + & .OR. IDTSO2 .EQ. N + & .OR. IDTN2O5 .EQ. N) THEN + TR_WDEP_CONV(J,N) = TR_WDEP_CONV(J,N) + & * 2d0 + ENDIF + + ! s to yr + TR_WDEP_CONV(J,N) = 86400D0 * 365D0 + & * TR_WDEP_CONV(J,N) + + ! to ha + TR_WDEP_CONV(J,N) = 1D4 / ADJOINT_AREA_M2 + & * TR_WDEP_CONV(J,N) + + ENDDO + + ENDIF + + ENDDO + + ELSE + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + DO J = 1, JJPAR + + !convert to moles from kg + TR_WDEP_CONV(J,N) = 1D0 + & / TRACER_MW_KG(N) + + IF ( IDTSO4 .EQ. N + & .OR. IDTSO2 .EQ. N + & .OR. IDTN2O5 .EQ. N) THEN + TR_WDEP_CONV(J,N) = TR_WDEP_CONV(J,N) + & * 2d0 + ENDIF + + ! s to yr + TR_WDEP_CONV(J,N) = 86400D0 * 365D0 + & * TR_WDEP_CONV(J,N) + ! to ha + TR_WDEP_CONV(J,N) = 1D8 / GET_AREA_CM2(J) + & * TR_WDEP_CONV(J,N) + + ENDDO + + ENDIF + + ENDDO + + ENDIF + + ENDIF + + ENDIF + + 100 FORMAT('2 equivalents in ',a) + + ! return to calling program + END SUBROUTINE INIT_UNITS_DEP + +!------------------------------------------------------------------------------ + SUBROUTINE INIT_CF_REGION +! +!****************************************************************************** +! Subroutine INIT_CF_REGION assigns values to CF_REGION, which determines the +! 3D spatial domain over which to evaluation the cost function. +! +! NOTES: +! (1 ) Setting weight = 1 is equivalent to saying that the uncertainty in each +! observation is of order 1 / OBS^2. +! (2 ) Add OBS_THIS_SPECIES and OPT_THIS_SPECIES, both default FALSE. +! (dkh, 03/25/05) +! (3 ) Add OPT_THIS_EMS. (dkh, 03/29/05) +! (4 ) Replace RETURN with IFELSE so that safety catches at the end are always +! checked (dkh, 06/07/05) +! (5 ) Updated for v8 ajd (dkh, ks, mak, cs 06/12/09) +! (6 ) Add support for LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (7 ) Replaced WEIGHT with CF_REGION (dkh, 03/13/13) +!****************************************************************************** +! + ! Reference to f90 modules + USE DAO_MOD, ONLY : IS_LAND + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_AREA_M2 + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE LOGICAL_ADJ_MOD, ONLY : LICS + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_OBS + USE LOGICAL_ADJ_MOD, ONLY : LFORCE_MASK + USE LOGICAL_ADJ_MOD, ONLY : LFORCE_MASK_BPCH, LFORCE_MASK_NC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_MOD, ONLY : LRCPTR_MASK + USE TRACER_MOD, ONLY : N_TRACERS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CL + USE CRITICAL_LOAD_MOD,ONLY : GET_CL_EXCEEDENCE + ! add for reaction rates (tww, 05/15/12) + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + +# include "CMN_SIZE" ! Size params +# include "define_adj.h" ! the obs operators + + ! Local variables + LOGICAL :: AT_LEAST_ONE = .FALSE. + INTEGER :: I, J, L, N + REAL*8 :: MASK(IIPAR,JJPAR) + REAL*8 :: MASK_CL(IIPAR,JJPAR) + + !================================================================= + ! INIT_CF_REGION begins here! + !================================================================= + + WRITE(6,*) ' SET CF_REGION ' + + ! Quickly define the weight array for the FD case + IF ( LFDTEST ) THEN + + IF ( LFD_GLOB ) THEN + WRITE( 6, * ) 'USE OBSERVATIONS IN LFD' + CF_REGION(:,:,LFD) = 1d0 + + IF ( LADJ_FDEP ) CF_REGION(:,:,:) = 1D0 + + ELSEIF ( LFD_SPOT ) THEN + WRITE( 6, * ) 'USE OBSERVATIONS ONLY IN FINITE DIFF CELLS' + WRITE( 6, * ) ' (IFD, JFD, LFD, NFD) = ', IFD,JFD,LFD,NFD + CF_REGION(IFD,JFD,LFD) = 1d0 + + IF ( LCSPEC_OBS ) CF_REGION(IFD,JFD,:) = 1d0 + + ENDIF + + ! Reset defaults so that NFD overides observation menu (dkh, 02/11/11) + OBS_THIS_TRACER(:) = .FALSE. + OBS_THIS_TRACER(NFD) = .TRUE. + + IF ( LCSPEC_OBS ) THEN + OBS_THIS_SPECIES(:) = .FALSE. + OBS_THIS_SPECIES(NFD) = .TRUE. + ENDIF + + IF ( LADJ_EMS ) THEN + + ! Reset defaults so that EMSFD overides control variable menu (dkh, 02/11/11) + OPT_THIS_EMS(:) = .FALSE. + + OPT_THIS_EMS(EMSFD) = .TRUE. + + ! Add support for strat fluxes (hml, dkh, 02/14/12, adj32_025) + IF ( LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + + ! Reset defaults so that STRFD overides control variabel menu (hml, 08/11/11) + OPT_THIS_EMS(EMSFD) = .FALSE. + OPT_THIS_PROD(:) = .FALSE. + OPT_THIS_LOSS(:) = .FALSE. + + ! By default, test the adjoints for the LOSS terms. + !OPT_THIS_PROD(STRFD) = .TRUE. + OPT_THIS_LOSS(STRFD) = .TRUE. + + ENDIF + + ! Add support for reaction rates (tww, 05/15/12) + ! To make LADJ_RRATE as a default when EMS, STRAT, and RRATE are all T (hml, 06/08/13) + IF ( LADJ_RRATE ) THEN + + OPT_THIS_EMS(EMSFD) = .FALSE. + OPT_THIS_RATE(:) = .FALSE. + OPT_THIS_PROD(:) = .FALSE. + OPT_THIS_LOSS(:) = .FALSE. + + OPT_THIS_RATE(RATFD) = .TRUE. + + ENDIF + + + ELSEIF ( LICS ) THEN + + ! Reset defaults so that ICSFD overides control variabel menu (dkh, 02/11/11) + OPT_THIS_TRACER(:) = .FALSE. + + OPT_THIS_TRACER(ICSFD) = .TRUE. + + ENDIF + + ! Manually define things for other cases + + ! Spatial domain of cost function + ELSE + + IF ( LFORCE_MASK .OR. LADJ_CL .OR. LRCPTR_MASK ) THEN + + IF ( LADJ_CL ) THEN + CALL GET_CL_EXCEEDENCE( MASK ) + ELSEIF ( LRCPTR_MASK ) THEN + MASK = READ_MASK_HTAP() + CALL GET_CL_EXCEEDENCE( MASK_CL ) + ELSE + MASK_CL(:,:) = 1D0 + END IF + + IF ( LFORCE_MASK ) THEN + IF ( LFORCE_MASK_BPCH ) THEN + MASK = READ_MASK( FORCING_MASK_FILE ) + ELSEIF ( LFORCE_MASK_NC ) THEN + CALL READ_MASK_NC( MASK ) + ENDIF + ELSE + MASK(:,:) = 1D0 + ENDIF + + + IF ( LRCPTR_MASK ) MASK = READ_MASK_HTAP() + + CF_REGION(:,:,:) = 0d0 + + ! 2D mask defining cost function region + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Extend mask throughout the column + IF ( MASK(I,J) > 0d0 ) THEN + CF_REGION(I,J,:) = MASK(I,J)*MASK_CL(I,J) + ENDIF + + ENDDO + ENDDO + + ELSE + + CF_REGION(:,:,:) = 1d0 + + ENDIF + + ENDIF + + + + IF ( LADJ_FDEP .and. LFORCE_MASK) THEN + + ADJOINT_AREA_M2 = 0d0 + + DO J = 1, JJPAR + DO I = 1, IIPAR + ADJOINT_AREA_M2 = ADJOINT_AREA_M2 + & + GET_AREA_M2( J ) + & * CF_REGION(I,J,1) + ENDDO + ENDDO + + WRITE(*,*) 'ADJOINT AREA (M2)',ADJOINT_AREA_M2 + + ELSE + + ADJOINT_AREA_M2 = 0d0 + + ENDIF + +!! Some compilers won't do this loop in parallel (dkh, mak) +!!!$OMP PARALLEL DO +!!!$OMP+DEFAULT( SHARED ) +!!!$OMP+PRIVATE( I, J, L, N ) +! DO N = 1, N_TRACERS +! !! dkh debug -- this is really strange +! !print*, ' if i dont print something here i will crash ' +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! IF ( OBS_THIS_TRACER(N) ) THEN +!! & .and. IS_LAND(I,J) ! Only the land species +!! & .and. ( MOD( I, 2 ) == 0 ) ! Only in every other cell +!! & .and. L == 1 ! Only at the surface +!! & .and. J >= 10 ! Not in antarctica +!! & .and. I < 42 .and. I > 34 ! IN +!! & .and. J > 32 .and. J < 39 ! EUROPE +!! & .and. I > 18 .and. I < 23 ! IN +!! & .and. J > 30 .and. J < 35 ! Eastern US +!! & .and. I > 11 .and. I < 23 ! IN +!! & .and. J > 30 .and. J < 35 ! US +!! & .and. I > 58 .and. I < 63 ! IN +!! & .and. J > 30 .and. J < 34 ! Eastern China +!! & .and. J >= 32 .and. J <= 33 ! +!! & .and. I >= 20 .and. I <= 21 ! +!! & ) THEN +! +! WEIGHT(I,J,L,N) = 1d0 +! !if ( n == 1 ) print*, 'observe in ',i, j +! +! ELSE +! +! WEIGHT(I,J,L,N) = 0d0 +! +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +! ENDDO +!!!$OMP END PARALLEL DO +! +! ENDIF + + ! BUG FIX: Only check this if no real obs operators are turned on (dkh, 07/30/10) + ! Now support IMPROVE_BC_OC_OBS (yhmao, dkh, 01/16/12, adj32_013) + ! Now support MOPITT_V5_CO_OBS (zhej, dkh, 01/16/12, adj32_016) + ! Now support CH4 operators (kjw, dkh, 02/12/12, adj32_023) +#if !defined(MOPITT_V5_CO_OBS) && !defined(MOPITT_V6_CO_OBS) && !defined(AIRS_CO_OBS) && !defined(SCIA_BRE_CO_OBS) && !defined(TES_NH3_OBS)&& !defined(SCIA_DAL_SO2_OBS) && !defined(PM_ATTAINMENT) && !defined(IMPROVE_SO4_NIT_OBS) && !defined(CASTNET_NH4_OBS) && !defined(SOMO35_ATTAINMENT) && !defined(TES_O3_OBS)&& !defined(SCIA_KNMI_NO2_OBS) && !defined(SCIA_DAL_NO2_OBS) && !defined(GOSAT_CO2_OBS) && !defined(IMPROVE_BC_OC_OBS) && !defined(TES_CH4_OBS) && !defined(SCIA_CH4_OBS) && !defined(MEM_CH4_OBS) && !defined (LEO_CH4_OBS) && !defined(GEOCAPE_CH4_OBS) && !defined(TES_O3_IRK) && !defined( OMI_SO2_OBS ) && !defined( OMI_NO2_OBS ) + + ! Check to make sure that at least something is being observed somewhere + IF ( MAXVAL( CF_REGION(:,:,:) ) == 0d0 ) THEN + CALL ERROR_STOP( ' No observations! ', + & ' INIT_CF_REGION, adjoint_mod.f ') + ENDIF + + ! Check to make sure at least one species or emission is being optimized + DO N = 1, N_TRACERS + IF ( OPT_THIS_TRACER(N) ) THEN + AT_LEAST_ONE = .TRUE. + ENDIF + ENDDO + +!#endif + + ! added this (dkh, 10/17/06) + IF ( LADJ_EMS ) THEN + DO N = 1, NNEMS + IF ( OPT_THIS_EMS(N) ) THEN + AT_LEAST_ONE = .TRUE. + ENDIF + ENDDO + + ! added this (hml, 08/20/11, adj32_025) + IF ( LADJ_STRAT ) THEN + DO N = 1, NSTPL + ! prod and loss cannot be perturbed at the same time + IF ( OPT_THIS_PROD(N) .OR. OPT_THIS_LOSS(N) ) THEN + AT_LEAST_ONE = .TRUE. + ENDIF + ENDDO + ENDIF + + ! added this (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN + DO N = 1, NRRATES + IF ( OPT_THIS_RATE(N) ) THEN + AT_LEAST_ONE = .TRUE. + ENDIF + ENDDO + ENDIF + + + ENDIF + + ! Error stop if no species are optimized + IF ( .not. AT_LEAST_ONE ) THEN + CALL ERROR_STOP( ' No variables to optimize!', + & ' INIT_CF_REGION, adjoint_mod.f' ) + ENDIF + + ! move this to here to allow for sensitivity studies of LICS with obs operators + ! (dkh, 08/25/10) +#endif + + ! Return to calling program + END SUBROUTINE INIT_CF_REGION + +!----------------------------------------------------------------------------- + + FUNCTION GET_CF_REGION(I,J,L) RESULT( W ) +! +!****************************************************************************** +! Function GET_CF_REGION returns the value of the cost function weighting +! array, CF_WEIGHT. (dkh, 06/12/09) +! +! NOTES: +! (1 ) Replace WEIGHT with CF_REGION (dkh, 03/13/13) +! +!****************************************************************************** +! + ! Function value + REAL*8 :: W + + ! Function arguments + INTEGER :: I, J, L, N + + !================================================================= + ! GET_CF_REGION begins here! + !================================================================= + + W = CF_REGION(I,J,L) + + ! Return to calling program + + END FUNCTION GET_CF_REGION +!----------------------------------------------------------------------------- + + FUNCTION ITS_TIME_FOR_OBS() RESULT( FLAG ) +! +!****************************************************************************** +! Function ITS_TIME_FOR_OBS returns TRUE if it is time for and +! observation +! and false otherwise. (dkh, 8/31/04) +! +! NOTES: +! (1 ) Add the L_NO_FIRST_OBS flag to make optional inclusion of the +! first time step +! as an observation time step. dkh, 02/21/05 +! (2 ) Add support for L_YES_LAST_OBS flag to force an observation at +! the second to +! last dynamic time step (the first step of the backwd +! integration) +! (dkh, 03/07/05) +! (3 ) Reorder IFELSE structure so that now L_YES_LAST_OBS overides +! L_NO_FIRST_OBS +! if the simulation is only one TS_CHEM long, ensuring that an +! observation +! will be made in this case (dkh, 06/11/05). +! (4 ) Add support for CH4 (kjw, dkh, 02/12/12, adj32_023) +!****************************************************************************** +! + ! Reference to f90 modules + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST + USE TIME_MOD, ONLY : GET_ELAPSED_MIN + USE TIME_MOD, ONLY : GET_TIME_AHEAD + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM + + +# include "CMN_SIZE" ! Size params for CMN_ADJ + + ! Function value + LOGICAL :: FLAG + + ! Local variables + INTEGER :: DATE(2) + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! ITS_TIME_FOR_OBS begins here! + !================================================================= + + ! Now for FDTEST force FLAG to TRUE on the first attempt during + ! the adjoint integration and false otherwise (dkh, 06/24/09) + IF ( LFDTEST ) THEN + + ! BUG FIS: only force it to be TRUE on the first chemistry + ! time step. (dkh, 07/14/09) + !IF ( FIRST ) THEN + IF ( MOD( GET_ELAPSED_MIN(), GET_TS_CHEM() ) == 0 + & .and. FIRST ) THEN + + FLAG = .TRUE. + FIRST = .FALSE. + + ELSE + + FLAG = .FALSE. + + ENDIF + + ! Return to calling program + RETURN + + ELSE + + FLAG = ( MOD( GET_ELAPSED_MIN(), OBS_FREQ ) == 0 ) + + ENDIF + + ! Return to calling program + + END FUNCTION ITS_TIME_FOR_OBS + +!------------------------------------------------------------------------------ + + SUBROUTINE CALC_NUM_SAT + +# include "define_adj.h" + + SAT = 0 + + ! Now support MOPITT_V5_CO_OBS (zhej, dkh, 01/16/12, adj32_016) +#if defined (MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS) + SAT = 1 + !Print*, 'ONLY MOPITT OBS, sat is:', SAT +#endif + +#if defined (SCIA_BRE_CO_OBS) + SAT = 2 + !Print*, 'SCIA BRE OBS, sat is:', SAT +#endif + +#if defined (AIRS_CO_OBS) + SAT = 3 + !Print*, 'AIRS OBS, sat is:', SAT +#endif + + END SUBROUTINE CALC_NUM_SAT + +!------------------------------------------------------------------------------ + + SUBROUTINE SET_EMS_ORIG( I, J, K, VALUE ) +! +!****************************************************************************** +! Subroutine SET_EMS_ORIG writes a value to EMS_orig. (mak, bmy, 3/14/06) +! Now lump all emissions by getting rid of one dimension (mak, 1/19/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 2nd dimension of array +! (3 ) K (INTEGER) : Index for time step dimension of array max=MMSCL +! (5 ) VALUE (REAL* ) : Value to store in (I,J,K)th element of array +! +! NOTES: +!****************************************************************************** +! + !USE TIME_MOD, ONLY : GET_DAY, GET_HOUR + + ! Arguments + INTEGER, INTENT(IN) :: I, J, K + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_EMS_orig begins here! + !================================================================= + EMS_orig(I,J,K) = EMS_orig(I,J,K) + VALUE + + ! for hourly emissions saving +! EMS_orig(I,J,GET_DAY(), GET_HOUR()) = +! & EMS_orig(I,J,GET_DAY(), GET_HOUR()) + VALUE + + ! Return to calling program + END SUBROUTINE SET_EMS_ORIG + +!----------------------------------------------------------------------------- + + FUNCTION GET_EMS_ORIG( I, J, K ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_EMS_ORIG gets a value from EMS_orig. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) K (INTEGER) : Index of chem/ems time steps of the simulation +! (4 ) N (INTEGER) : Index of ems/source types to be optimized +! (5 ) VALUE (REAL*8 ) : Value to store in (I,J,K,N)th element of array +! +! NOTES: +!****************************************************************************** +! + !USE TIME_MOD, ONLY : GET_DAY, GET_HOUR + + ! Arguments + INTEGER, INTENT(IN) :: I, J, K + + ! Function value + REAL*8 :: VALUE + + !================================================================= + ! GET_EMS_orig begins here! + !================================================================= + VALUE = EMS_orig(I,J,K) + + ! Return to calling program + END FUNCTION GET_EMS_ORIG + +!----------------------------------------------------------------------------- + + + SUBROUTINE SET_FORCING( I, J, D, VALUE ) +! +!****************************************************************************** +! Subroutine SET_FORCING writes a value to FORCING. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_FORCING begins here! + !================================================================= + FORCING(I,J,D) = FORCING(I,J,D) + VALUE + + ! Return to calling program + END SUBROUTINE SET_FORCING + +!----------------------------------------------------------------------------- + + FUNCTION GET_FORCING( I, J, D ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_FORCING gets a value from FORCING. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_FORCING begins here! + !================================================================= + VALUE = FORCING(I,J,D) + + ! Return to calling program + END FUNCTION GET_FORCING + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_MOP_MOD_DIFF( I, J, D, VALUE ) +! +!****************************************************************************** +! Subroutine SET_MOP_MOD_DIFF writes a value to MOP_MOD_DIFF. +! (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_MOP_MOD_DIFF begins here! + !================================================================= + MOP_MOD_DIFF(I,J,D) = MOP_MOD_DIFF(I,J,D) + VALUE + + ! Return to calling program + END SUBROUTINE SET_MOP_MOD_DIFF + +!----------------------------------------------------------------------------- + + FUNCTION GET_MOP_MOD_DIFF( I, J, D ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_MOP_MOD_DIFF gets a value from MOP_MOD_DIFF. +! (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_MOP_MOD_DIFF begins here! + !================================================================= + VALUE = MOP_MOD_DIFF(I,J,D) + + ! Return to calling program + END FUNCTION GET_MOP_MOD_DIFF + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_MODEL_BIAS( I, J, D, N, VALUE ) +! +!****************************************************************************** +! Subroutine SET_MODEL_BIAS writes a value to MODEL_BIAS. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, N + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_MODEL_BIAS begins here! + !================================================================= + MODEL_BIAS(I,J,D,N) = MODEL_BIAS(I,J,D, N) + VALUE + + ! Return to calling program + END SUBROUTINE SET_MODEL_BIAS + +!----------------------------------------------------------------------------- + + FUNCTION GET_MODEL_BIAS( I, J, D,n ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_MODEL_BIAS gets a value from MODEL_BIAS. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, N + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_MODEL_BIAS begins here! + !================================================================= + VALUE = MODEL_BIAS(I,J,D, N) + + ! Return to calling program + END FUNCTION GET_MODEL_BIAS + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_MODEL( I, J, D, s, VALUE ) +! +!****************************************************************************** +! Subroutine SET_MODEL_BIAS writes a value to MODEL. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_MODEL begins here! + !================================================================= + MODEL(I,J,D,s) = VALUE + + ! Return to calling program + END SUBROUTINE SET_MODEL + +!----------------------------------------------------------------------------- + + FUNCTION GET_MODEL( I, J, D, s ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_MODEL gets a value from MODEL. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_MODEL begins here! + !================================================================= + VALUE = MODEL(I,J,D,s) + + ! Return to calling program + END FUNCTION GET_MODEL + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_OBS( I, J, D, s, VALUE ) +! +!****************************************************************************** +! Subroutine SET_OBS writes a value to OBS. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) s (INTEGER) : Index for SATELLITE DATASET NUMBER +! (5 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_OBS begins here! + !================================================================= + OBS(I,J,D,s) = VALUE + + ! Return to calling program + END SUBROUTINE SET_OBS + +!----------------------------------------------------------------------------- + + FUNCTION GET_OBS( I, J, D, s ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_OBS gets a value from OBS. (mak, bmy, 3/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for LAT +! (2 ) J (INTEGER) : Index for LON +! (3 ) D (INTEGER) : Index for DAY OF SIMULATION +! (4 ) s (INTEGER) : Index for SATELLITE DATASET NUMBER +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_OBS begins here! + !================================================================= + VALUE = OBS(I,J,D,s) + + ! Return to calling program + END FUNCTION GET_OBS + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_DOFS( I, J, D, s, VALUE ) +! +!****************************************************************************** +! Subroutine SET_DOFS writes a value to SAT_DOFS. (mak, bmy, 3/14/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! (4 ) VALUE (REAL*8 ) : Value to store in (I,J,D)th element of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + REAL*8, INTENT(IN) :: VALUE + + !================================================================= + ! SET_MODEL begins here! + !================================================================= + SAT_DOFS(I,J,D,s) = VALUE + + ! Return to calling program + END SUBROUTINE SET_DOFS + +!----------------------------------------------------------------------------- + + FUNCTION GET_DOFS( I, J, D, s ) RESULT( VALUE ) +! +!****************************************************************************** +! Subroutine GET_DOFS gets a value from SAT_DOFS. (mak, bmy, 3/14/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : Index for 1st dimension of array +! (2 ) J (INTEGER) : Index for 1st dimension of array +! (3 ) D (INTEGER) : Index for 1st dimension of array +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J, D, s + + ! Local variables + REAL*8 :: VALUE + + !================================================================= + ! GET_MODEL begins here! + !================================================================= + VALUE = SAT_DOFS(I,J,D,s) + + ! Return to calling program + END FUNCTION GET_DOFS + +!----------------------------------------------------------------------------- + + SUBROUTINE CHECK_STT_ADJ( LOCATION ) +! +!****************************************************************************** +! Subroutine CHECK_STT_ADJ checks the STT_ADJ array for +! NaN values, or Infinity values. If any of these are found, the code +! will stop with an error message. (bmy, 3/8/01, 10/3/05) +! (dkh, ks, mak, cs 06/12/09) +! +! Arguments as Input: +! ============================================================================ +! (1) LOCATION (CHARACTER) : String describing location of error in code +! +! NOTES: +! (1 ) Based on CHECK_STT from the forward model. +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE ERROR_MOD, ONLY : IT_IS_NAN + USE ERROR_MOD, ONLY : IT_IS_FINITE + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: LOCATION + + ! Local variables + LOGICAL :: LNAN, LINF + INTEGER :: I, J, L, N + + !================================================================= + ! CHECK_STT_ADJ begins here! + !================================================================= + + ! Initialize + LNAN = .FALSE. + LINF = .FALSE. + + ! Loop over grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + !--------------------------- + ! Check for NaN's + !--------------------------- + IF ( IT_IS_NAN( STT_ADJ(I,J,L,N) ) ) THEN +!$OMP CRITICAL + LNAN = .TRUE. + WRITE( 6, 100 ) I, J, L, N, STT_ADJ(I,J,L,N) +!$OMP END CRITICAL + + !---------------------------- + ! Check STT's for Infinities + !---------------------------- + ELSE IF ( .not. IT_IS_FINITE( STT_ADJ(I,J,L,N) ) ) THEN +!$OMP CRITICAL + LINF = .TRUE. + WRITE( 6, 100 ) I, J, L, N, STT_ADJ(I,J,L,N) +!$OMP END CRITICAL + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Stop the run if any of LNAN, LINF is true + !================================================================= + IF ( LNAN .or. LINF ) THEN + WRITE( 6, 120 ) TRIM( LOCATION ) + CALL GEOS_CHEM_STOP + ENDIF + + !================================================================= + ! FORMAT statements + !================================================================= + 100 FORMAT( 'CHECK_STT_ADJ: STT_ADJ(',i3,',',i3,',',i3,',',i3,') = ', + & f13.6 ) + 120 FORMAT( 'CHECK_STT_ADJ: STOP at ', a ) + + ! Return to calling program + END SUBROUTINE CHECK_STT_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_STT_05x0666_ADJ( LOCATION ) + +!****************************************************************************** +! +! Subroutine CHECK\_STT\_05x0666_ADJ checks the STT tracer array for +! NaN values, or Infinity values. If any of these are found, +! the STT array will be set to a specified value. +! +! Arguments as Input: +! ============================================================================ +! (1) LOCATION (CHARACTER) : String describing location of error in code +! +! NOTES: +! 23 May 2013 - Y. Davila - Initial version based on CHECK_STT_ADJ and updates +! for nested grid by Yuxuan Wang. +!****************************************************************************** + + ! References to F90 modules + USE ERROR_MOD, ONLY : IT_IS_NAN + USE ERROR_MOD, ONLY : IT_IS_FINITE + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: LOCATION + + + + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! CHECK_STT_05x0666_ADJ begins here! + !================================================================= + + ! Loop over grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + +! In CHECK_STT_ADJ we don't check for negatives values (yd 5/23/2013) +! !--------------------------- +! ! Check for Negatives +! !--------------------------- +! IF ( STT(I,J,L,N) < 0d0 ) THEN +!!$OMP CRITICAL +! WRITE( 6, 100 ) I, J, L, N, STT_ADJ(I,J,L,N) +! PRINT*, 'Neg STT_ADJ ' // TRIM( LOCATION ) // +! & '. SET STT_ADJ TO BE ZERO.' +! STT_ADJ(I,J,L,N) = 0d0 +!!$OMP END CRITICAL + + !--------------------------- + ! Check for NaN's + !--------------------------- + IF ( IT_IS_NAN( STT_ADJ(I,J,L,N) ) ) THEN +!$OMP CRITICAL + WRITE( 6, 100 ) I, J, L, N, STT_ADJ(I,J,L,N) + PRINT*, 'NaN STT_ADJ ' // TRIM( LOCATION ) // + & '. SET STT_ADJ TO BE LOWER LEVEL.' + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L-1,N) +!$OMP END CRITICAL + + !---------------------------- + ! Check STT's for Infinities + !---------------------------- + ELSE IF ( .not. IT_IS_FINITE( STT_ADJ(I,J,L,N) ) ) THEN +!$OMP CRITICAL + WRITE( 6, 100 ) I, J, L, N, STT_ADJ(I,J,L,N) + PRINT*, 'Inf STT_ADJ ' // TRIM( LOCATION ) // + & '. SET STT_ADJ TO BE LOWER LEVEL.' + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L-1,N) +!$OMP END CRITICAL + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + 100 FORMAT( ' STT_ADJ(',i3,',',i3,',',i3,',',i3,') = ', f13.6 ) + + END SUBROUTINE CHECK_STT_05x0666_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE EXPAND_NAME( FILENAME, N_ITRN ) +! +!****************************************************************************** +! Subroutine EXPAND_DATE replaces "NN" token within +! a filename string with the actual values. (bmy, 6/27/02, 12/2/03) +! (dkh, 9/22/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Filename with tokens to replace +! (2 ) N_ITRN (INTEGER ) : Current iteration number +! +! +! Arguments as Output: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Modified filename +! +! NOTES: +! (1 ) Based on EXPAND_DATE +! +!****************************************************************************** +! + ! References to F90 modules + USE CHARPAK_MOD, ONLY : STRREPL + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "define.h" + + ! Arguments + CHARACTER(LEN=*), INTENT(INOUT) :: FILENAME + INTEGER, INTENT(IN) :: N_ITRN + + ! Local variables + CHARACTER(LEN=2) :: NN_STR + + !================================================================= + ! EXPAND_NAME begins here! + !================================================================= + +#if defined( LINUX_PGI ) + + ! Use ENCODE statement for PGI/Linux (bmy, 9/29/03) + ENCODE( 2, '(i2.2)', NN_STR ) N_ITRN + +#else + + ! For other platforms, use an F90 internal write (bmy, 9/29/03) + WRITE( NN_STR, '(i2.2)' ) N_ITRN + +#endif + + ! Replace NN token w/ actual value + CALL STRREPL( FILENAME, 'NN', NN_STR ) + + + ! Return to calling program + END SUBROUTINE EXPAND_NAME + +!----------------------------------------------------------------------------- + + FUNCTION GET_SCALE_GROUP( ) RESULT( CURRENT_GROUP ) +! +!******************************************************************************** +! Subroutine GET_SCALE_GROUP determines which predifined scaling index corresponds +! to the current time and location (dkh, 12/02/04) +! +! NOTES +! (1 ) CURRENT_GROUP is currently only a function of TAU +! (2 ) Get rid of I,J as argument. (dkh, 03/28/05) +! +!******************************************************************************** + + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD,ONLY : LICS + +# include "CMN_SIZE" ! Size stuff + + ! Arguments + INTEGER :: CURRENT_GROUP + + ! Local Variables + + !============================================================ + ! GET_SCALE_GROUP begins here! + !============================================================ + + ! Currently there is no spatial grouping + IF ( LICS ) THEN + print*, ' SET MMSLC = 1 for LICS ' + CURRENT_GROUP = 1 + RETURN + ENDIF + + ! Determine temporal grouping + IF ( MMSCL == 1 ) THEN + CURRENT_GROUP = 1 + RETURN + ELSE + print*, ' M = ', MMSCL + CALL ERROR_STOP(' GET_SCALE_GROUP', 'adj_arrays_mod.f') + ENDIF + + END FUNCTION GET_SCALE_GROUP + +!----------------------------------------------------------------------------------------- + + SUBROUTINE INIT_CSPEC_ADJ( ) +! +!****************************************************************************** +! Subroutine INIT_CSPEC_ADJ initializes arrays for the adjoint that depend +! uppon arrays from SMVGEAR. (dkh, 02/10/11) +! +! NOTES: +! (1 ) Now move error checking for the TES_O3_OBS simulation here +! (nb, dkh, 01/06/12, adj32_011) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE ERROR_MOD, ONLY : ERROR_STOP + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + + +# include "CMN_SIZE" +# include "comode.h" + + ! Local variables + INTEGER :: N + INTEGER :: AS + INTEGER :: JJ + INTEGER :: NK + LOGICAL :: FOUND + + !================================================================= + ! INIT_CSPEC_ADJ begins here! + !================================================================= + + + ! First allocate IDCSPEC_ADJ to be the number of obs from CSPEC + ALLOCATE( IDCSPEC_ADJ( NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'IDCSPEC_ADJ' ) + IDCSPEC_ADJ = 0 + + + ! allocate reverse mapping + ALLOCATE( ID2C( IGAS ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID2C' ) + ID2C = 0d0 + + ! Now we can allocate these sub-arrays of CSPEC as well + ALLOCATE( CSPEC_AFTER_CHEM( ITLOOP, NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CSPEC_AFTER_CHEM' ) + CSPEC_AFTER_CHEM = 0d0 + + + ALLOCATE( CSPEC_AFTER_CHEM_ADJ( ITLOOP, NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CSPEC_AFTER_CHEM_ADJ' ) + CSPEC_AFTER_CHEM_ADJ = 0d0 + + + DO N = 1, NOBS_CSPEC + + ! get species id number + IDCSPEC_ADJ(N) = GET_SPEC( CNAME(N) ) + + ! save reverse mapping + ID2C(IDCSPEC_ADJ(N)) = N + + ENDDO + + ! Now check that we can run TES_O3_OBS here (nb, dkh, 01/06/12, adj32_002) +#if defined ( TES_O3_OBS ) || defined( TES_O3_IRK ) + ! Since the O3 obs operators will pass adjoints back + ! to CSPEC via CSPEC_AFTER_CHEM_ADJ, we need to make sure that + ! these species are listed as observed species + FOUND = .FALSE. + DO N = 1, NOBS_CSPEC + + IF ( TRIM( NAMEGAS( IDCSPEC_ADJ(N) ) ) == 'O3' ) THEN + FOUND = .TRUE. + ENDIF + + ENDDO + IF ( .not. FOUND ) THEN + + CALL ERROR_STOP( ' Need to list O3 as observed species', + & ' adj_arrays_mod ' ) + ENDIF +#endif + + + ! Return to calling program + END SUBROUTINE INIT_CSPEC_ADJ + +!----------------------------------------------------------------------------------------- + + SUBROUTINE INIT_ADJ_STRAT + +!***************************************************************************** +! Subroutine INIT_ADJ_STRAT initializes stratohspheric adj prod & loss names +! and IDs (hml, dkh, 02/14/12, adj32_025) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" +# include "define_adj.h" + + ! Local variables + INTEGER :: AS + + !================================================================= + ! Allocate arrays + !================================================================= + + ALLOCATE( ID_PROD( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_PROD' ) + ID_PROD = 0 + + ALLOCATE( PROD_NAME( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_NAME' ) + PROD_NAME = '' + + ALLOCATE( OPT_THIS_PROD( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OPT_THIS_PROD' ) + OPT_THIS_PROD = .FALSE. + + ALLOCATE( REG_PARAM_PROD( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REG_PARAM_PROD' ) + REG_PARAM_PROD = 1d0 + + ALLOCATE( ID_LOSS( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_LOSS' ) + ID_LOSS = 0 + + ALLOCATE( LOSS_NAME( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_NAME' ) + LOSS_NAME = '' + + ALLOCATE( OPT_THIS_LOSS( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OPT_THIS_LOSS' ) + OPT_THIS_LOSS = .FALSE. + + ALLOCATE( REG_PARAM_LOSS( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REG_PARAM_LOSS' ) + REG_PARAM_LOSS = 1d0 + + ALLOCATE( PROD_ERROR( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_ERROR' ) + PROD_ERROR = 1d0 +#if defined ( LOG_OPT ) + PROD_ERROR = EXP(1d0) +#endif + + ALLOCATE( LOSS_ERROR( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_ERROR' ) + LOSS_ERROR = 1d0 +#if defined ( LOG_OPT ) + LOSS_ERROR = EXP(1d0) +#endif + + ALLOCATE( PROD_SF_DEFAULT( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RPOD_SF_DEFAULT' ) + PROD_SF_DEFAULT = 1d0 + + ALLOCATE( LOSS_SF_DEFAULT( NSTPL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_SF_DEFAULT' ) + LOSS_SF_DEFAULT = 1d0 + + ! Return to calling program + END SUBROUTINE INIT_ADJ_STRAT + +!----------------------------------------------------------------------------- + + FUNCTION GET_SPEC( SPEC_NAME ) RESULT ( I ) +! +!****************************************************************************** +! Function GET_SPEC return the index of the CSPEC species array given +! a species name (dkh, 02/09/11) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) SPEC_NAME (Character) : Species name +! +! Result as Output: +! ============================================================================ +! (1 ) I (INTEGER) : Index of this specis in CSPEC array +! +! NOTES: +! (1 ) Needs to match SETTRACE in tracerid_mod +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NSPEC, NAMEGAS + + ! Function arguemtn + CHARACTER(LEN=14) :: SPEC_NAME + + ! Function return value + INTEGER :: I + + ! Local variables + INTEGER :: N + LOGICAL :: FOUND + + !================================================================= + ! GET_SPEC begins here! + !================================================================= + + FOUND = .FALSE. + + DO N = 1, NSPEC(NCSURBAN) + IF ( TRIM(NAMEGAS(N)) == TRIM( SPEC_NAME ) ) THEN + I = N + FOUND = .TRUE. + WRITE(*,*) 'SPEC_NAME',TRIM(NAMEGAS(N)) + ENDIF + ENDDO + + IF ( .not. FOUND ) THEN + CALL ERROR_STOP('name not found in GET_SPEC', + & 'adj_arrays_mod.f' ) + ENDIF + + ! Return to calling program + END FUNCTION GET_SPEC + +!------------------------------------------------------------------------------ + + FUNCTION DO_CHK_FILE() RESULT( DO_CHECKPOINT ) +! +!****************************************************************************** +! Function DO_CHK_FILE returns TRUE if it *.chk.* files are needed +! and false otherwise. (yd, 10/29/12) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST, LADJ + + ! Function value + LOGICAL :: DO_CHECKPOINT + + !================================================================= + ! DO_CHK_FILE begins here! + !================================================================= + + IF ( N_CALC > 0 .and. LADJ .and. + & ( .not. (LFDTEST .and. N_CALC > 1 ))) THEN + DO_CHECKPOINT = .TRUE. + ELSE + DO_CHECKPOINT = .FALSE. + ENDIF + + ! Return to calling program + + END FUNCTION DO_CHK_FILE + +!------------------------------------------------------------------------------ + FUNCTION READ_MASK( FILENAME ) RESULT ( MASK ) + +!****************************************************************************** +! Function READ_MASK reads the mask from disk for user defined +! FORCING_MASK_FILE in input.gcadj +! (dkh, 10/11/12) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to F90 modules + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=255) :: FILENAME + REAL*4 :: MASK(IGLOB,JGLOB) + + ! Local variables + REAL*4 :: ARRAY(IGLOB,JGLOB,1) + REAL*8 :: XTAU + + !================================================================= + ! READ_MASK begins here! + !================================================================= + + ! File name + + ! binary mask + !FILENAME = TRIM( REGION ) // '.bpch' + !! Get TAU0 for Jan 1985 + XTAU = GET_TAU0( 1, 1, 1985 ) + + ! Get TAU0 for Jan 1985 + !XTAU = GET_TAU0( 1, 1, 2006 ) + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_MASK: Reading ', a ) + + ! Mask is stored as 2 + !CALL READ_BPCH2( FILENAME, 'LANDMAP', 1, + CALL READ_BPCH2( FILENAME, 'LANDMAP', 2, + & XTAU, IGLOB, JGLOB, + & 1, ARRAY, QUIET=.TRUE. ) + + MASK = ARRAY(:,:,1) + + ! ensure range + IF ( MAXVAL(MASK) > 1d0 .or. MINVAL(MASK) < 0d0 ) THEN + CALL ERROR_STOP(' bad mask in READ_MASK', 'adj_arrays_mod.f') + ENDIF + + + ! Return to calling program + END FUNCTION READ_MASK + +!------------------------------------------------------------------------------ + FUNCTION READ_MASK_HTAP( ) RESULT ( MASK ) + +!****************************************************************************** +! Function READ_MASK_HTAP reads the receptor mask from disk. +! (yd, 10/12/13) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE REGRID_A2A_MOD, ONLY : DO_REGRID_DKH + USE HTAP_MOD, ONLY : LOCN20, LOCN21, LOCN22, LOCN23, LOCN24 + USE HTAP_MOD, ONLY : LOCN25, LOCN26, LOCN27, LOCN28 + USE HTAP_MOD, ONLY : LNAM31, LNAM32, LNAM33, LNAM34, LNAM35 + USE HTAP_MOD, ONLY : LNAM36, LEUR41, LEUR42, LEUR43, LEUR44 + USE HTAP_MOD, ONLY : LSAS51, LSAS52, LSAS53, LEAS61, LEAS62 + USE HTAP_MOD, ONLY : LEAS63, LEAS64, LEAS65, LEAS66, LSEA71 + USE HTAP_MOD, ONLY : LSEA72, LPAN81, LPAN82, LPAN83, LNAF91 + USE HTAP_MOD, ONLY : LNAF92, LNAF93, LMDE112 + USE HTAP_MOD, ONLY : LSAF101, LSAF102, LSAF103, LMDE111 + USE HTAP_MOD, ONLY : LMDE113, LMCA121, LMCA122, LMCA123 + USE HTAP_MOD, ONLY : LSAM131, LSAM132, LSAM133, LSAM134 + USE HTAP_MOD, ONLY : LRBU142, LRBU143, LCAS151, LNPO150 + USE HTAP_MOD, ONLY : LSPO161, LSPO160, LRBU141, LMCA124 + USE m_netcdf_io_open + USE m_netcdf_io_read + USE m_netcdf_io_readattr + USE m_netcdf_io_close + USE m_netcdf_io_get_dimlen + +# include "CMN_SIZE" ! Size parameters +# include "define.h" ! Grid Size + + ! Arguments + REAL*8 :: MASK(IGLOB,JGLOB) + + ! Local variables + INTEGER, PARAMETER :: I01x01 = 3600, J01x01 = 1800 + INTEGER :: I, J, II, JJ, fId1 + REAL*8 :: ARRAY(I01x01,J01x01) + REAL*8 :: TMP_ARRAY(I01x01,J01x01) + CHARACTER(LEN=255) :: LLFILENAME, FILENAME + + + !================================================================= + ! READ_MASK_HTAP begins here! + !================================================================= + + ! File name + ! File with lat/lon edges for regridding + LLFILENAME = TRIM( DATA_DIR_1x1) // + & 'MAP_A2A_Regrid_201203/MAP_HTAP.nc' + + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'HTAP/MASKS/HTAP_Phase2_tier2NC01x01.nc' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_MASK: Reading ', a ) + + ! Set Mask + MASK = 0d0 + ARRAY = 0d0 + + ! Open model_ready mask from netCDF file + CALL Ncop_Rd(fId1, TRIM( FILENAME )) + + ! Read model_ready data from netCDF file + CALL NcRd(TMP_ARRAY, fId1, 'region_code', + &(/ 1, 1 /), !Start + &(/ I01x01, J01x01/) ) !Count lon/lat + + ! Close netCDF file + CALL NcCl( fId1 ) + + ! Apply Source Mask Scaling + DO I = 1, I01x01 + + ! I on mask is -180->180 , but I on GEOS_01x01 is 0->360 + IF (I .LT. 1800 ) THEN + II = I + 1800 + ELSE IF (I .GE. 1801) THEN + II = I - 1800 + ENDIF + + ! J on mask is N->S, but I on GEOS_01x01 is S->N + JJ = J01x01 + + DO J = 1, J01x01 + + IF ( LOCN20 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 20d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN21 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 21d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN22 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 22d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN23 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 23d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN24 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 24d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN25 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 25d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN26 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 26d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN27 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 27d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LOCN28 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 28d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM31 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 31d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM32 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 32d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM33 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 33d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM34 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 34d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM35 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 35d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAM36 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 36d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEUR41 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 41d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEUR42 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 42d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEUR43 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 43d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEUR44 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 44d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAS51 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 51d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAS52 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 52d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAS53 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 53d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS61 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 61d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS62 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 62d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS63 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 63d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS64 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 64d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS65 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 65d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LEAS66 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 66d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSEA71 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 71d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSEA72 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 72d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LPAN81 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 81d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LPAN82 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 82d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LPAN83 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 83d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAF91 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 91d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAF92 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 92d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNAF93 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 93d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAF101 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 101d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAF102 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 102d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAF103 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 103d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMDE111 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 111d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMDE112 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 112d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMDE113 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 113d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMCA121 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 121d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMCA122 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 122d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMCA123 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 123d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LMCA124 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 124d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAM131 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 131d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAM132 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 132d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAM133 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 133d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSAM134 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 134d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LRBU141 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 141d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LRBU142 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 142d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LRBU143 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 143d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LCAS151 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 151d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LNPO150 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 150d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSPO160 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 160d0 ) ARRAY(I,J) = 1d0 + ENDIF + + IF ( LSPO161 ) THEN + IF ( TMP_ARRAY(II,JJ) .EQ. 161d0 ) ARRAY(I,J) = 1d0 + ENDIF + + JJ = JJ - 1 + ENDDO + ENDDO + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, + & ARRAY, MASK, IS_MASS=1, + & netCDF=.TRUE.) + +#if defined ( GRID4x5) + MASK = MASK / 2000d0 +#elif defined ( GRID2x25) + MASK = MASK / 500d0 +#elif defined ( GRID1x125) + MASK = MASK / 125d0 +#elif defined ( GRID1x1) + MASK = MASK / 10d0 +#endif + + ! ensure range +! IF ( MAXVAL(MASK) > 1d0 .or. MINVAL(MASK) < 0d0 ) THEN +! CALL ERROR_STOP(' bad mask in READ_MASK_HTAP', +! & 'adj_arrays_mod.f') +! ENDIF + + + ! Return to calling program + END FUNCTION READ_MASK_HTAP + +!----------------------------------------------------------------------------------------- + + SUBROUTINE READ_MASK_NC ( MASK ) + +!****************************************************************************** +! Function READ_MASK_NC reads the mask from disk for user defined +! FORCING_MASK_FILE_NC in input.gcadj +! (fp 2013) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + USE m_netcdf_io_open + USE m_netcdf_io_read + USE m_netcdf_io_readattr + USE m_netcdf_io_close + USE m_netcdf_io_get_dimlen + +# include "CMN_SIZE" ! Size parameters +# include "netcdf.inc" + + ! Arguments + REAL*4 :: MASK_TEMP(IGLOB,JGLOB) + REAL*8, INTENT(OUT):: MASK(IGLOB,JGLOB) + CHARACTER*255 :: VARNAME + + ! Local variables + INTEGER :: FID, N + + !================================================================= + ! READ_MASK_NC begins here! + !================================================================= + + ! open file + CALL Ncop_Rd(FID, TRIM(FORCING_MASK_FILE_NC) ) + + MASK = 0d0 + + DO N = 1, NB_MASK_VAR + + VARNAME = FORCING_MASK_VARIABLE(N) + + ! Echo info + WRITE( 6, 100 ) TRIM( FORCING_MASK_FILE_NC ), TRIM( VARNAME ) + + CALL NcRd( MASK_TEMP, FID, TRIM( VARNAME ), + & (/ 1, 1 /), + & (/ IGLOB, JGLOB /) ) + + MASK = MASK + MASK_TEMP + + ENDDO + + !with multiple variables, I don't think we should require mask to be <=1 + !so just force it for now (fp) + + IF ( MAXVAL(MASK) .gt. 1d0 .and. NB_MASK_VAR .GT. 1 ) THEN + + WHERE( MASK .GT. 1D0) + MASK = 1D0 + END WHERE + + WRITE(*,*) 'Force cumulative mask to be <=1' + + ENDIF + + + 100 FORMAT( ' - READ_MASK: Reading ', a , 1x, a) + + ! ensure range + IF ( MAXVAL(MASK) > 1d0 .or. MINVAL(MASK) < 0d0 ) THEN + CALL ERROR_STOP(' bad mask in READ_MASK_NC', + & 'adj_arrays_mod.f') + ENDIF + + + ! Return to calling program + END SUBROUTINE READ_MASK_NC + +!----------------------------------------------------------------------------------------- + + SUBROUTINE CLEANUP_ADJ_ARRAYS + + !================================================================= + ! Subroutine CLEANUP_ADJ_ARRAYS deallocates arrays + !================================================================= + IF ( ALLOCATED( FORCING ) ) DEALLOCATE( FORCING ) + IF ( ALLOCATED( SHIPO3DEP_ADJ ) ) DEALLOCATE( SHIPO3DEP_ADJ ) + IF ( ALLOCATED( MOP_MOD_DIFF ) ) DEALLOCATE( MOP_MOD_DIFF ) + IF ( ALLOCATED( MODEL_BIAS ) ) DEALLOCATE( MODEL_BIAS ) + IF ( ALLOCATED( MODEL ) ) DEALLOCATE( MODEL ) + IF ( ALLOCATED( SAT_DOFS ) ) DEALLOCATE( SAT_DOFS ) + IF ( ALLOCATED( OBS ) ) DEALLOCATE( OBS ) + IF ( ALLOCATED( COST_ARRAY ) ) DEALLOCATE( COST_ARRAY ) + IF ( ALLOCATED( OBS_COUNT ) ) DEALLOCATE( OBS_COUNT ) + IF ( ALLOCATED( OBS_STT ) ) DEALLOCATE( OBS_STT ) + IF ( ALLOCATED( STT_ADJ ) ) DEALLOCATE( STT_ADJ ) + IF ( ALLOCATED( STT_ORIG ) ) DEALLOCATE( STT_ORIG ) + IF ( ALLOCATED( EMS_orig ) ) DEALLOCATE( EMS_orig ) + IF ( ALLOCATED( CF_REGION ) ) DEALLOCATE( CF_REGION ) + IF ( ALLOCATED( COST_FUNC_SAV ) ) DEALLOCATE( COST_FUNC_SAV ) + IF ( ALLOCATED( ICS_SF ) ) DEALLOCATE( ICS_SF ) + IF ( ALLOCATED( ICS_SF0 ) ) DEALLOCATE( ICS_SF0 ) + IF ( ALLOCATED( EMS_SF ) ) DEALLOCATE( EMS_SF ) + IF ( ALLOCATED( EMS_SF0 ) ) DEALLOCATE( EMS_SF0 ) + IF ( ALLOCATED( REG_PARAM_EMS ) ) DEALLOCATE( REG_PARAM_EMS ) + IF ( ALLOCATED( REG_PARAM_ICS ) ) DEALLOCATE( REG_PARAM_ICS ) + IF ( ALLOCATED( ID_ADEMS ) ) DEALLOCATE( ID_ADEMS ) + IF ( ALLOCATED( OPT_THIS_TRACER ) ) DEALLOCATE( OPT_THIS_TRACER ) + IF ( ALLOCATED( OBS_THIS_SPECIES) ) DEALLOCATE( OBS_THIS_SPECIES ) + IF ( ALLOCATED( OBS_THIS_TRACER ) ) DEALLOCATE( OBS_THIS_TRACER ) + IF ( ALLOCATED( OPT_THIS_EMS ) ) DEALLOCATE( OPT_THIS_EMS ) + IF ( ALLOCATED( REMIS_ADJ ) ) DEALLOCATE( REMIS_ADJ ) + IF ( ALLOCATED( DEPSAV_ADJ ) ) DEALLOCATE( DEPSAV_ADJ ) + IF ( ALLOCATED( EMS_SF_DEFAULT ) ) DEALLOCATE( EMS_SF_DEFAULT ) + IF ( ALLOCATED( ICS_SF_DEFAULT ) ) DEALLOCATE( ICS_SF_DEFAULT ) + IF ( ALLOCATED( IDCSPEC_ADJ ) ) DEALLOCATE( IDCSPEC_ADJ ) + IF ( ALLOCATED( ID2C ) ) DEALLOCATE( ID2C ) + IF ( ALLOCATED( EMS_ERROR ) ) DEALLOCATE( EMS_ERROR ) + IF ( ALLOCATED( COV_ERROR_LX ) ) DEALLOCATE( COV_ERROR_LX ) + IF ( ALLOCATED( COV_ERROR_LY ) ) DEALLOCATE( COV_ERROR_LY ) + IF ( ALLOCATED( ICS_ERROR ) ) DEALLOCATE( ICS_ERROR ) + IF ( ALLOCATED( CNAME ) ) DEALLOCATE( CNAME ) + IF ( ALLOCATED( EMS_SF_ADJ ) ) DEALLOCATE( EMS_SF_ADJ ) + IF ( ALLOCATED( TEMP2 ) ) DEALLOCATE( TEMP2 ) + IF ( ALLOCATED( EMS_ADJ ) ) DEALLOCATE( EMS_ADJ ) + IF ( ALLOCATED( PROD_SF ) ) DEALLOCATE( PROD_SF ) + IF ( ALLOCATED( PROD_SF_ADJ ) ) DEALLOCATE( PROD_SF_ADJ ) + IF ( ALLOCATED( PROD_SF_DEFAULT ) ) DEALLOCATE( PROD_SF_DEFAULT ) + IF ( ALLOCATED( LOSS_SF ) ) DEALLOCATE( LOSS_SF ) + IF ( ALLOCATED( LOSS_SF_ADJ ) ) DEALLOCATE( LOSS_SF_ADJ ) + IF ( ALLOCATED( LOSS_SF_DEFAULT ) ) DEALLOCATE( LOSS_SF_DEFAULT ) + IF ( ALLOCATED( OPT_THIS_PROD ) ) DEALLOCATE( OPT_THIS_PROD ) + IF ( ALLOCATED( OPT_THIS_LOSS ) ) DEALLOCATE( OPT_THIS_LOSS ) + IF ( ALLOCATED( PROD_SF0 ) ) DEALLOCATE( PROD_SF0 ) + IF ( ALLOCATED( LOSS_SF0 ) ) DEALLOCATE( LOSS_SF0 ) + IF ( ALLOCATED( P_ADJ ) ) DEALLOCATE( P_ADJ ) + IF ( ALLOCATED( k_ADJ ) ) DEALLOCATE( k_ADJ ) + IF ( ALLOCATED( VAR_FD ) ) DEALLOCATE( VAR_FD ) + IF ( ALLOCATED( RCONST_FD ) ) DEALLOCATE( RCONST_FD ) + IF ( ALLOCATED( RATE_SF_ADJ ) ) DEALLOCATE( RATE_SF_ADJ ) + IF ( ALLOCATED( OPT_THIS_RATE ) ) DEALLOCATE( OPT_THIS_RATE ) + IF ( ALLOCATED( RATE_SF_DEFAULT ) ) DEALLOCATE( RATE_SF_DEFAULT ) + IF ( ALLOCATED( REG_PARAM_RATE ) ) DEALLOCATE( REG_PARAM_RATE ) + IF ( ALLOCATED( RATE_ERROR ) ) DEALLOCATE( RATE_ERROR ) + IF ( ALLOCATED( RATE_SF ) ) DEALLOCATE( RATE_SF ) + IF ( ALLOCATED( RATE_SF0 ) ) DEALLOCATE( RATE_SF0 ) + IF ( ALLOCATED( NHX_ADJ_FORCE ) ) DEALLOCATE( NHX_ADJ_FORCE ) + IF ( ALLOCATED( TR_DDEP_CONV )) DEALLOCATE( TR_DDEP_CONV ) + IF ( ALLOCATED( CS_DDEP_CONV )) DEALLOCATE( CS_DDEP_CONV ) + IF ( ALLOCATED( TR_WDEP_CONV )) DEALLOCATE( TR_WDEP_CONV ) + + ! Return to calling program + END SUBROUTINE CLEANUP_ADJ_ARRAYS + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE ADJ_ARRAYS_MOD diff --git a/code/adjoint/calcrate_adj.f b/code/adjoint/calcrate_adj.f new file mode 100644 index 0000000..a8f5ff2 --- /dev/null +++ b/code/adjoint/calcrate_adj.f @@ -0,0 +1,423 @@ +! $Id: calcrate_adj.f,v 1.1 2010/04/01 07:09:43 daven Exp $ +! SUBROUTINE CALCRATE( SUNCOS ) + SUBROUTINE CALCRATE_ADJ(RRATE_ADJ,IX,IY,IZ) + +! +!****************************************************************************** +! Subroutine CALCRATE_ADJ basically just transfers adjoints of emissions and +! deposition rates from the RRATE_ADJ array to more specific arrays. This +! is only for species whose emission and/or deposition is handled within the +! fullchemistry mechanims (such as NOx, but not SOx). (dkh, 06/05/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) RRATE_ADJ (REAK*8(:)) : Adjoint of emission and deposition rates +! (2-4) IX, IY, IZ (INTEGER) : 3-D array location [unit] +! +! Module variable as Input: +! ============================================================================ +! +! Module variable as Output: +! ============================================================================ +! (1 ) ADJ_REMIS (REAK*8(:,:)) : Adjoint of emission rates +! (2 ) ADJ_DEPSAV (REAK*8(:,:,:)) : Adjoint of deposition rates +! (3 ) ADJ_TAREA (REAK*8(:,:)) : Adjoint of areosol area +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 03/30/10) +! +!****************************************************************************** +! + ! Reference to f90 modules + USE COMODE_MOD, ONLY : ABSHUM, AIRDENS, ERADIUS, T3, TAREA + USE COMODE_MOD, ONLY : JLOP + USE DRYDEP_MOD, ONLY : NUMDEP, DEPNAME, SHIPO3DEP + USE ERROR_MOD, ONLY : ERROR_STOP, GEOS_CHEM_STOP + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP + + USE ADJ_ARRAYS_MOD, ONLY : DEPSAV_ADJ, REMIS_ADJ, SHIPO3DEP_ADJ + USE GCKPP_ADJ_GLOBAL, ONLY : NCOEFF + + ! Added for reaction rate sensitivities (tww, 05/08/12) + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE GCKPP_ADJ_GLOBAL, ONLY : IND, JCOEFF, RCONST, NCOEFF_EM + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NTDEP, NEMIS, NTEMIS, NCSURBAN + + + ! Arguments + REAL*8,INTENT(IN) :: RRATE_ADJ(NMTRATE) + INTEGER :: IX, IY, IZ + + ! Local variables + INTEGER :: NK, I, NN, N + INTEGER :: JJLOOP + REAL*8 :: XAREA,XRADIUS,XSQM + REAL*8 :: XSTKCF,XDENA,XSTK + REAL*8 :: ARSL1K, DFKG + + !debug tww + LOGICAL, SAVE :: FIRST=.TRUE. + + !REAL*8 :: ADJ_ARSL1K, ADJ_XAREA + !REAL*8 :: ADJ_XRADIUS + REAL*8 :: ARSL1K_ADJ, XAREA_ADJ + REAL*8 :: XRADIUS_ADJ + !================================================================= + !CALCRATE_ADJ begins here! + !================================================================= +C +C ********************************************************************* +C ****** ADJOINT OF SET DRY DEPOSITION RATES ****** +C ********************************************************************* +C + + DO I = 1,NUMDEP + NK = NTDEP(I) + IF (NK.NE.0) THEN + ! We don't loop over SMVG blocks for adjoint + !DO KLOOP = 1,KTLOOP + + ! Pass JJLOOP, IX, IY and IZ as arguments instead (dkh, 06/04/06) + ! 1-D grid box index (accounts for reordering) + !JLOOP = LREORDER(KLOOP+JLOOPLO) + + ! 3-D grid box index + !IX = IXSAVE(JLOOP) + !IY = IYSAVE(JLOOP) + !IZ = IZSAVE(JLOOP) + + SELECT CASE ( TRIM(DEPNAME(I)) ) + CASE ( 'O3' ) + ! fwd code: + !RRATE(KLOOP,NK) = RRATE(KLOOP,NK) + + ! SHIPO3DEP(IX,IY) * + ! GET_FRAC_UNDER_PBLTOP( IX, IY, IZ ) + ! adj code: + SHIPO3DEP_ADJ(IX,IY) = SHIPO3DEP_ADJ(IX,IY) + & + RRATE_ADJ(NK) + & * GET_FRAC_UNDER_PBLTOP( IX, IY, IZ ) + + CASE DEFAULT ! Do nothing + END SELECT + + ! Adjoint of deposition frequency + ! PBLFRAC is the fraction of grid box (I,J,L) below the PBL top + ! fwd code: + !RRATE(KLOOP,NK) = DEPSAV(IX,IY,I) * + ! GET_FRAC_UNDER_PBLTOP( IX, IY, IZ ) + + DEPSAV_ADJ(IX,IY,I) + & = RRATE_ADJ(NK) * + & GET_FRAC_UNDER_PBLTOP( IX, IY, IZ ) + + + !ENDDO + ENDIF + ENDDO + +C ********************************************************************* +C ****** ADJOINT OF SET EMISSION RATES ****** +C ********************************************************************* +C + + NCS = 1 + DO I = 1,NEMIS(NCS) +C get tracer number corresponding to emission species I + NN = IDEMS(I) + IF (NN.NE.0) THEN +C find reaction number for emission of tracer NN + NK = NTEMIS(NN,NCS) + IF (NK.NE.0) THEN + ! We don't loop over SMVG blocks for adjoint + !DO KLOOP = 1,KTLOOP + + ! Pass JJLOOP as an argument for adjoint + !JLOOP = LREORDER(KLOOP+JLOOPLO) + + ! fwd code: + ! RRATE(KLOOP,NK) = REMIS(JLOOP,I) + ! At this point, all the adjoint routine has to do is pass the + ! values from RRATE_ADJ to REMIS_ADJ. + JJLOOP = JLOP(IX,IY,IZ) + REMIS_ADJ(JJLOOP,I) = RRATE_ADJ(NK) + + !ENDDO + ENDIF + ENDIF + ENDDO + +! **************************************************************** +! ****** ADJOINT OF REACTION RATES ****** +! **************************************************************** +! added (tww, 05/08/12) + + IF ( LADJ_RRATE ) THEN + DO I = NCOEFF_EM+1, NCOEFF + + ! get reaction number for reaction specified for adjoint calc + NK = IND( JCOEFF( I ) ) + RATE_SF_ADJ(IX,IY,IZ,I-NCOEFF_EM) = + & RATE_SF_ADJ(IX,IY,IZ,I-NCOEFF_EM) + & + RRATE_ADJ(NK) * RCONST(JCOEFF(I)) + + ENDDO + ENDIF + +! aerosol het chem adjoint, need to update +! +! NCS = NCSURBAN +! +! ! Set HETCHEM = T to perform het chem on aerosols +! !HETCHEM = .TRUE. +! +! !IF ( HETCHEM ) THEN +! +! ! Initialize TAREA_ADJ +! TAREA_ADJ(JJLOOP,:) = 0d0 +! +! !=========================================================== +! ! Perform heterogeneous chemistry on sulfate aerosol +! ! plus each of the NDUST dust size bins from FAST-J +! !=========================================================== +! XDENA = AIRDENS(JJLOOP) +! XSTK = SQRT(T3(JJLOOP)) +! +! DO I = 1, NNADDK(NCS) +! NK = NKSPECK(I,NCS) +! XSQM = SQRT(ARR(NK,NCS)) +! +! ARSL1K_ADJ = 0d0 +! +! ! Loop over sulfate and other aerosols +! ! SKIPP DUST for now +! !DO N = 1, NDUST + NAER +! !DO N = NDUST+1, NDUST + NAER +! ! Now include carbon aerosol (dkh, 06/03/08) +! DO N = NDUST+1, NDUST + 3 +! +! ! Adjoint of ARSL1K +! ! fwd code: +! !RRATE(KLOOP,NK) = RRATE(KLOOP,NK) + ARSL1K +! ARSL1K_ADJ = RRATE_ADJ(JJLOOP,NK) +! +! ! Recalculate XSTKCF, XSQM, XRADIUS, XAREA +! +! ! Surface area of aerosol [cm2 aerosol/cm3 air] +! XAREA = TAREA(JJLOOP,N) +! +! ! Test if N2O5 hydrolysis rxn +! IF ( NK == NKN2O5 ) THEN +! +! ! Get GAMMA for N2O5 hydrolysis, which is +! ! a function of aerosol type, temp, and RH +! XSTKCF = N2O5( N, T3(JJLOOP), ABSHUM(JJLOOP) ) +! +! ELSE +! +! ! Get GAMMA for species other than N2O5 +! XSTKCF = BRR(NK,NCS) +! +! ENDIF +! +! ! Radius for dust size bin N +! XRADIUS = ERADIUS(JJLOOP,N) +! +! +! ! ARSL1K begins here! +! !================================================================= +! IF ( XAREA < 0d0 .or. XRADIUS < 1d-30 ) THEN +! +! ! fwd code +! !ARSL1K = 1.D-3 +! ! Adjoint of this is do nothing +! XAREA_ADJ = 0d0 +! XRADIUS_ADJ = 0d0 +! +! ELSE +! +! ! Recalculate DFKG +! ! DFKG = Gas phase diffusion coeff [cm2/s] (order of 0.1) +! DFKG = 9.45D17/XDENA * XSTK +! & * SQRT(3.472D-2 + 1.D0/(XSQM*XSQM)) +! +! ! Calcualte adjoint of AREA from ARSL1K_ADJ +! ! fwd code +! !ARSL1K = AREA / ( RADIUS/DFKG + 2.749064E-4*SQM/(STKCF*STK) ) +! XAREA_ADJ = ARSL1K_ADJ / ( XRADIUS/DFKG +! & + 2.749064E-4*XSQM/(XSTKCF*XSTK) ) +! +! ! Calculate adjoint of RADIUS from ARSL1K_ADJ +! XRADIUS_ADJ = ARSL1K_ADJ * ( - XAREA / DFKG ) +! & * ( XRADIUS/DFKG +! & + 2.749064E-4*XSQM/(XSTKCF*XSTK) ) ** -2 +! +! +! ENDIF +! +! ! Surface area of aerosol [cm2 aerosol/cm3 air] +! ! fwd code: +! !XAREA = TAREA(JLOOP,N) +! TAREA_ADJ(JJLOOP,N) = TAREA_ADJ(JJLOOP,N) + XAREA_ADJ +! +! ! fwd code: +! !XRADIUS = ERADIUS(JLOOP,N) +! ERADIUS_ADJ(JJLOOP,N) = ERADIUS_ADJ(JJLOOP,N) +! & + XRADIUS_ADJ +! +! ENDDO +! +! ! Reset, not needed, but to be safe... +! !RRATE_ADJ(JJLOOP,NK) = 0d0 +! +! ENDDO +! +! !ENDIF +! !ENDDO +C + RETURN + +C +C ********************************************************************* +C INTERNAL SUBROUTINES +C ********************************************************************* +C + CONTAINS + + FUNCTION N2O5( AEROTYPE, TEMP, RH ) RESULT( GAMMA ) + + !================================================================= + ! Internal function N2O5 computes the GAMMA sticking factor + ! for N2O5 hydrolysis. (mje, bmy, 8/7/030 + ! + ! Arguments as Input: + ! ---------------------------------------------------------------- + ! (1 ) AEROTYPE (INTEGER) : # denoting aerosol type (cf FAST-J) + ! (2 ) TEMP (REAL*8 ) : Temperature [K] + ! (3 ) RH (REAL*8 ) : Relative Humidity [fraction] + ! + ! NOTES: + !================================================================= + + ! Arguments + INTEGER, INTENT(IN) :: AEROTYPE + REAL*8, INTENT(IN) :: TEMP, RH + + ! Local variables + REAL*8 :: RH_P, FACT, TTEMP + + ! Function return value + REAL*8 :: GAMMA + + !================================================================= + ! N2O5 begins here! + !================================================================= + + ! Convert RH to % (max = 100%) + RH_P = MIN( RH * 100d0, 100d0 ) + + ! Default value + GAMMA = 0.01d0 + + ! Special handling for various aerosols + SELECT CASE ( AEROTYPE ) + + !---------------- + ! Dust + !---------------- + CASE ( 1, 2, 3, 4, 5, 6, 7 ) + + ! Based on unpublished Crowley work + GAMMA = 0.01d0 + + !---------------- + ! Sulfate + !---------------- + CASE ( 8 ) + + !=========================================================== + ! RH dependence from Kane et al., Heterogenous uptake of + ! gaseous N2O5 by (NH4)2SO4, NH4HSO4 and H2SO4 aerosols + ! J. Phys. Chem. A , 2001, 105, 6465-6470 + !=========================================================== + GAMMA = 2.79d-4 + RH_P*( 1.30d-4 + + & RH_P*( -3.43d-6 + + & RH_P*( 7.52d-8 ) ) ) + + !=========================================================== + ! Temperature dependence factor (Cox et al, Cambridge UK) + ! is of the form: + ! + ! 10^( LOG10( G294 ) - 0.04 * ( TTEMP - 294 ) ) + ! FACT = ------------------------------------------------- + ! 10^( LOG10( G294 ) ) + ! + ! Where G294 = 1e-2 and TTEMP is MAX( TEMP, 282 ). + ! + ! For computational speed, replace LOG10( 1e-2 ) with -2 + ! and replace 10^( LOG10( G294 ) ) with G294 + !=========================================================== + TTEMP = MAX( TEMP, 282d0 ) + FACT = 10.d0**( -2d0 - 4d-2*( TTEMP - 294.d0 ) ) / 1d-2 + + ! Apply temperature dependence + GAMMA = GAMMA * FACT + + !---------------- + ! Black Carbon + !---------------- + CASE ( 9 ) + + ! From IUPAC + GAMMA = 0.005d0 + + !---------------- + ! Organic Carbon + !---------------- + CASE ( 10 ) + + !=========================================================== + ! Based on Thornton, Braban and Abbatt, 2003 + ! N2O5 hydrolysis on sub-micron organic aerosol: the effect + ! of relative humidity, particle phase and particle size + !=========================================================== + IF ( RH_P >= 57d0 ) THEN + GAMMA = 0.03d0 + ELSE + GAMMA = RH_P * 5.2d-4 + ENDIF + + !---------------- + ! Sea salt + ! accum & coarse + !---------------- + CASE ( 11, 12 ) + + ! Based on IUPAC recomendation + IF ( RH_P >= 62 ) THEN + GAMMA = 0.03d0 + ELSE + GAMMA = 0.005d0 + ENDIF + + !---------------- + ! Default + !---------------- + CASE DEFAULT + WRITE (6,*) 'Not a suitable aerosol surface ' + WRITE (6,*) 'for N2O5 hydrolysis' + WRITE (6,*) 'AEROSOL TYPE =',AEROTYPE + CALL GEOS_CHEM_STOP + + END SELECT + + ! Return to CALCRATE + END FUNCTION N2O5 + + ! Return to calling program + END SUBROUTINE CALCRATE_ADJ + diff --git a/code/adjoint/carbon_adj_mod.f b/code/adjoint/carbon_adj_mod.f new file mode 100644 index 0000000..1b5ce35 --- /dev/null +++ b/code/adjoint/carbon_adj_mod.f @@ -0,0 +1,1611 @@ + MODULE CARBON_ADJ_MOD +! +!****************************************************************************** +! Module CARBON_ADJ_MOD contains arrays and routines for performing an offline +! carbonaceous aerosol adjoint simulation. Original code taken from forward +! routines in CARBON_MOD and modified accordingly. (dkh, 03/01/05) +! +! Module Variables: +! ============================================================================ +! (1 ) BCCONV_ADJ (REAL*8) : Adjoint of BCCONV +! (2 ) OCCONV_ADJ (REAL*8) : Adjoint of OCCONV +! +! Module Routines: +! ============================================================================ +! (1 ) ADJ_CHEMCARBON : Driver program for adjoint carbon aerosol chemistry +! (2 ) ADJ_CHEM_BCPO : Chemistry routine for hydrophobic BC (aka EC) +! (3 ) ADJ_CHEM_BCPI : Chemistry routine for hydrophilic BC (aka EC) +! (4 ) ADJ_CHEM_OCPO : Chemistry routine for hydrophobic OC +! (5 ) ADJ_CHEM_OCPI : Chemistry routine for hydrophilic OC +! +! GEOS-CHEM modules referenced by carbon_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (2 ) dao_mod.f : Module w/ arrays for DAO met fields +! (3 ) diag_mod.f : Module w/ GEOS-CHEM diagnostic arrays +! (4 ) directory_mod.f : Module w/ GEOS-CHEM data & met field dirs +! (5 ) drydep_mod.f : Module w/ routines for dry deposition +! (6 ) error_mod.f : Module w/ I/O error and NaN check routines +! (7 ) global_no3_mod.f : Module w/ routines to read 3-D NO3 field +! (8 ) global_oh_mod.f : Module w/ routines to read 3-D OH field +! (9 ) global_o3_mod.f : Module w/ routines to read 3-D O3 field +! (10) grid_mod.f : Module w/ horizontal grid information +! (11) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (12) megan_mod.f : Module w/ routines to read MEGAN biogenic emiss +! (13) pbl_mix_mod.f : Module w/ routines for PBL height & mixing +! (14) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (15) time_mod.f : Module w/ routines for computing time & date +! (16) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc. +! (17) tracerid_mod.f : Module w/ pointers to tracers & emissions +! (18) transfer_mod.f : Module w/ routines to cast & resize arrays +! +! NOTES: +! (1 ) See original forward module for all notes. +! (2 ) Change BCCONV and OCCONV to ADJ_BCCONV and ADJ_OCCONV. (dkh, 03/22/07) +! (3 ) Updated to GCv8 (dkh, 09/09/09) +! +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "carbon_mod.f" + !================================================================= + + ! Declare everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: CHEMCARBON_ADJ + PUBLIC :: EMISSCARBON_ADJ + PUBLIC :: CLEANUP_CARBON_ADJ + + !================================================================= + ! MODULE VARIABLES + !================================================================= + +! Comment out module variables from forward routine that we don't use +! for the adjoint. (dkh, 09/09/09) +! ! Scalars +! LOGICAL :: USE_MONTHLY_BIOB = .TRUE. +! INTEGER :: DRYBCPI, DRYOCPI, DRYBCPO, DRYOCPO +! INTEGER :: DRYALPH, DRYLIMO, DRYALCO +! INTEGER :: DRYSOG1, DRYSOG2, DRYSOG3, DRYSOG4 +! INTEGER :: DRYSOA1, DRYSOA2, DRYSOA3, DRYSOA4 +! INTEGER :: I1_NA, J1_NA +! INTEGER :: I2_NA, J2_NA +! INTEGER :: DRYSOAG, DRYSOAM +! +! ! Parameters +! INTEGER, PARAMETER :: MHC = 6 +! INTEGER, PARAMETER :: NPROD = 3 +! REAL*8, PARAMETER :: SMALLNUM = 1d-20 +! +! ! Arrays +! REAL*8, ALLOCATABLE :: ANTH_BLKC(:,:,:) +! REAL*8, ALLOCATABLE :: ANTH_ORGC(:,:,:) +! REAL*8, ALLOCATABLE :: BIOB_BLKC(:,:,:) +! REAL*8, ALLOCATABLE :: BIOB_ORGC(:,:,:) +! REAL*8, ALLOCATABLE :: BIOF_BLKC(:,:,:) +! REAL*8, ALLOCATABLE :: BIOF_ORGC(:,:,:) +! REAL*8, ALLOCATABLE :: EF_BLKC(:,:) +! REAL*8, ALLOCATABLE :: EF_ORGC(:,:) +! REAL*8, ALLOCATABLE :: TERP_ORGC(:,:) +! REAL*8, ALLOCATABLE :: BCCONV(:,:,:) +! REAL*8, ALLOCATABLE :: OCCONV(:,:,:) +! REAL*8, ALLOCATABLE :: BIOG_ALPH(:,:) +! REAL*8, ALLOCATABLE :: BIOG_LIMO(:,:) +! REAL*8, ALLOCATABLE :: BIOG_ALCO(:,:) +! REAL*8, ALLOCATABLE :: BIOG_TERP(:,:) +! REAL*8, ALLOCATABLE :: BIOG_SESQ(:,:) +! REAL*8, ALLOCATABLE :: DIUR_ORVC(:,:) +! REAL*8, ALLOCATABLE :: GEIA_ORVC(:,:) +! REAL*8, ALLOCATABLE :: TCOSZ(:,:) +! REAL*8, ALLOCATABLE :: ORVC_SESQ(:,:,:) +! REAL*8, ALLOCATABLE :: ORVC_TERP(:,:,:) +! REAL*8, ALLOCATABLE :: GPROD(:,:,:,:,:) +! REAL*8, ALLOCATABLE :: APROD(:,:,:,:,:) +! ! Cloud fraction - for cloud droplet uptake of dicarbonyls +! ! (tmf, 12/07/07) +! REAL*8, ALLOCATABLE :: VCLDF(:,:,:) + + REAL*8, ALLOCATABLE :: BCCONV_ADJ(:,:,:) + REAL*8, ALLOCATABLE :: OCCONV_ADJ(:,:,:) + + ! Days per month (based on 1998) + INTEGER :: NDAYS(12) = (/ 31, 28, 31, 30, 31, 30, + & 31, 31, 30, 31, 30, 31 /) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEMCARBON_ADJ +! +!****************************************************************************** +! Subroutine CHEMCARBON is the interface between the GEOS-CHEM main +! program and the adjoint carbon aerosol chemistry routines that calculates +! dry deposition and chemical conversion between hydrophilic and +! hydrophobic. +! +! NOTES: +! (1 ) Based on CHEMCARBON from forward model. (rjp, bmy, 4/1/04, 9/14/06) +! The only differences are: +! i. Use STT_ADJ instead of STT +! ii. Call CHEM_xxxx_ADJ rather than CHEM_xxxx +! +! NOTES: +! (1 ) See forword module for all notes. +! (2 ) Updated to GCv8 (dkh, 09/09/09) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE DRYDEP_MOD, ONLY : DEPNAME, NUMDEP + USE ERROR_MOD, ONLY : DEBUG_MSG + USE ERROR_MOD, ONLY : ERROR_STOP + USE GLOBAL_OH_MOD, ONLY : GET_GLOBAL_OH + USE GLOBAL_NO3_MOD, ONLY : GET_GLOBAL_NO3 + USE GLOBAL_O3_MOD, ONLY : GET_GLOBAL_O3 + USE LOGICAL_MOD, ONLY : LSOA, LEMIS, LPRT + USE TIME_MOD, ONLY : GET_MONTH, ITS_A_NEW_MONTH + USE TRACER_MOD, ONLY : STT, ITS_AN_AEROSOL_SIM + USE TRACERID_MOD, ONLY : IDTBCPI, IDTBCPO, IDTOCPI + USE TRACERID_MOD, ONLY : IDTOCPO, IDTSOG4, IDTSOA4 + USE TRACERID_MOD, ONLY : IDTSOAG, IDTSOAM + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRSTCHEM = .TRUE. + INTEGER :: N, THISMONTH + + !================================================================= + ! CHEMCARBON_ADJ begins here! + !================================================================= + + ! First-time initialization + IF ( FIRSTCHEM ) THEN + + ! Initialize arrays (if not already done before) + CALL INIT_CARBON_ADJ + + ! Don't need to repeat the rest of this (dkh, 09/09/09) +! ! Find drydep species in DEPSAV +! DO N = 1, NUMDEP +! SELECT CASE ( TRIM( DEPNAME(N) ) ) +! CASE ( 'BCPI' ) +! DRYBCPI = N +! CASE ( 'OCPI' ) +! DRYOCPI = N +! CASE ( 'BCPO' ) +! DRYBCPO = N +! CASE ( 'OCPO' ) +! DRYOCPO = N +! CASE ( 'ALPH' ) +! DRYALPH = N +! CASE ( 'LIMO' ) +! DRYLIMO = N +! CASE ( 'ALCO' ) +! DRYALCO = N +! CASE ( 'SOG1' ) +! DRYSOG1 = N +! CASE ( 'SOG2' ) +! DRYSOG2 = N +! CASE ( 'SOG3' ) +! DRYSOG3 = N +! CASE ( 'SOG4' ) +! DRYSOG4 = N +! CASE ( 'SOA1' ) +! DRYSOA1 = N +! CASE ( 'SOA2' ) +! DRYSOA2 = N +! CASE ( 'SOA3' ) +! DRYSOA3 = N +! CASE ( 'SOA4' ) +! DRYSOA4 = N +! CASE ( 'SOAG' ) +! DRYSOAG = N +! CASE ( 'SOAM' ) +! DRYSOAM = N +! CASE DEFAULT +! ! Nothing +! END SELECT +! ENDDO +! +! ! Zero SOG4 and SOA4 (SOA from ISOP in gas & aerosol form) +! ! for offline aerosol simulations. Eventually we should have +! ! archived isoprene oxidation fields available for offline +! ! simulations but for now we just set them to zero. +! ! (dkh, bmy, 6/1/06) +! IF ( ITS_AN_AEROSOL_SIM() ) THEN +! +! ! temp fix for aerosol w/ 20 tracers simulation (phs) +! IF ( IDTSOG4 .NE. 0 ) THEN +! STT(:,:,:,IDTSOG4) = 0d0 +! STT(:,:,:,IDTSOA4) = 0d0 +! ENDIF +! ENDIF + + ! Reset first-time flag + FIRSTCHEM = .FALSE. + ENDIF + + !================================================================= + ! Do chemistry for carbon aerosol tracers + !================================================================= + + ! Chemistry for hydrophilic OC + IF ( IDTOCPI > 0 ) THEN + CALL CHEM_OCPI_ADJ( STT_ADJ(:,:,:,IDTOCPI) ) + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMCARBON_ADJ: a CHEM_OCPI_ADJ' ) + ENDIF + + ! Chemistry for hydrophobic OC + IF ( IDTOCPO > 0 ) THEN + CALL CHEM_OCPO_ADJ( STT_ADJ(:,:,:,IDTOCPO) ) + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMCARBON_ADJ: a CHEM_OCPO_ADJ' ) + ENDIF + + ! Chemistry for hydrophilic BC + IF ( IDTBCPI > 0 ) THEN + CALL CHEM_BCPI_ADJ( STT_ADJ(:,:,:,IDTBCPI) ) + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMCARBON_ADJ: a CHEM_BCPI_ADJ' ) + ENDIF + + + ! Chemistry for hydrophobic BC + IF ( IDTBCPO > 0 ) THEN + CALL CHEM_BCPO_ADJ( STT_ADJ(:,:,:,IDTBCPO) ) + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMCARBON_ADJ: a CHEM_BCPO_ADJ' ) + ENDIF + + + !================================================================= + ! Do chemistry for secondary organic aerosols + !================================================================= + IF ( LSOA ) THEN + + CALL ERROR_STOP('SOA not supported yet for adjoint', + & 'carbon_adj_mod.f') + +! ! Read offline OH, NO3, O3 fields from disk +! IF ( ITS_AN_AEROSOL_SIM() ) THEN +! +! ! Current month +! THISMONTH = GET_MONTH() +! +! IF ( ITS_A_NEW_MONTH() ) THEN +! CALL GET_GLOBAL_OH( THISMONTH ) +! CALL GET_GLOBAL_NO3( THISMONTH ) +! CALL GET_GLOBAL_O3( THISMONTH ) +! ENDIF +! +! ! Compute time scaling arrays for offline OH, NO3 +! ! but only if it hasn't been done in EMISSCARBON +! IF ( LSOA .and. ( .not. LEMIS ) ) THEN +! CALL OHNO3TIME +! IF ( LPRT ) CALL DEBUG_MSG( '### CHEMCARB: a OHNO3TIME' ) +! ENDIF +! ENDIF +! +! ! Compute SOA chemistry +! ! NOTE: This is SOA production from the reversible mechanism only +! ! (tmf, 12/07/07) +! CALL SOA_CHEMISTRY +! IF ( LPRT ) CALL DEBUG_MSG( '### CHEMCARBON: a SOA_CHEM' ) +! +! ! If SOAG and SOAM are declared, switch on +! ! SOA production from dicarbonyls (tmf, 12/07/07) +! IF ( IDTSOAG > 0 ) THEN +! +! ! Get grid box cloud fraction +! ! (tmf, 2/26/07) +! CALL GET_VCLDF +! +! ! Cloud uptake +! CALL SOAG_CLOUD +! IF ( LPRT ) +! & CALL DEBUG_MSG('### CHEMCARBON: a SOAG_CLOUD') +! +! ! Aqueous aerosol uptake +! CALL SOAG_LIGGIO_DIFF +! IF ( LPRT ) +! & CALL DEBUG_MSG('### CHEMCARBON: a SOAG_LIGGIO_DIFF') +! +! ENDIF +! +! IF ( IDTSOAM > 0 ) THEN +! +! ! Get grid box cloud fraction +! ! (tmf, 2/26/07) +! CALL GET_VCLDF +! +! ! Cloud uptake +! CALL SOAM_CLOUD +! IF ( LPRT ) +! & CALL DEBUG_MSG('### CHEMCARBON: a SOAM_CLOUD') +! +! ! Aqueous aerosol uptake +! CALL SOAM_LIGGIO_DIFF +! IF ( LPRT ) +! & CALL DEBUG_MSG( '### CHEMCARBON: a SOAM_LIGGIO_DIFF' ) +! +! +! +! ENDIF + + + ENDIF + + ! Return to calling program + END SUBROUTINE CHEMCARBON_ADJ + +!----------------------------------------------------------------------------- + + SUBROUTINE CHEM_BCPO_ADJ( TC_ADJ ) +! +!****************************************************************************** +! Subroutine ADJ_CHEM_BCPO converts hydrophobic BC to hydrophilic BC and +! calculates the dry deposition of hydrophobic BC adjoints. (dkh, 03/02/05) +! +! Based on forward model by (rjp, bmy, 4/1/04,10/25/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) TC (REAL*8) : Array of hydrophobic BC tracer +! +! NOTES: +! (1 ) See forward model. +! (2 ) Based on CHEM_OPCI from forward model. The only differences are: +! i. Check if ABS( CNEW ) < SMALLNUM +! ii. Include STT_ADJ +! iii. Take out ND44 stuff +! (3 ) Updated to include adjoint of OCPO --> OCPI. Comment out diagnostics +! from forward model. (dkh, 03/22/07) +! (4 ) Updated to GCv8 (dkh, 09/09/09) +!****************************************************************************** +! + ! References to F90 modules + USE CARBON_MOD, ONLY : DRYBCPO + USE DAO_MOD, ONLY : AD + !USE DIAG_MOD, ONLY : AD44, AD07_BC + USE DRYDEP_MOD, ONLY : DEPSAV + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTBCPO + USE TIME_MOD, ONLY : GET_TS_CHEM + +# include "CMN_SIZE" ! Size parameters +!# include "CMN_DIAG" ! ND44, ND07, LD07 + + ! Arguments + REAL*8, INTENT(INOUT) :: TC_ADJ(IIPAR,JJPAR,LLPAR) + + ! Local variables + INTEGER :: I, J, L + !REAL*8 :: ND44_TMP(IIPAR,JJPAR,LLPAR) + REAL*8 :: DTCHEM, FLUX, KBC, FREQ, BL_FRAC + REAL*8 :: TC0_ADJ, CNEW_ADJ, RKT, AREA_CM2 + REAL*8, PARAMETER :: BC_LIFE = 1.15D0 + + !================================================================= + ! CHEM_BCPO_ADJ begins here! + !================================================================= + + ! Return if BCPO isn't defined + IF ( IDTBCPO == 0 .or. DRYBCPO == 0 ) RETURN + + ! Initialize + KBC = 1.D0 / ( 86400d0 * BC_LIFE ) + DTCHEM = GET_TS_CHEM() * 60d0 + + !================================================================= + ! For tracers with dry deposition, the loss rate of dry dep is + ! combined in chem loss term. + ! + ! Conversion from hydrophobic to hydrophilic: + ! e-folding time 1.15 days + ! ---------------------------------------- + ! Use an e-folding time of 1.15 days or a convertion rate + ! of 1.0e-5 /sec. + ! + ! Hydrophobic(2) --> Hydrophilic(1) , k = 1.0e-5 + ! Both aerosols are dry-deposited, kd = Dvel/DELZ (sec-1) + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, TC0_ADJ, FREQ, BL_FRAC, RKT, CNEW_ADJ ) +!$OMP+PRIVATE( AREA_CM2, FLUX ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Store new concentration back into tracer array + CNEW_ADJ = TC_ADJ(I,J,L) + + ! Zero drydep freq + FREQ = 0d0 + + ! Fraction of box under the PBL top [unitless] + BL_FRAC = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + + ! Only apply drydep to boxes w/in the PBL + IF ( BL_FRAC > 0d0 ) THEN + + ! BC drydep frequency [1/s] -- PBLFRAC accounts for the fraction + ! of each grid box (I,J,L) that is located beneath the PBL top + FREQ = DEPSAV(I,J,DRYBCPO) * BL_FRAC + + ENDIF + + ! Prevent underflow condition + !IF ( ABS( CNEW ) < SMALLNUM ) CNEW = 0d0 + + ! Amount of BCPO converted to BCPI [kg/timestep] + ! fwd code: + !BCCONV(I,J,L) = ( TC0 - CNEW ) * KBC / ( KBC + FREQ ) + TC0_ADJ = BCCONV_ADJ(I,J,L) * KBC / ( KBC + FREQ ) + ! CNEW_ADJ is calculated as: + ! CNEW_ADJ = CNEW_ADJ - BCCONV_ADJ(I,J,L) * KBC / ( KBC + FREQ ) + ! same thing, but faster: + CNEW_ADJ = CNEW_ADJ - TC0_ADJ + + ! Amount of BCPO left after chemistry and drydep [kg] + RKT = ( KBC + FREQ ) * DTCHEM + ! fwd code: + !CNEW = TC0 * EXP( -RKT ) + TC0_ADJ = TC0_ADJ + CNEW_ADJ * EXP( -RKT ) + +! !============================================================== +! ! ND44 diagnostic: drydep loss [atoms C/cm2/s] +! !============================================================== +! IF ( ND44 > 0 .AND. FREQ > 0d0 ) THEN +! +! ! Surface area [cm2] +! AREA_CM2 = GET_AREA_CM2( J ) +! +! ! Convert drydep loss from [kg/timestep] to [atoms C/cm2/s] +! ! XNUMOL is the ratio [molec tracer/kg tracer] +! FLUX = TC0 - CNEW - BCCONV(I,J,L) +! FLUX = FLUX * XNUMOL(IDTBCPO) / ( DTCHEM * AREA_CM2 ) +! +! ! Store in ND44_TMP as a placeholder +! ND44_TMP(I,J,L) = ND44_TMP(I,J,L) + FLUX +! ENDIF +! +! !============================================================== +! ! ND07 diagnostic: H-philic BC from H_phobic BC [kg/timestep] +! !============================================================== +! IF ( ND07 > 0 .and. L <= LD07 ) THEN +! AD07_BC(I,J,L) = AD07_BC(I,J,L) + BCCONV(I,J,L) +! ENDIF + + ! Initial BC mass [kg] + ! fwd code: + !TC0 = TC(I,J,L) + TC_ADJ(I,J,L) = TC0_ADJ + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + +! !=============================================================== +! ! ND44: Sum drydep fluxes by level into the AD44 array in +! ! order to ensure that we get the same results w/ sp or mp +! !=============================================================== +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! DO L = 1, LLPAR +! AD44(I,J,DRYBCPO,1) = AD44(I,J,DRYBCPO,1) + ND44_TMP(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! fwd code: + !BCCONV(I,J,L) = 0d0 + BCCONV_ADJ(I,J,L) = 0d0 + + ! Initialize for drydep diagnostic +! IF ( ND44 > 0 ) ND44_TMP(I,J,L) = 0d0 + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE CHEM_BCPO_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_BCPI_ADJ( TC_ADJ ) +! +!****************************************************************************** +! Subroutine CHEM_BCPI_ADJ calculates dry deposition of hydrophilic BC adjoint +! (dkh, 03/02/05) +! +! Based on forward code by (rjp, bmy, 4/1/04, 10/25/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) TC (REAL*8) : Array of hydrophilic BC adjoint +! +! NOTES: +! (1 ) Based on CHEM_BCPI from forward model. The only differences are: +! i. Check if ABS( CNEW ) < SMALLNUM +! ii. Return if IDADJBCPI is 0 +! iii. Include ADJ_STT +! (2 ) Updated to include adjoint of BCPO --> BCPI. Comment out diagnostics +! from forward model. (dkh, 03/22/07) +! (3 ) Updated to GCv8 (dkh, 09/09/09) +!****************************************************************************** +! + ! References to F90 modules + USE CARBON_MOD, ONLY : DRYBCPI + USE DAO_MOD, ONLY : AD + USE DIAG_MOD, ONLY : AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTBCPI + USE TIME_MOD, ONLY : GET_TS_CHEM + +# include "CMN_SIZE" ! Size parameters +!# include "CMN_DIAG" ! ND44 + + ! Arguments + REAL*8, INTENT(INOUT) :: TC_ADJ(IIPAR,JJPAR,LLPAR) + + ! Local variables + INTEGER :: I, J, L + REAL*8 :: DTCHEM, FLUX, BL_FRAC, AREA_CM2, FREQ + REAL*8 :: TC0_ADJ, CNEW_ADJ, CCV_ADJ +! REAL*8 :: ND44_TMP(IIPAR,JJPAR,LLPAR) + + !================================================================= + ! CHEM_BCPI_ADJ begins here! + !================================================================= + + ! Return if BCPI isn't defined + IF ( IDTBCPI == 0 .or. DRYBCPI == 0 ) RETURN + + ! Chemistry timestep [s] + DTCHEM = GET_TS_CHEM() * 60d0 + + !================================================================= + ! Zero out the BCCONV_ADJ array for the next iteration + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ! fwd code: + !BCCONV(I,J,L) = 0.d0 + BCCONV_ADJ(I,J,L) = 0.d0 + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + +! ! Initialize for ND44 diagnostic +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! ND44_TMP(I,J,L) = 0d0 +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, TC0_ADJ, CCV_ADJ, FREQ, BL_FRAC ) +!$OMP+PRIVATE( CNEW_ADJ, AREA_CM2, FLUX ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Save new concentration of H-philic IC in tracer array + CNEW_ADJ = TC_ADJ(I,J,L) + + ! Fraction of grid box under the PBL top [unitless] + BL_FRAC = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! Only apply drydep to boxes w/in the PBL + IF ( BL_FRAC > 0d0 ) THEN + + ! Drydep frequency + FREQ = DEPSAV(I,J,DRYBCPI) * BL_FRAC + + !=========================================================== + ! Note, This is an analytical solution of first order + ! partial differential equations (w/ 2 solutions): + ! + ! #1) CNEW = Cphi * exp(-RKT) + Cconv/RKT * (1.-exp(-RKT)) + ! #2) CNEW = ( Cphi + Cconv ) * exp(-RKT) + !=========================================================== + + ! note -- this was already commented out of fwd code + ! Comment out for now + !CNEW = TC0 * EXP( -FREQ * DTCHEM ) + ! + CCV / FREQ * ( 1.D0 - EXP( -FREQ * DTCHEM ) ) + + ! Amount of BCPI left after drydep [kg] + ! fwd code: + !CNEW = ( TC0 + CCV ) * EXP( -FREQ * DTCHEM ) + TC0_ADJ = CNEW_ADJ * EXP( -FREQ * DTCHEM ) + ! adjoint for CCV_ADJ is: + ! CCV_ADJ = CNEW_ADJ * EXP( -FREQ * DTCHEM ) + ! or, same but faster: + CCV_ADJ = TC0_ADJ + +! !=========================================================== +! ! ND44 diagnostic: drydep flux [atoms C/cm2/s] +! !=========================================================== +! IF ( ND44 > 0 .and. FREQ > 0d0 ) THEN +! +! ! Surface area [cm2] +! AREA_CM2 = GET_AREA_CM2( J ) +! +! ! Convert drydep loss from [kg/timestep] to [molec/cm2/s] +! FLUX = ( TC0 + CCV - CNEW ) +! FLUX = FLUX * XNUMOL(IDTBCPI) / ( AREA_CM2 * DTCHEM ) +! +! ! Store in ND44_TMP as a placeholder +! ND44_TMP(I,J,L) = ND44_TMP(I,J,L) + FLUX +! ENDIF + + ELSE + + ! Otherwise, omit the exponential to save on clock cycles + ! fwd code: + !CNEW = TC0 + CCV + TC0_ADJ = CNEW_ADJ + CCV_ADJ = CNEW_ADJ + + ENDIF + + ! Prevent underflow condition + !IF ( ABS( CNEW ) < SMALLNUM ) CNEW = 0d0 + + ! H-philic BC that used to be H-phobic BC [kg] + ! fwd code: + !CCV = BCCONV(I,J,L) + BCCONV_ADJ(I,J,L) = CCV_ADJ + + ! Initial H-philic BC [kg] + ! fwd code: + !TC0 = TC(I,J,L) + TC_ADJ(I,J,L) = TC0_ADJ + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + +! !================================================================= +! ! ND44: Sum drydep fluxes by level into the AD44 array in +! ! order to ensure that we get the same results w/ sp or mp +! !================================================================= +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! DO L = 1, LLPAR +! AD44(I,J,DRYBCPI,1) = AD44(I,J,DRYBCPI,1) + ND44_TMP(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF + + ! Return to calling program + END SUBROUTINE CHEM_BCPI_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_OCPI_ADJ( TC_ADJ ) +! +!****************************************************************************** +! Subroutine CHEM_OCPI_ADJ calculates dry deposition of hydrophilic OC adjoint +! (dkh, 03/02/05) +! +! Based on forward code by (rjp, bmy, 4/1/04, 10/25/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) TC (REAL*8) : Array of hydrophilic BC tracer +! +! NOTES: +! (1 ) Based on CHEM_OPCI from forward model. The only differences are: +! i. Check if ABS( CNEW ) < SMALLNUM +! ii. Return if IDADJOPCI is 0 +! iii. Include ADJ_STT +! (2 ) Updated to include adjoint of OCPO --> OCPI. Comment out diagnostics +! from forward model. (dkh, 03/22/07) +! (4 ) Updated to GCv8 (dkh, 09/09/09) +! (5 ) BUG FIX: now declare BL_FRAC thread private (dkh, 07/30/10) +!****************************************************************************** +! + ! References to F90 modules + USE CARBON_MOD, ONLY : DRYOCPI + USE DAO_MOD, ONLY : AD + USE DIAG_MOD, ONLY : AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTOCPI + USE TIME_MOD, ONLY : GET_TS_CHEM + +# include "CMN_SIZE" ! Size parameters +!# include "CMN_DIAG" ! ND44 + + ! Arguments + REAL*8, INTENT(INOUT) :: TC_ADJ(IIPAR,JJPAR,LLPAR) + + ! Local variable + INTEGER :: I, J, L + REAL*8 :: DTCHEM, FLUX, BL_FRAC, AREA_CM2 + REAL*8 :: TC0_ADJ, CNEW_ADJ, CCV_ADJ, FREQ +! REAL*8 :: ND44_TMP(IIPAR,JJPAR,LLPAR) + + !================================================================= + ! CHEM_OCPI_ADJ begins here! + !================================================================= + IF ( IDTOCPI == 0 .or. DRYOCPI == 0 ) RETURN + + ! Chemistry timestep [s] + DTCHEM = GET_TS_CHEM() * 60d0 + +! ! Initialize for drydep diagnostic +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! ND44_TMP(I,J,L) = 0d0 +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF + + !================================================================= + ! Zero OCCONV_ADJ array for next timestep + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ! fwd code: + !OCCONV(I,J,L) = 0d0 + OCCONV_ADJ(I,J,L) = 0d0 + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! BUG FIX: BL_FRAC needs to be thread private (dkh, 07/30/10) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, TC0_ADJ, CCV_ADJ, FREQ, CNEW_ADJ ) +!$OMP+PRIVATE( AREA_CM2, FLUX ) +!$OMP+PRIVATE( BL_FRAC ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Store modified concentration back in tracer array [kg] + ! fwd code: + !TC(I,J,L) = CNEW + CNEW_ADJ = TC_ADJ(I,J,L) + + ! dkh -- don't take adjoint of this. It would require + ! recalculation of fwd CNEW -- probably not worth while. + ! Prevent underflow condition + !IF ( ABS( CNEW ) < SMALLNUM ) CNEW = 0d0 + + ! Fraction of grid box under the PBL top [unitless] + BL_FRAC = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! Only apply drydep to boxes w/in the PBL + IF ( BL_FRAC > 0d0 ) THEN + + ! Recalculate drydep frequency [1/s] + FREQ = DEPSAV(I,J,DRYOCPI) * BL_FRAC + + !=========================================================== + ! Note, This is an analytical solution of first order + ! partial differential equations (w/ 2 solutions): + ! + ! #1) CNEW = Cphi * exp(-RKT) + Cconv/RKT * (1.-exp(-RKT)) + ! #2) CNEW = ( Cphi + Cconv ) * exp(-RKT) + !=========================================================== + + ! dkh -- this was already commented out of fwd code + ! CNEW = TC0 * EXP( -FREQ * DTCHEM ) + ! + CCV / FREQ * ( 1.D0 - EXP( -FREQ * DTCHEM ) ) + + ! Amount of BCPI left after drydep [kg]D + ! fwd code: + !CNEW = ( TC0 + CCV ) * EXP( -FREQ * DTCHEM ) + TC0_ADJ = CNEW_ADJ * EXP( -FREQ * DTCHEM ) + ! adjoint code for CCV is: + ! CCV_ADJ = CNEW_ADJ * EXP( -FREQ * DTCHEM ) + ! same thing, except faster: + CCV_ADJ = TC0_ADJ + +! !=========================================================== +! ! ND44 diagnostic: drydep loss [atoms C/cm2/s] +! !=========================================================== +! IF ( ND44 > 0 ) THEN +! +! ! Surface area [cm2] +! AREA_CM2 = GET_AREA_CM2( J ) +! +! ! Convert drydep loss from [kg/timestep] to [atoms C/cm2/s] +! FLUX = ( TC0 + CCV - CNEW ) +! FLUX = FLUX * XNUMOL(IDTOCPI) / ( AREA_CM2 * DTCHEM ) +! +! ! Store in ND44_TMP as a placeholder +! ND44_TMP(I,J,L) = ND44_TMP(I,J,L) + FLUX +! ENDIF + + ELSE + + ! Otherwise, avoid doing the exponential + ! to preserve precision and clock cycles + ! fwd code: + !CNEW = TC0 + CCV + TC0_ADJ = CNEW_ADJ + CCV_ADJ = CNEW_ADJ + + ENDIF + + ! Initial H-philic OC [kg] + ! fwd code: + !TC0 = TC(I,J,L) + TC_ADJ(I,J,L) = TC0_ADJ + + ! H-philic OC that used to be H-phobic OC [kg] + ! fwd code: + !CCV = OCCONV(I,J,L) + OCCONV_ADJ(I,J,L) = CCV_ADJ + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + +! !================================================================= +! ! ND44: Sum drydep fluxes by level into the AD44 array in +! ! order to ensure that we get the same results w/ sp or mp +! !================================================================= +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! DO L = 1, LLPAR +! AD44(I,J,DRYOCPI,1) = AD44(I,J,DRYOCPI,1) + ND44_TMP(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF + + ! Return to calling program + END SUBROUTINE CHEM_OCPI_ADJ + + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_OCPO_ADJ( TC_ADJ ) +! +!****************************************************************************** +! Subroutine CHEM_OCPO_ADJ converts adjoint of hydrophobic OC to hydrophilic OC and +! calculates the dry deposition of hydrophobic OC. (dkh, 03/02/05) +! +! Based on forward model by (rjp, bmy, 4/1/04, 10/25/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) TC (REAL*8) : Array of hydrophobic OC tracer [kg] +! +! NOTES: +! (1 ) Based on CHEM_OCPO from forward model. The only differences are: +! i. Check if ABS( CNEW ) < SMALLNUM +! ii. Return if IDADJOCPO is 0 +! iii. Include ADJ_STT +! (2 ) Updated to include adjoint of OCPO --> OCPI. Comment out diagnostics +! from forward model. (dkh, 03/22/07) +! (3 ) Updated to GCv8 (dkh, 09/09/09) +!****************************************************************************** +! + ! References to F90 modules + USE CARBON_MOD, ONLY : DRYOCPO + USE DAO_MOD, ONLY : AD + USE DIAG_MOD, ONLY : AD44, AD07_OC + USE DRYDEP_MOD, ONLY : DEPSAV + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTOCPO + USE TIME_MOD, ONLY : GET_TS_CHEM + +# include "CMN_SIZE" ! Size parameters +!# include "CMN_DIAG" ! ND44, ND07, LD07 + + ! Arguments + REAL*8, INTENT(INOUT) :: TC_ADJ(IIPAR,JJPAR,LLPAR) + + ! Local variable + INTEGER :: I, J, L +! REAL*8 :: ND44_TMP(IIPAR,JJPAR,LLPAR) + REAL*8 :: DTCHEM, FLUX, KOC, BL_FRAC + REAL*8 :: TC0_ADJ, FREQ, CNEW_ADJ, RKT, AREA_CM2 + REAL*8, PARAMETER :: OC_LIFE = 1.15D0 + + !================================================================= + ! CHEM_OCPO_ADJ begins here! + !================================================================= + + ! Return if OCPO isn't defined + IF ( IDTOCPO == 0 .or. DRYOCPO == 0 ) RETURN + + ! Initialize + KOC = 1.D0 / ( 86400d0 * OC_LIFE ) + DTCHEM = GET_TS_CHEM() * 60d0 + + + !================================================================= + ! For tracers with dry deposition, the loss rate of dry dep is + ! combined in chem loss term. + ! + ! Conversion from hydrophobic to hydrophilic: + ! e-folding time 1.15 days + ! ---------------------------------------- + ! Use an e-folding time of 1.15 days or a convertion rate + ! of 1.0e-5 /sec. + ! Hydrophobic --> Hydrophilic, k = 1.0e-5 + ! Aerosols are dry-deposited, kd = DEPSAV (sec-1) + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, TC0_ADJ, FREQ, BL_FRAC, RKT ) +!$OMP+PRIVATE( CNEW_ADJ, AREA_CM2, FLUX ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Store modified OC concentration back in tracer array + ! fwd code: + !TC(I,J,L) = CNEW + CNEW_ADJ = TC_ADJ(I,J,L) + + ! Zero drydep freq + FREQ = 0d0 + + ! Fraction of box under the PBL top [unitless] + BL_FRAC = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! Only apply drydep to boxes w/in the PBL + IF ( BL_FRAC > 0d0 ) THEN + + ! OC drydep frequency [1/s] -- PBLFRAC accounts for the fraction + ! of each grid box (I,J,L) that is located beneath the PBL top + FREQ = DEPSAV(I,J,DRYOCPO) * BL_FRAC + + ENDIF + + ! Amount of OCPO converted to OCPI [kg/timestep] + ! fwd code: + !OCCONV(I,J,L) = ( TC0 - CNEW ) * KOC / ( KOC + FREQ ) + TC0_ADJ = OCCONV_ADJ(I,J,L) * KOC / ( KOC + FREQ ) + ! adjoint code is: + ! CNEW_ADJ = CNEW_ADJ - OCCONV_ADJ(I,J,L) * KOC / ( KOC + FREQ ) + ! same thing, except faster: + CNEW_ADJ = CNEW_ADJ - TC0_ADJ + + ! Amount of OCPO left after chemistry and drydep [kg] + RKT = ( KOC + FREQ ) * DTCHEM + ! fwd code: + !CNEW = TC0 * EXP( -RKT ) + TC0_ADJ = TC0_ADJ + CNEW_ADJ * EXP( -RKT ) + + ! dkh -- don't take adjoint of this + ! Prevent underflow condition + !IF ( ABS( CNEW ) < SMALLNUM ) CNEW = 0d0 + +! !============================================================== +! ! ND44 diagnostic: drydep loss [atoms C/cm2/s] +! !============================================================== +! IF ( ND44 > 0 .AND. FREQ > 0d0 ) THEN +! +! ! Surface area [cm2] +! AREA_CM2 = GET_AREA_CM2( J ) +! +! ! Convert drydep loss from [kg/timestep] to [atoms C/cm2/s] +! ! XNUMOL is the ratio [molec tracer/kg tracer] +! FLUX = TC0 - CNEW - OCCONV(I,J,L) +! FLUX = FLUX * XNUMOL(IDTOCPO) / ( DTCHEM * AREA_CM2 ) +! +! ! Store in ND44_TMP as a placeholder +! ND44_TMP(I,J,L) = ND44_TMP(I,J,L) + FLUX +! ENDIF +! +! !============================================================== +! ! ND07 diagnostic: H-Philic OC from H-phobic [kg/timestep] +! !============================================================== +! IF ( ND07 > 0 .and. L <= LD07 ) THEN +! AD07_OC(I,J,L) = AD07_OC(I,J,L) + OCCONV(I,J,L) +! ENDIF + + ! Initial OC [kg] + ! fwd code: + !TC0 = TC(I,J,L) + TC_ADJ(I,J,L) = TC0_ADJ + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + +! !================================================================= +! ! ND44: Sum drydep fluxes by level into the AD44 array in +! ! order to ensure that we get the same results w/ sp or mp +! !================================================================= +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! DO L = 1, LLPAR +! AD44(I,J,DRYOCPO,1) = AD44(I,J,DRYOCPO,1) + ND44_TMP(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! fwd code: + !OCCONV(I,J,L) = 0d0 + OCCONV_ADJ(I,J,L) = 0d0 + +! ! Initialize for drydep diagnostic +! IF ( ND44 > 0 ) ND44_TMP(I,J,L) = 0d0 + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE CHEM_OCPO_ADJ +!------------------------------------------------------------------------------ + + SUBROUTINE EMISSCARBON_ADJ +! +!****************************************************************************** +! Subroutine EMISSCARBON_ADJ is the adjoint of EMISSCARBON. (dkh, 04/26/06) + +! It is based on the forward model subroutine EMISSCARBON which is the interface +! between the GEOS-CHEM modeland the CARBONACEOUS AEROSOL emissions +! (rjp, bmy, 1/24/02, 9/25/06) +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 11/10/09) +! (2 ) Add LEMS_ABS option (dkh, 02/17/11) +!****************************************************************************** +! + ! References to F90 modules + USE DIAG_MOD, ONLY : AD07 + USE DAO_MOD, ONLY : PBL + USE ERROR_MOD, ONLY : DEBUG_MSG + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LSOA, LPRT + USE TIME_MOD, ONLY : GET_MONTH, ITS_A_NEW_MONTH + USE TRACER_MOD, ONLY : STT + USE GFED2_BIOMASS_MOD, ONLY : GFED2_IS_NEW + !USE TRACERID_MOD + + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EBCPI_an, IDADJ_EBCPO_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EOCPI_an, IDADJ_EOCPO_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EBCPI_bb, IDADJ_EBCPO_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EOCPI_bb, IDADJ_EOCPO_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EBCPI_bf, IDADJ_EBCPO_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EOCPI_bf, IDADJ_EOCPO_bf + USE ADJ_ARRAYS_MOD, ONLY : EMS_ADJ + USE CARBON_MOD, ONLY : ANTH_ORGC, ANTH_BLKC + USE CARBON_MOD, ONLY : BIOB_ORGC, BIOB_BLKC + USE CARBON_MOD, ONLY : BIOF_ORGC, BIOF_BLKC + USE CARBON_MOD, ONLY : BIOMASS_CARB_GEOS !lzhang + USE LOGICAL_ADJ_MOD, ONLY : LEMS_ABS + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND07 + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, MONTH, N + REAL*8 :: BCSRC_ADJ(IIPAR,JJPAR,2) + REAL*8 :: OCSRC_ADJ(IIPAR,JJPAR,2) + + !================================================================= + ! EMISSCARBON_ADJ begins here! + !================================================================= + !lzhang + + IF ( GFED2_IS_NEW() .or. ITS_A_NEW_MONTH() ) THEN + CALL BIOMASS_CARB_GEOS + IF ( LPRT ) CALL DEBUG_MSG('### EMISSCARB_ADJ: a BB_CRB_GEOS') + ENDIF + + ! fwd code: + !CALL EMITHIGH( BCSRC, OCSRC ) + ! adj code: + CALL EMITHIGH_ADJ( BCSRC_ADJ, OCSRC_ADJ ) + IF ( LPRT ) + & CALL DEBUG_MSG( '### EMISCARB_ADJ: after EMITHIGH_ADJ' ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! fwd code: + ! ! Total HYDROPHILIC BC source [kg] + ! BCSRC(I,J,1)= ANTH_BLKC(I,J,1) * EMS_SF(I,J,1,IDADJ_EBCPI_an) + ! + BIOF_BLKC(I,J,1) * EMS_SF(I,J,1,IDADJ_EBCPI_bf) + ! + BIOB_BLKC(I,J,1) * EMS_SF(I,J,1,IDADJ_EBCPI_bb) + ! adj code: + EMS_SF_ADJ(I,J,1,IDADJ_EBCPI_an) + & = EMS_SF_ADJ(I,J,1,IDADJ_EBCPI_an) + & + ANTH_BLKC(I,J,1) * BCSRC_ADJ(I,J,1) + + EMS_SF_ADJ(I,J,1,IDADJ_EBCPI_bf) + & = EMS_SF_ADJ(I,J,1,IDADJ_EBCPI_bf) + & + BIOF_BLKC(I,J,1) * BCSRC_ADJ(I,J,1) + + EMS_SF_ADJ(I,J,1,IDADJ_EBCPI_bb) + & = EMS_SF_ADJ(I,J,1,IDADJ_EBCPI_bb) + & + BIOB_BLKC(I,J,1) * BCSRC_ADJ(I,J,1) + + ! fwd code: + ! ! Total HYDROPHOBIC BC source [kg] + ! BCSRC(I,J,2)= ANTH_BLKC(I,J,2) * EMS_SF(I,J,1,IDADJ_EBCPI_an) + ! + BIOF_BLKC(I,J,2) * EMS_SF(I,J,1,IDADJ_EBCPO_bf) + ! + BIOB_BLKC(I,J,2) * EMS_SF(I,J,1,IDADJ_EBCPO_bb) + ! adj code: + EMS_SF_ADJ(I,J,1,IDADJ_EBCPO_an) + & = EMS_SF_ADJ(I,J,1,IDADJ_EBCPO_an) + & + ANTH_BLKC(I,J,2) * BCSRC_ADJ(I,J,2) + + EMS_SF_ADJ(I,J,1,IDADJ_EBCPO_bf) + & = EMS_SF_ADJ(I,J,1,IDADJ_EBCPO_bf) + & + BIOF_BLKC(I,J,2) * BCSRC_ADJ(I,J,2) + + EMS_SF_ADJ(I,J,1,IDADJ_EBCPO_bb) + & = EMS_SF_ADJ(I,J,1,IDADJ_EBCPO_bb) + & + BIOB_BLKC(I,J,2) * BCSRC_ADJ(I,J,2) + + IF ( LSOA ) THEN + + CALL ERROR_STOP('LSOA not supported yet', + & 'carbon_adj_mod.f') +! ! Total HYDROPHILIC OC source [kg] +! ! (Don't use archived TERP_ORGC if LSOA=T) +! OCSRC(I,J,1) = ANTH_ORGC(I,J,1) + +! & BIOF_ORGC(I,J,1) + +! & BIOB_ORGC(I,J,1) + + ELSE + + ! fwd code: + ! ! Total HYDROPHILIC OC source [kg] + ! (Use archived TERP_ORGC for if LSOA=F) + ! OCSRC(I,J,1) + ! = ANTH_ORGC(I,J,1) * EMS_SF(I,J,1,IDADJ_EOCPI_an) + ! + BIOF_ORGC(I,J,1) * EMS_SF(I,J,1,IDADJ_EOCPI_bf) + ! + BIOB_ORGC(I,J,1) * EMS_SF(I,J,1,IDADJ_EOCPI_bb) + ! + TERP_ORGC(I,J) + ! adj code: + EMS_SF_ADJ(I,J,1,IDADJ_EOCPI_an) + & = EMS_SF_ADJ(I,J,1,IDADJ_EOCPI_an) + & + ANTH_ORGC(I,J,1) * OCSRC_ADJ(I,J,1) + + EMS_SF_ADJ(I,J,1,IDADJ_EOCPI_bf) + & = EMS_SF_ADJ(I,J,1,IDADJ_EOCPI_bf) + & + BIOF_ORGC(I,J,1) * OCSRC_ADJ(I,J,1) + + EMS_SF_ADJ(I,J,1,IDADJ_EOCPI_bb) + & = EMS_SF_ADJ(I,J,1,IDADJ_EOCPI_bb) + & + BIOB_ORGC(I,J,1) * OCSRC_ADJ(I,J,1) + + ENDIF + + ! fwd code: + ! ! Total HYDROPHOBIC OC source [kg] + ! OCSRC(I,J,2) + ! = ANTH_ORGC(I,J,2) * EMS_SF(I,J,1,IDADJ_EOCPO_an) + ! + BIOF_ORGC(I,J,2) * EMS_SF(I,J,1,IDADJ_EOCPO_bf) + ! + BIOB_ORGC(I,J,2) * EMS_SF(I,J,1,IDADJ_EOCPO_bb) + ! adj code: + EMS_SF_ADJ(I,J,1,IDADJ_EOCPO_an) + & = EMS_SF_ADJ(I,J,1,IDADJ_EOCPO_an) + & + ANTH_ORGC(I,J,2) * OCSRC_ADJ(I,J,2) + + EMS_SF_ADJ(I,J,1,IDADJ_EOCPO_bf) + & = EMS_SF_ADJ(I,J,1,IDADJ_EOCPO_bf) + & + BIOF_ORGC(I,J,2) * OCSRC_ADJ(I,J,2) + + EMS_SF_ADJ(I,J,1,IDADJ_EOCPO_bb) + & = EMS_SF_ADJ(I,J,1,IDADJ_EOCPO_bb) + & + BIOB_ORGC(I,J,2) * OCSRC_ADJ(I,J,2) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Optional diagnostic -- also save out the emissions adjoints (dkh, 02/17/11) + ! (absolute sensitivities per emissions rather than per scaling factor) + IF ( LEMS_ABS ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! fwd code: + ! ! Total HYDROPHILIC BC source [kg] + ! BCSRC(I,J,1)= ANTH_BLKC(I,J,1) * EMS_SF(I,J,1,IDADJ_EBCPI_an) + ! + BIOF_BLKC(I,J,1) * EMS_SF(I,J,1,IDADJ_EBCPI_bf) + ! + BIOB_BLKC(I,J,1) * EMS_SF(I,J,1,IDADJ_EBCPI_bb) + ! adj code: + EMS_ADJ(I,J,1,IDADJ_EBCPI_an) + & = EMS_ADJ(I,J,1,IDADJ_EBCPI_an) + BCSRC_ADJ(I,J,1) + + EMS_ADJ(I,J,1,IDADJ_EBCPI_bf) + & = EMS_ADJ(I,J,1,IDADJ_EBCPI_bf) + BCSRC_ADJ(I,J,1) + + EMS_ADJ(I,J,1,IDADJ_EBCPI_bb) + & = EMS_ADJ(I,J,1,IDADJ_EBCPI_bb) + BCSRC_ADJ(I,J,1) + + ! fwd code: + ! ! Total HYDROPHOBIC BC source [kg] + ! BCSRC(I,J,2)= ANTH_BLKC(I,J,2) * EMS_SF(I,J,1,IDADJ_EBCPI_an) + ! + BIOF_BLKC(I,J,2) * EMS_SF(I,J,1,IDADJ_EBCPO_bf) + ! + BIOB_BLKC(I,J,2) * EMS_SF(I,J,1,IDADJ_EBCPO_bb) + ! adj code: + EMS_ADJ(I,J,1,IDADJ_EBCPO_an) + & = EMS_ADJ(I,J,1,IDADJ_EBCPO_an) + BCSRC_ADJ(I,J,2) + + EMS_ADJ(I,J,1,IDADJ_EBCPO_bf) + & = EMS_ADJ(I,J,1,IDADJ_EBCPO_bf) + BCSRC_ADJ(I,J,2) + + EMS_ADJ(I,J,1,IDADJ_EBCPO_bb) + & = EMS_ADJ(I,J,1,IDADJ_EBCPO_bb) + BCSRC_ADJ(I,J,2) + + IF ( LSOA ) THEN + + CALL ERROR_STOP('LSOA not supported yet', + & 'carbon_adj_mod.f') +! ! Total HYDROPHILIC OC source [kg] +! ! (Don't use archived TERP_ORGC if LSOA=T) +! OCSRC(I,J,1) = ANTH_ORGC(I,J,1) + +! & BIOF_ORGC(I,J,1) + +! & BIOB_ORGC(I,J,1) + + ELSE + + ! fwd code: + ! ! Total HYDROPHILIC OC source [kg] + ! (Use archived TERP_ORGC for if LSOA=F) + ! OCSRC(I,J,1) + ! = ANTH_ORGC(I,J,1) * EMS_SF(I,J,1,IDADJ_EOCPI_an) + ! + BIOF_ORGC(I,J,1) * EMS_SF(I,J,1,IDADJ_EOCPI_bf) + ! + BIOB_ORGC(I,J,1) * EMS_SF(I,J,1,IDADJ_EOCPI_bb) + ! + TERP_ORGC(I,J) + ! adj code: + EMS_ADJ(I,J,1,IDADJ_EOCPI_an) + & = EMS_ADJ(I,J,1,IDADJ_EOCPI_an) + OCSRC_ADJ(I,J,1) + + EMS_ADJ(I,J,1,IDADJ_EOCPI_bf) + & = EMS_ADJ(I,J,1,IDADJ_EOCPI_bf) + OCSRC_ADJ(I,J,1) + + EMS_ADJ(I,J,1,IDADJ_EOCPI_bb) + & = EMS_ADJ(I,J,1,IDADJ_EOCPI_bb) + OCSRC_ADJ(I,J,1) + + ENDIF + + ! fwd code: + ! ! Total HYDROPHOBIC OC source [kg] + ! OCSRC(I,J,2) + ! = ANTH_ORGC(I,J,2) * EMS_SF(I,J,1,IDADJ_EOCPO_an) + ! + BIOF_ORGC(I,J,2) * EMS_SF(I,J,1,IDADJ_EOCPO_bf) + ! + BIOB_ORGC(I,J,2) * EMS_SF(I,J,1,IDADJ_EOCPO_bb) + ! adj code: + EMS_ADJ(I,J,1,IDADJ_EOCPO_an) + & = EMS_ADJ(I,J,1,IDADJ_EOCPO_an) + OCSRC_ADJ(I,J,2) + + EMS_ADJ(I,J,1,IDADJ_EOCPO_bf) + & = EMS_ADJ(I,J,1,IDADJ_EOCPO_bf) + OCSRC_ADJ(I,J,2) + + EMS_ADJ(I,J,1,IDADJ_EOCPO_bb) + & = EMS_ADJ(I,J,1,IDADJ_EOCPO_bb) + OCSRC_ADJ(I,J,2) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ! Return to calling program + END SUBROUTINE EMISSCARBON_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE EMITHIGH_ADJ( BCSRC_ADJ, OCSRC_ADJ ) +! +!****************************************************************************** +! Subroutine EMITHIGH_ADJ is the adjoint of EMITHIGH (dkh, 04/26/06) +! +! Based on forward routine EMITHIGHT that mixes tracer completely from the +! surface to the PBL top. (rjp, bmy, 4/2/04, 2/17/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) BCSRC (REAL*8) : Array which holds Total BC (H-phobic & H-philic) +! (2 ) OCSRC (REAL*8) : Array which holds Total OC (H-phobic & H-philic) +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 11/11/09) +! (2 ) L Taken out of the OpenMP Loop (yd, 08/28/12) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ERROR_MOD, ONLY : ERROR_STOP + USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_MAX_L + USE TRACER_MOD, ONLY : STT + USE TRACERID_MOD, ONLY : IDTBCPI, IDTBCPO, IDTOCPI, IDTOCPO + USE TRACERID_MOD, ONLY : IDTALPH, IDTLIMO, IDTALCO + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*8, INTENT(OUT) :: BCSRC_ADJ(IIPAR,JJPAR,2) + REAL*8, INTENT(OUT) :: OCSRC_ADJ(IIPAR,JJPAR,2) + + ! Local variables + LOGICAL :: IS_BCPO, IS_OCPO, IS_BCPI, IS_OCPI + LOGICAL :: IS_ALPH, IS_LIMO, IS_ALCO + INTEGER :: I, J, L, PBL_MAX + REAL*8 :: F_OF_PBL + + !================================================================= + ! EMITHIGH_ADJ begins here! + !================================================================= + + ! initialize + BCSRC_ADJ = 0d0 + OCSRC_ADJ = 0d0 + + ! Define logical flags for expediency + IS_BCPI = ( IDTBCPI > 0 ) + IS_OCPI = ( IDTOCPI > 0 ) + IS_BCPO = ( IDTBCPO > 0 ) + IS_OCPO = ( IDTOCPO > 0 ) + IF ( IDTALPH > 0 ) + & CALL ERROR_STOP( 'ALPH not supported', 'carbon_adj_mod') + IF ( IDTLIMO > 0 ) + & CALL ERROR_STOP( 'LIMO not supported', 'carbon_adj_mod') + IF ( IDTALCO > 0 ) + & CALL ERROR_STOP( 'ALCO not supported', 'carbon_adj_mod') + + IF ( IS_OCPI .AND. IS_BCPI.AND.IS_BCPO.AND.IS_OCPO ) THEN !lzhang + ! Maximum extent of PBL [model levels] + PBL_MAX = GET_PBL_MAX_L() + + !================================================================= + ! Partition emissions throughout the boundary layer + !================================================================= + DO L = 1, PBL_MAX +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, F_OF_PBL ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Fraction of PBL spanned by grid box (I,J,L) [unitless] + F_OF_PBL = GET_FRAC_OF_PBL( I, J, L ) + + ! Hydrophilic BLACK CARBON +!ZL IF ( IS_BCPI ) THEN + ! fwd code: + !STT(I,J,L,IDTBCPI) = STT(I,J,L,IDTBCPI) + + ! ( F_OF_PBL * BCSRC(I,J,1) ) + ! adj code: + BCSRC_ADJ(I,J,1) = BCSRC_ADJ(I,J,1) + & + F_OF_PBL * STT_ADJ(I,J,L,IDTBCPI) + +!ZL ENDIF + + ! Hydrophilic ORGANIC CARBON +!ZL IF ( IS_OCPI ) THEN + ! fwd code: + !STT(I,J,L,IDTOCPI) = STT(I,J,L,IDTOCPI) + + ! ( F_OF_PBL * OCSRC(I,J,1) ) + ! adj code: + OCSRC_ADJ(I,J,1) = OCSRC_ADJ(I,J,1) + & + F_OF_PBL * STT_ADJ(I,J,L,IDTOCPI) +!ZL ENDIF + + ! Hydrophobic BLACK CARBON +!ZL IF ( IS_BCPO ) THEN + ! fwd code: + !STT(I,J,L,IDTBCPO) = STT(I,J,L,IDTBCPO) + + ! ( F_OF_PBL * BCSRC(I,J,2) ) + ! adj code: + BCSRC_ADJ(I,J,2) = BCSRC_ADJ(I,J,2) + & + F_OF_PBL * STT_ADJ(I,J,L,IDTBCPO) +!ZL ENDIF + + ! Hydrophobic ORGANIC CARBON +!ZL IF ( IS_OCPO ) THEN + ! fwd code: + !STT(I,J,L,IDTOCPO) = STT(I,J,L,IDTOCPO) + + ! ( F_OF_PBL * OCSRC(I,J,2) ) + ! adj code: + OCSRC_ADJ(I,J,2) = OCSRC_ADJ(I,J,2) + & + F_OF_PBL * STT_ADJ(I,J,L,IDTOCPO) +!ZL ENDIF + + ! remaining species not yet included in adjoint +! ! ALPHA-PINENE +! IF ( IS_ALPH ) THEN +! STT(I,J,L,IDTALPH) = STT(I,J,L,IDTALPH) + +! & ( F_OF_PBL * BIOG_ALPH(I,J) ) +! ENDIF +! +! ! LIMONENE +! IF ( IS_LIMO ) THEN +! STT(I,J,L,IDTLIMO) = STT(I,J,L,IDTLIMO) + +! & ( F_OF_PBL * BIOG_LIMO(I,J) ) +! +! ORVC_TERP(I,J,L) = ORVC_TERP(I,J,L) + +! & ( F_OF_PBL * BIOG_TERP(I,J) ) +! ENDIF +! +! ! ALCOHOL and SESQTERPENE (not a tracer) +! IF ( IS_ALCO ) THEN +! STT(I,J,L,IDTALCO) = STT(I,J,L,IDTALCO) + +! & ( F_OF_PBL * BIOG_ALCO(I,J) ) +! +! ORVC_SESQ(I,J,L) = ORVC_SESQ(I,J,L) + +! & ( F_OF_PBL * BIOG_SESQ(I,J) ) +! ENDIF + + ENDDO + ENDDO +!ZL ENDDO +!$OMP END PARALLEL DO + ENDDO + ENDIF !lzhang + ! Return to calling program + END SUBROUTINE EMITHIGH_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_CARBON_ADJ +! +!****************************************************************************** +! Subroutine INIT_CARBON_ADJ initializes all module arrays (rjp, bmy, 4/1/04) +! +! NOTES: +!****************************************************************************** + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: IS_INIT = .FALSE. + INTEGER :: AS + + !================================================================= + ! INIT_CARBON_ADJ begins here! + !================================================================= + + ! Return if we already allocated arrays + IF ( IS_INIT ) RETURN + + ALLOCATE( BCCONV_ADJ( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BCCONV_ADJ' ) + BCCONV_ADJ = 0d0 + + ALLOCATE( OCCONV_ADJ( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OCCONV_ADJ' ) + OCCONV_ADJ = 0d0 + + ! Reset IS_INIT + IS_INIT = .TRUE. + + ! Return to calling program + END SUBROUTINE INIT_CARBON_ADJ + +!------------------------------------------------------------------------------ + SUBROUTINE CLEANUP_CARBON_ADJ +! +!****************************************************************************** +! Subroutine CLEANUP_CARBON_ADJ deallocates all module arrays (rjp, bmy, 4/1/04) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_CARBON_ADJ begins here! + !================================================================= + IF ( ALLOCATED( BCCONV_ADJ ) ) DEALLOCATE( BCCONV_ADJ ) + IF ( ALLOCATED( OCCONV_ADJ ) ) DEALLOCATE( OCCONV_ADJ ) + + ! Return to calling program + END SUBROUTINE CLEANUP_CARBON_ADJ + +!------------------------------------------------------------------------------ + + + END MODULE CARBON_ADJ_MOD diff --git a/code/adjoint/checkpoint_mod.f b/code/adjoint/checkpoint_mod.f new file mode 100644 index 0000000..0128853 --- /dev/null +++ b/code/adjoint/checkpoint_mod.f @@ -0,0 +1,8484 @@ +! $Id: checkpoint_mod.f,v 1.6 2012/03/01 22:00:26 daven Exp $ + MODULE CHECKPOINT_MOD +! +!****************************************************************************** +! Module CHECKPOINT_MOD contains variables and routines which are used to read +! and write GEOS-CHEM restart files, which contain tracer concentrations +! in [v/v] mixing ratio. (bmy, 6/25/02, 12/16/05) +! +! Module Variables: +! ============================================================================ +! (1 ) INPUT_CHECKPOINT_FILE : Full path name of the restart file to be read +! (2 ) OUTPUT_CHECKPOINT_FILE : Full path name (w/ tokens!) of output file +! +! Module Routines: +! ============================================================================ +! (1 ) MAKE_CHECKPOINT_FILE : Writes restart file to disk +! (2 ) READ_CHECKPOINT_FILE : Reads restart file from disk +! (3 ) CONVERT_TRACER_TO_VV : Converts from [ppbv], [ppmv], etc to [v/v] +! (4 ) CHECK_DIMENSIONS : Ensures that restart file contains global data +! (5 ) COPY_STT : Converts [v/v] to [kg] and stores in STT +! (6 ) CHECK_DATA_BLOCKS : Makes sure we have read in data for each tracer +! (7 ) SET_CHECKPOINT : Gets restart filenames from "input_mod.f" +! +! GEOS-CHEM modules referenced by restart_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (2 ) error_mod.f : Module w/ NaN and other error check routines +! (3 ) file_mod.f : Module w/ file unit numbers and error checks +! (4 ) grid_mod.f : Module w/ horizontal grid information +! (5 ) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (6 ) time_mod.f : Module w/ routines for computing time & date +! (7 ) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc. +! +! NOTES: +! (1 ) Moved routines "make_restart_file.f"" and "read_restart_file.f" into +! this module. Also now internal routines to "read_restart_file.f" +! are now a part of this module. Now reference "file_mod.f" to get +! file unit numbers and error checking routines. (bmy, 6/25/02) +! (2 ) Now reference AD from "dao_mod.f". Now reference "error_mod.f". +! Also added minor bug fix for ALPHA platform. (bmy, 10/15/02) +! (3 ) Now references "grid_mod.f" and the new "time_mod.f" (bmy, 2/11/03) +! (4 ) Added error-check and cosmetic changes (bmy, 4/29/03) +! (5 ) Removed call to COPY_STT_FOR_OX, it's obsolete (bmy, 8/18/03) +! (6 ) Add fancy output (bmy, 4/26/04) +! (7 ) Added routine SET_CHECKPOINT. Now reference "logical_mod.f" and +! "tracer_mod.f" (bmy, 7/20/04) +! (8 ) Removed obsolete routines TRUE_TRACER_INDEX and COPY_DATA_FOR_CO_OH +! (bmy, 6/28/05) +! (9 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (10) Now pass TAU via the arg list in MAKE_CHECKPOINT_FILE (bmy, 12/15/05) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + CHARACTER(LEN=255) :: INPUT_CHECKPOINT_FILE + CHARACTER(LEN=255) :: OUTPUT_CHECKPOINT_FILE + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_CONVECTION_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +! +!****************************************************************************** +! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +! +! NOTES: +! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +! Y2K compliant string for all data sets. (bmy, 6/22/00) +! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +! BPCH2, and GET_MODELNAME for writing data to binary punch files. +! (bmy, 6/22/00) +! (3 ) Now do not write more than NTRACE data blocks to disk. +! Also updated comments. (bmy, 7/17/00) +! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +! restart file. (bmy, 6/24/02) +! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +! Now references function GET_TAU from "time_mod.f". Now added a call +! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +! (8 ) Cosmetic changes (bmy, 4/29/03) +! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +! remove hardwired output restart filename. Now references LPRT +! from "logical_mod.f". (bmy, 7/20/04) +! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +! grids. (bmy, 6/28/05) +! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (12) Add TAU to the argument list (bmy, 12/16/05) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME + USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE + USE DAO_MOD, ONLY : AD + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + REAL*8, INTENT(IN) :: TAU + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER :: HALFPOLAR + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + CHARACTER*10 :: SUFFIX1 + CHARACTER*1 :: SUFFIX2(4) + INTEGER :: T,MULT,IT,LT + REAL*8, PARAMETER :: SMALLNUM = 1d-12 + !================================================================= + ! MAKE_CHECKPOINT_FILE begins here! + !================================================================= + + WRITE (SUFFIX1,'(I8)')YYYYMMDD + + T = HHMMSS/100 + + DO IT = 1, 4 + LT = T-(T/10)*10 + WRITE (SUFFIX2(4-IT+1),'(I1)')LT + T = T/10 + END DO + + OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') + & //TRIM('CONV_CHK.')//TRIM(SUFFIX1)//TRIM('.') + & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) + & //TRIM(SUFFIX2(4)) + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM CHECKPOINT File: ' // + & 'Instantaneous Tracer Concentrations (v/v)' + UNIT = 'v/v' + CATEGORY = 'IJ-AVG-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Call GET_HALFPOLAR to return the proper value + ! for either GCAP or GEOS grids (bmy, 6/28/05) + HALFPOLAR = GET_HALFPOLAR() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the restart file for output -- binary punch format + !================================================================= + + ! Copy the output restart file name into a local variable + FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) + + ! Open restart file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each tracer to the restart file + !================================================================= + DO N = 1, N_TRACERS + + ! Convert from [kg] to [v/v] and store in the TRACER array +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,L) = STT(I,J,L,N) * TCVV(N) / AD(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Convert STT from [kg] to [v/v] mixing ratio + ! and store in temporary variable TRACER + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') + + + ! Return to calling program + END SUBROUTINE MAKE_CONVECTION_CHKFILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_CONVECTION_CHKFILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! NOTES: +! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +! Also reorganize some print statements (bmy, 10/25/99) +! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +! Y2K compliant string for all data sets. (bmy, 6/22/00) +! (5 ) Broke up sections of code into internal subroutines. Also updated +! comments & cleaned up a few things. (bmy, 7/17/00) +! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +! (10) Added updates from amf for tagged Ox run. Also updated comments +! and made some cosmetic changes (bmy, 7/3/01) +! (11) Bug fix: if starting from multiox restart file, then NTRACER +! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +! accordingly. (amf, bmy, 9/6/01) +! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +! (13) Updated comments (bmy, 1/25/02) +! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +! (17) Add fancy output string (bmy, 4/26/04) +! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +! and "tracer_mod.f" (bmy, 7/20/04) +! (19) Remove code for obsolete CO-OH simulation. Also remove references +! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +! (bmy, 6/24/05) +! (20) Updated comments (bmy, 12/16/05) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DAO_MOD, ONLY : AD + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_MOD, ONLY : LSPLIT, LPRT + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS, STT + USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + CHARACTER*10 :: SUFFIX1 + CHARACTER*1 :: SUFFIX2(4) + INTEGER :: T,MULT,IT,LT + + !================================================================= + ! READ_CHECKPOINT_FILE begins here! + !================================================================= + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open restart file and read top-of-file header + !================================================================= + + WRITE (SUFFIX1,'(I8)')YYYYMMDD + + T = HHMMSS/100 + + DO IT = 1, 4 + LT = T-(T/10)*10 + WRITE (SUFFIX2(4-IT+1),'(I1)')LT + T = T/10 + END DO + + INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') + & //TRIM('CONV_CHK.')//TRIM(SUFFIX1)//TRIM('.') + & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) + & //TRIM(SUFFIX2(4)) + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + ! Echo more output + WRITE( 6, 110 ) + 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', + & /, '(in volume mixing ratio units: v/v)' ) + + !================================================================= + ! Read concentrations -- store in the TRACER array + !================================================================= + DO + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process concentration data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-AVG-$' ) THEN + + ! Convert TRACER from [v/v] to [kg] and copy into STT array + CALL COPY_STT( NTRACER, TRACER, NCOUNT ) + + ENDIF + ENDDO + + !================================================================= + ! Examine data blocks, print totals, and return + !================================================================= + + ! Check for missing or duplicate data blocks + CALL CHECK_DATA_BLOCKS( N_TRACERS, NCOUNT ) + + ! Close file + CLOSE( IU_RST ) + + ! Print totals atmospheric mass for each tracer + WRITE( 6, 120 ) + 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') + + ! Return to calling program + END SUBROUTINE READ_CONVECTION_CHKFILE + +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_CHEMISTRY_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CHK, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Convert from [kg] to [v/v] and store in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ! Convert STT from [kg] to [v/v] mixing ratio +c$$$ ! and store in temporary variable TRACER +c$$$ CALL BPCH2_CHK( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_CHEMISTRY_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ + + SUBROUTINE READ_CHEMISTRY_CHKFILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine READ_CHEMISTRY_CHKFILE (ks, ???) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! NOTES: +! (1 ) Based on READ_RESTART_FILE +! (2 ) Updated for v8 adjoint (mak, dkh, 06/23/09) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DAO_MOD, ONLY : AD + USE DIRECTORY_ADJ_MOD,ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_MOD, ONLY : LSPLIT, LPRT + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS, STT + USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + CHARACTER*10 :: SUFFIX1 + CHARACTER*1 :: SUFFIX2(4) + INTEGER :: T,MULT,IT,LT + + !================================================================= + ! READ_CHEMISTRY_CHKFILE begins here! + !================================================================= + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open restart file and read top-of-file header + !================================================================= + + ! Use EXPAND_DATE instead of this (dkh, 06/23/09) +! WRITE (SUFFIX1,'(I8)')YYYYMMDD +! +! T = HHMMSS/100 +! +! DO IT = 1, 4 +! LT = T-(T/10)*10 +! WRITE (SUFFIX2(4-IT+1),'(I1)')LT +! T = T/10 +! END DO +! +! INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +! & //TRIM('CHEM_CHK.')//TRIM(SUFFIX1)//TRIM('.') +! & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +! & //TRIM(SUFFIX2(4)) + + INPUT_CHECKPOINT_FILE = TRIM('CHECK_CHK.YYYYMMDD.hhmm') + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + FILENAME = TRIM( ADJTMP_DIR ) + & // TRIM( FILENAME ) + + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C H E C K P O I N T F I L E I N P U T' + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_CHEMISTRY_CHKFILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + ! Echo more output + WRITE( 6, 110 ) + 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', + & /, '(in volume mixing ratio units: v/v)' ) + + !================================================================= + ! Read concentrations -- store in the TRACER array + !================================================================= + + DO + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_chemistry_chk:4') + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'readchemistry_chk:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + !------------------------------------------- + ! *****TESTING CHECKPOINTING***** + !------------------------------------------- + !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'readchemistry_chk:6') + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + CALL COPY_STT( NTRACER, TRACER, NCOUNT ) + + ENDDO + + !================================================================= + ! Examine data blocks, print totals, and return + !================================================================= + + ! Check for missing or duplicate data blocks + CALL CHECK_DATA_BLOCKS( N_TRACERS, NCOUNT ) + + ! Close file + CLOSE( IU_RST ) + + ! Print totals atmospheric mass for each tracer + WRITE( 6, 120 ) + 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + !### Debug + IF ( LPRT ) + & CALL DEBUG_MSG('### READ_CHEMISTRY_CHKFILE: read file') + + ! Return to calling program + END SUBROUTINE READ_CHEMISTRY_CHKFILE + +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_CHEMISTRY_CHKFILE_CSP1( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CSP, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ USE COMODE_MOD, ONLY : CSPEC +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$# include "comode.h" +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ INTEGER :: JLOOP,JJ, KK +c$$$ REAL*4 :: TRACER(ITLOOP,IGAS) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK_CSP1.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ !PRINT*,'ITLOOP, IGAS = ',ITLOOP,IGAS +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J ) +c$$$ DO J = 1, IGAS +c$$$ DO I = 1, ITLOOP +c$$$ ! Compute tracer concentration [molec/cm3/box] by +c$$$ ! looping over all species belonging to this tracer +c$$$ TRACER(I,J) = CSPEC(I,J) +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ +c$$$ CALL BPCH2_CSP( IU_RST, ITLOOP, IGAS, TRACER ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_CHEMISTRY_CHKFILE_CSP1 +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_CHEMISTRY_CHKFILE_CSP1( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +c$$$! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +c$$$! Also reorganize some print statements (bmy, 10/25/99) +c$$$! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +c$$$! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +c$$$! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (5 ) Broke up sections of code into internal subroutines. Also updated +c$$$! comments & cleaned up a few things. (bmy, 7/17/00) +c$$$! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +c$$$! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +c$$$! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +c$$$! (10) Added updates from amf for tagged Ox run. Also updated comments +c$$$! and made some cosmetic changes (bmy, 7/3/01) +c$$$! (11) Bug fix: if starting from multiox restart file, then NTRACER +c$$$! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +c$$$! accordingly. (amf, bmy, 9/6/01) +c$$$! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +c$$$! (13) Updated comments (bmy, 1/25/02) +c$$$! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +c$$$! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +c$$$! (17) Add fancy output string (bmy, 4/26/04) +c$$$! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +c$$$! and "tracer_mod.f" (bmy, 7/20/04) +c$$$! (19) Remove code for obsolete CO-OH simulation. Also remove references +c$$$! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +c$$$! (bmy, 6/24/05) +c$$$! (20) Updated comments (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ USE COMODE_MOD, ONLY : CSPEC, JLOP +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$# include "comode.h" +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR) +c$$$ REAL*4 :: TRACER(ITLOOP,IGAS) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK_CSP1.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & NI, NJ +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( TRACER(I,J), I=1,ITLOOP ), J=1,IGAS ) +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$ !============================================================== +c$$$ ! Assign data from the TRACER array to the STT array. +c$$$ !============================================================== +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J ) +c$$$ DO J = 1, IGAS +c$$$ DO I = 1, ITLOOP +c$$$ ! Compute tracer concentration [molec/cm3/box] by +c$$$ ! looping over all species belonging to this tracer +c$$$ CSPEC(I,J) = TRACER(I,J) +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_CHEMISTRY_CHKFILE_CSP1 +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_CHEMISTRY_CHKFILE_CSP2( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CSP, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ USE COMODE_MOD, ONLY : CSPEC +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$# include "comode.h" +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ INTEGER :: JLOOP,JJ, KK +c$$$ REAL*4 :: TRACER(ITLOOP,IGAS) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK_CSP2.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ !PRINT*,'ITLOOP, IGAS = ',ITLOOP,IGAS +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J ) +c$$$ DO J = 1, IGAS +c$$$ DO I = 1, ITLOOP +c$$$ ! Compute tracer concentration [molec/cm3/box] by +c$$$ ! looping over all species belonging to this tracer +c$$$ TRACER(I,J) = CSPEC(I,J) +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ +c$$$ CALL BPCH2_CSP( IU_RST, ITLOOP, IGAS, TRACER ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_CHEMISTRY_CHKFILE_CSP2 +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_CHEMISTRY_CHKFILE_CSP2( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +c$$$! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +c$$$! Also reorganize some print statements (bmy, 10/25/99) +c$$$! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +c$$$! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +c$$$! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (5 ) Broke up sections of code into internal subroutines. Also updated +c$$$! comments & cleaned up a few things. (bmy, 7/17/00) +c$$$! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +c$$$! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +c$$$! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +c$$$! (10) Added updates from amf for tagged Ox run. Also updated comments +c$$$! and made some cosmetic changes (bmy, 7/3/01) +c$$$! (11) Bug fix: if starting from multiox restart file, then NTRACER +c$$$! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +c$$$! accordingly. (amf, bmy, 9/6/01) +c$$$! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +c$$$! (13) Updated comments (bmy, 1/25/02) +c$$$! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +c$$$! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +c$$$! (17) Add fancy output string (bmy, 4/26/04) +c$$$! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +c$$$! and "tracer_mod.f" (bmy, 7/20/04) +c$$$! (19) Remove code for obsolete CO-OH simulation. Also remove references +c$$$! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +c$$$! (bmy, 6/24/05) +c$$$! (20) Updated comments (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ USE COMODE_MOD, ONLY : CSPEC, JLOP +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$# include "comode.h" +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR) +c$$$ REAL*4 :: TRACER(ITLOOP,IGAS) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK_CSP2.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & NI, NJ +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( TRACER(I,J), I=1,ITLOOP ), J=1,IGAS ) +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$ !============================================================== +c$$$ ! Assign data from the TRACER array to the STT array. +c$$$ !============================================================== +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J ) +c$$$ DO J = 1, IGAS +c$$$ DO I = 1, ITLOOP +c$$$ ! Compute tracer concentration [molec/cm3/box] by +c$$$ ! looping over all species belonging to this tracer +c$$$ CSPEC(I,J) = TRACER(I,J) +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_CHEMISTRY_CHKFILE_CSP2 +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE CONVERT_TRACER_TO_VV( NTRACER, TRACER, UNIT ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine CONVERT_TRACER_TO_VV converts the TRACER array from its +c$$$! natural units (e.g. ppbv, ppmv) as read from the restart file to v/v +c$$$! mixing ratio. (bmy, 6/25/02, 6/24/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) NTRACER (INTEGER) : Tracer number +c$$$! (2 ) TRACER (REAL*4 ) : Array containing tracer concentrations +c$$$! (3 ) UNIT (CHARACTER) : Unit of tracer as read in from restart file +c$$$! +c$$$! NOTES: +c$$$! (1 ) Added to "restart_mod.f". Can now also convert from ppm or ppmv +c$$$! to v/v mixing ratio. (bmy, 6/25/02) +c$$$! (2 ) Now reference GEOS_CHEM_STOP from "error_mod.f", which frees all +c$$$! allocated memory before stopping the run. (bmy, 10/15/02) +c$$$! (3 ) Remove obsolete reference to CMN (bmy, 6/24/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE CHARPAK_MOD, ONLY : TRANUC +c$$$ USE ERROR_MOD, ONLY : GEOS_CHEM_STOP +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: NTRACER +c$$$ REAL*8, INTENT(INOUT) :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=*), INTENT(IN) :: UNIT +c$$$ +c$$$ !================================================================= +c$$$ ! CONVERT_TRACER_TO_VV begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Convert UNIT to uppercase +c$$$ CALL TRANUC( UNIT ) +c$$$ +c$$$ ! Convert from the current unit to v/v +c$$$ SELECT CASE ( TRIM( UNIT ) ) +c$$$ +c$$$ CASE ( '', 'V/V' ) +c$$$ ! Do nothing, TRACER is already in v/v +c$$$ +c$$$ CASE ( 'PPM', 'PPMV', 'PPMC' ) +c$$$ TRACER = TRACER * 1d-6 +c$$$ +c$$$ CASE ( 'PPB', 'PPBV', 'PPBC' ) +c$$$ TRACER = TRACER * 1d-9 +c$$$ +c$$$ CASE ( 'PPT', 'PPTV', 'PPTC' ) +c$$$ TRACER = TRACER * 1d-12 +c$$$ +c$$$ CASE DEFAULT +c$$$ WRITE( 6, '(a)' ) 'Incompatible units in punch file!' +c$$$ WRITE( 6, '(a)' ) 'STOP in CONVERT_TRACER_TO_VV' +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ CALL GEOS_CHEM_STOP +c$$$ +c$$$ END SELECT +c$$$ +c$$$ ! Print the min & max of each tracer as it is read from the file +c$$$ WRITE( 6, 110 ) NTRACER, MINVAL( TRACER ), MAXVAL( TRACER ) +c$$$ 110 FORMAT( 'Tracer ', i3, ': Min = ', es12.5, ' Max = ', es12.5 ) +c$$$ +c$$$ ! Return to READ_CHECKPOINT_FILE +c$$$ END SUBROUTINE CONVERT_TRACER_TO_VV +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE CHECK_DIMENSIONS( NI, NJ, NL ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine CHECK_DIMENSIONS makes sure that the dimensions of the +c$$$! restart file extend to cover the entire grid. (bmy, 6/25/02, 10/15/02) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) NI (INTEGER) : Number of longitudes read from restart file +c$$$! (2 ) NJ (INTEGER) : Number of latitudes read from restart file +c$$$! (3 ) NL (INTEGER) : Numbef of levels read from restart file +c$$$! +c$$$! NOTES: +c$$$! (1 ) Added to "restart_mod.f". Now no longer allow initialization with +c$$$! less than a globally-sized data block. (bmy, 6/25/02) +c$$$! (2 ) Now reference GEOS_CHEM_STOP from "error_mod.f", which frees all +c$$$! allocated memory before stopping the run. (bmy, 10/15/02) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE ERROR_MOD, ONLY : GEOS_CHEM_STOP +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: NI, NJ, NL +c$$$ +c$$$# include "CMN_SIZE" +c$$$ +c$$$ !================================================================= +c$$$ ! CHECK_DIMENSIONS begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Error check longitude dimension: NI must equal IIPAR +c$$$ IF ( NI /= IIPAR ) THEN +c$$$ WRITE( 6, '(a)' ) 'ERROR reading in restart file!' +c$$$ WRITE( 6, '(a)' ) 'Wrong number of longitudes encountered!' +c$$$ WRITE( 6, '(a)' ) 'STOP in CHECK_DIMENSIONS (restart_mod.f)' +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ CALL GEOS_CHEM_STOP +c$$$ ENDIF +c$$$ +c$$$ ! Error check latitude dimension: NJ must equal JJPAR +c$$$ IF ( NJ /= JJPAR ) THEN +c$$$ WRITE( 6, '(a)' ) 'ERROR reading in restart file!' +c$$$ WRITE( 6, '(a)' ) 'Wrong number of latitudes encountered!' +c$$$ WRITE( 6, '(a)' ) 'STOP in CHECK_DIMENSIONS (restart_mod.f)' +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ CALL GEOS_CHEM_STOP +c$$$ ENDIF +c$$$ +c$$$ ! Error check vertical dimension: NL must equal LLPAR +c$$$ IF ( NL /= LLPAR ) THEN +c$$$ WRITE( 6, '(a)' ) 'ERROR reading in restart file!' +c$$$ WRITE( 6, '(a)' ) 'Wrong number of levels encountered!' +c$$$ WRITE( 6, '(a)' ) 'STOP in CHECK_DIMENSIONS (restart_mod.f)' +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ CALL GEOS_CHEM_STOP +c$$$ ENDIF +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE CHECK_DIMENSIONS +c$$$ +!------------------------------------------------------------------------------ + + SUBROUTINE COPY_STT( NTRACER, TRACER, NCOUNT ) +! +!****************************************************************************** +! Subroutine COPY_STT copies the results into the STT tracer array. +! (Kumaresh, 01/24/08) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTRACER (INTEGER) : Tracer number +! (2 ) NCOUNT (INTEGER) : Ctr array - # of data blocks read for each tracer +! (3 ) TRACER (REAL*4 ) : Tracer concentrations from restart file [v/v] +! +! NOTES: +! (1 ) Added to "restart_mod.f". Also added parallel loops. (bmy, 6/25/02) +! (2 ) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +! (3 ) Now exit if N is out of range (bmy, 4/29/03) +! (4 ) Now references N_TRACERS, STT & TCVV from "tracer_mod.f" (bmy, 7/20/04) +! (5 ) Remove call to TRUE_TRACER_INDEX (bmy, 6/24/05) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : AD + USE TRACER_MOD, ONLY : N_TRACERS, STT, TCVV + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: NTRACER + REAL*4, INTENT(IN) :: TRACER(IIPAR,JJPAR,LLPAR) + INTEGER, INTENT(INOUT) :: NCOUNT(NNPAR) + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! COPY_STT begins here! + !================================================================= + + ! Tracer number + N = NTRACER + + ! Exit if N is out of range + IF ( N < 1 .or. N > N_TRACERS ) RETURN + + ! store Tracers into GEOS-CHEM tracer arry +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + STT(I,J,L,N) = TRACER(I,J,L) * AD(I,J,L) / TCVV(N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Increment the # of records found for tracer N + NCOUNT(N) = NCOUNT(N) + 1 + + END SUBROUTINE COPY_STT + +!------------------------------------------------------------------------------ + + SUBROUTINE COPY_STT_TMP( NTRACER, TRACER, NCOUNT ) +! +!****************************************************************************** +! Subroutine COPY_STT copies the results into the STT tracer array. +! (Kumaresh, 01/24/08) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTRACER (INTEGER) : Tracer number +! (2 ) NCOUNT (INTEGER) : Ctr array - # of data blocks read for each tracer +! (3 ) TRACER (REAL*4 ) : Tracer concentrations from restart file [v/v] +! +! NOTES: +! (1 ) Added to "restart_mod.f". Also added parallel loops. (bmy, 6/25/02) +! (2 ) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +! (3 ) Now exit if N is out of range (bmy, 4/29/03) +! (4 ) Now references N_TRACERS, STT & TCVV from "tracer_mod.f" (bmy, 7/20/04) +! (5 ) Remove call to TRUE_TRACER_INDEX (bmy, 6/24/05) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : AD + USE TRACER_MOD, ONLY : N_TRACERS, STT_TMP, TCVV + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: NTRACER + REAL*4, INTENT(IN) :: TRACER(IIPAR,JJPAR,LLPAR) + INTEGER, INTENT(INOUT) :: NCOUNT(NNPAR) + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! COPY_STT begins here! + !================================================================= + + ! Tracer number + N = NTRACER + + ! Exit if N is out of range + IF ( N < 1 .or. N > N_TRACERS ) RETURN + + ! store Tracers into GEOS-CHEM tracer arry +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + STT_TMP(I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Increment the # of records found for tracer N + NCOUNT(N) = NCOUNT(N) + 1 + + END SUBROUTINE COPY_STT_TMP + +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE COPY_STT_ADJ( NTRACER, TRACER, NCOUNT ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine COPY_STT_ADJ converts tracer concetrations copies the results into +c$$$! the STT_ADJ tracer array. (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) NTRACER (INTEGER) : Tracer number +c$$$! (2 ) NCOUNT (INTEGER) : Ctr array - # of data blocks read for each tracer +c$$$! (3 ) TRACER (REAL*4 ) : Tracer concentrations from restart file [v/v] +c$$$! +c$$$! NOTES: +c$$$! (1 ) Added to "restart_mod.f". Also added parallel loops. (bmy, 6/25/02) +c$$$! (2 ) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +c$$$! (3 ) Now exit if N is out of range (bmy, 4/29/03) +c$$$! (4 ) Now references N_TRACERS, STT & TCVV from "tracer_mod.f" (bmy, 7/20/04) +c$$$! (5 ) Remove call to TRUE_TRACER_INDEX (bmy, 6/24/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT_ADJ, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: NTRACER +c$$$ REAL*8, INTENT(IN) :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ INTEGER, INTENT(INOUT) :: NCOUNT(NNPAR) +c$$$ +c$$$ ! Local variables +c$$$ INTEGER :: I, J, L, N +c$$$ +c$$$ !================================================================= +c$$$ ! COPY_STT_ADJ begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Tracer number +c$$$ N = NTRACER +c$$$ +c$$$ ! Exit if N is out of range +c$$$ IF ( N < 1 .or. N > N_TRACERS ) RETURN +c$$$ +c$$$ ! Store Tracer values in GEOS-CHEM tracers +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ STT_ADJ(I,J,L,N) = TRACER(I,J,L) !* AD(I,J,L) / TCVV(N) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ! Increment the # of records found for tracer N +c$$$ NCOUNT(N) = NCOUNT(N) + 1 +c$$$ +c$$$ END SUBROUTINE COPY_STT_ADJ +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE COPY_F( NTRACER, TRACER, NCOUNT ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine COPY_STT copies the results into the STT tracer array. +c$$$! (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) NTRACER (INTEGER) : Tracer number +c$$$! (2 ) NCOUNT (INTEGER) : Ctr array - # of data blocks read for each tracer +c$$$! (3 ) TRACER (REAL*4 ) : Tracer concentrations from restart file [v/v] +c$$$! +c$$$! NOTES: +c$$$! (1 ) Added to "restart_mod.f". Also added parallel loops. (bmy, 6/25/02) +c$$$! (2 ) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +c$$$! (3 ) Now exit if N is out of range (bmy, 4/29/03) +c$$$! (4 ) Now references N_TRACERS, STT & TCVV from "tracer_mod.f" (bmy, 7/20/04) +c$$$! (5 ) Remove call to TRUE_TRACER_INDEX (bmy, 6/24/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, F, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: NTRACER +c$$$ REAL*8, INTENT(IN) :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ INTEGER, INTENT(INOUT) :: NCOUNT(NNPAR) +c$$$ +c$$$ ! Local variables +c$$$ INTEGER :: I, J, L, N +c$$$ +c$$$ !================================================================= +c$$$ ! COPY_STT begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Tracer number +c$$$ N = NTRACER +c$$$ +c$$$ ! Exit if N is out of range +c$$$ IF ( N < 1 .or. N > N_TRACERS ) RETURN +c$$$ +c$$$ ! store Tracers into GEOS-CHEM tracer arry +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ F(I,J,L,N) = TRACER(I,J,L) !* AD(I,J,L) / TCVV(N) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ! Increment the # of records found for tracer N +c$$$ NCOUNT(N) = NCOUNT(N) + 1 +c$$$ +c$$$ END SUBROUTINE COPY_F +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_RRATE_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CSP, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ USE COMODE_MOD, ONLY : R_KPP +c$$$ USE gckpp_Global, ONLY : NTT, IND +c$$$ USE gckpp_Parameters +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ INTEGER :: JLOOP,JJ, KK +c$$$ REAL*4 :: TRACER(NTT,NREACT) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('RRATE_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ !PRINT*,'ITLOOP, IGAS = ',ITLOOP,IGAS +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J ) +c$$$ DO J = 1, NREACT +c$$$ DO I = 1, NTT +c$$$ ! Compute tracer concentration [molec/cm3/box] by +c$$$ ! looping over all species belonging to this tracer +c$$$ TRACER(I,J) = R_KPP(I,IND(J)) +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ +c$$$ CALL BPCH2_CSP( IU_RST, NTT, NREACT, TRACER ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_RRATE_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_RRATE_CHKFILE( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +c$$$! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +c$$$! Also reorganize some print statements (bmy, 10/25/99) +c$$$! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +c$$$! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +c$$$! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (5 ) Broke up sections of code into internal subroutines. Also updated +c$$$! comments & cleaned up a few things. (bmy, 7/17/00) +c$$$! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +c$$$! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +c$$$! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +c$$$! (10) Added updates from amf for tagged Ox run. Also updated comments +c$$$! and made some cosmetic changes (bmy, 7/3/01) +c$$$! (11) Bug fix: if starting from multiox restart file, then NTRACER +c$$$! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +c$$$! accordingly. (amf, bmy, 9/6/01) +c$$$! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +c$$$! (13) Updated comments (bmy, 1/25/02) +c$$$! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +c$$$! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +c$$$! (17) Add fancy output string (bmy, 4/26/04) +c$$$! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +c$$$! and "tracer_mod.f" (bmy, 7/20/04) +c$$$! (19) Remove code for obsolete CO-OH simulation. Also remove references +c$$$! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +c$$$! (bmy, 6/24/05) +c$$$! (20) Updated comments (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ USE COMODE_MOD, ONLY : R_KPP +c$$$ USE gckpp_Global +c$$$ USE gckpp_Parameters +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR) +c$$$ REAL*4 :: TRACER(NTT,NREACT) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: II, JJ +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('RRATE_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & II, JJ +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( TRACER(I,J), I=1,NTT ), J=1,NREACT ) +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$ !============================================================== +c$$$ ! Assign data from the TRACER array to the STT array. +c$$$ !============================================================== +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J ) +c$$$ DO J = 1, NREACT +c$$$ DO I = 1, NTT +c$$$ ! Compute tracer concentration [molec/cm3/box] by +c$$$ ! looping over all species belonging to this tracer +c$$$ R_KPP(I,IND(J)) = TRACER(I,J) +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_RRATE_CHKFILE +c$$$ +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_DATA_BLOCKS( NTRACE, NCOUNT ) +! +!****************************************************************************** +! Subroutine CHECK_DATA_BLOCKS checks to see if we have multiple or +! missing data blocks for a given tracer. (bmy, 6/25/02, 10/15/02) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTRACE (INTEGER) : Number of tracers +! (2 ) NCOUNT (INTEGER) : Ctr array - # of data blocks found per tracer +! +! NOTES: +! (1 ) Added to "restart_mod.f". Also now use F90 intrinsic REPEAT to +! write a long line of "="'s to the screen. (bmy, 6/25/02) +! (2 ) Now reference GEOS_CHEM_STOP from "error_mod.f", which frees all +! allocated memory before stopping the run. (bmy, 10/15/02) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE LOGICAL_MOD, ONLY : LLINOZ + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: NTRACE, NCOUNT(NNPAR) + + ! Local variables + INTEGER :: N + + !================================================================= + ! CHECK_DATA_BLOCKS begins here! + !================================================================= + + ! Loop over all tracers + DO N = 1, NTRACE + + ! Stop if a tracer has more than one data block + IF ( NCOUNT(N) > 1 ) THEN + WRITE( 6, 100 ) N + WRITE( 6, 120 ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ! Stop if a tracer has no data blocks + IF ( NCOUNT(N) == 0 ) THEN + WRITE( 6, 110 ) N + WRITE( 6, 120 ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + ENDDO + + ! FORMAT statements + 100 FORMAT( 'More than one record found for tracer : ', i4 ) + 110 FORMAT( 'No records found for tracer : ', i4 ) + 120 FORMAT( 'STOP in CHECK_DATA_BLOCKS (checkpoint_mod.f)' ) + + ! Return to calling program + END SUBROUTINE CHECK_DATA_BLOCKS + +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_ADJOINT_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT_ADJ, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ REAL*8, PARAMETER :: SMALLOX = 1d-6 +c$$$ REAL*8, PARAMETER :: SMALLNOX = 1d-8 +c$$$ REAL*8, PARAMETER :: SMALLCO = 1d-9 +c$$$ +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('ADJ.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_ADJ_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Convert from [kg] to [v/v] and store in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT_ADJ(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$c$$$ IF(N==1)THEN +c$$$c$$$ IF(STT_ADJ(I,J,L,N).ne.0d0) THEN +c$$$c$$$ IF( STT_ADJ(I,J,L,N) < SMALLNOX )THEN +c$$$c$$$ TRACER(I,J,L) = 0d0 +c$$$c$$$ ENDIF +c$$$c$$$ ENDIF +c$$$c$$$ ELSEIF(N==2)THEN +c$$$c$$$ IF(STT_ADJ(I,J,L,N).ne.0d0) THEN +c$$$c$$$ IF( STT_ADJ(I,J,L,N) < SMALLOX )THEN +c$$$c$$$ TRACER(I,J,L) = 0d0 +c$$$c$$$ ENDIF +c$$$c$$$ ENDIF +c$$$c$$$ ELSE +c$$$c$$$ IF(STT_ADJ(I,J,L,N).ne.0d0) THEN +c$$$c$$$ IF( STT_ADJ(I,J,L,N) < SMALLCO )THEN +c$$$c$$$ TRACER(I,J,L) = 0d0 +c$$$c$$$ ENDIF +c$$$c$$$ ENDIF +c$$$c$$$ ENDIF +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ! Convert STT from [kg] to [v/v] mixing ratio +c$$$ ! and store in temporary variable TRACER +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_ADJOINT_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_CHEMISTRY_CHKFILE_P( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHEMISTRY_CHKFILE_P creates GEOS-CHEM restart files of tracers +c$$$! in binary punch file format for perturbed chemistry concentrations. +c$$$! (Kumaresh, 01/24/08) +c$$$ +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CHK, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK_P.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Store GEOS-CHEM tracers in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2_CHK( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_CHEMISTRY_CHKFILE_P +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_CHEMISTRY_CHKFILE_P( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_CHEMISTRY_CHKFILE_P initializes GEOS-CHEM tracer concentrations +c$$$! from a binary punch file for perturbed chemistry concentrations. +c$$$! (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR) +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK_P.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ DO +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +c$$$ +c$$$ ! IOS < 0 is end-of-file, so exit +c$$$ IF ( IOS < 0 ) EXIT +c$$$ +c$$$ ! IOS > 0 is a real I/O error -- print error message +c$$$ IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:4' ) +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +c$$$ & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +c$$$ & NSKIP +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$ !============================================================== +c$$$ ! Assign data from the TRACER array to the STT array. +c$$$ !============================================================== +c$$$ CALL COPY_STT( NTRACER, TRACER, NCOUNT ) +c$$$ +c$$$ ENDDO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Check for missing or duplicate data blocks +c$$$ CALL CHECK_DATA_BLOCKS( N_TRACERS, NCOUNT ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_CHEMISTRY_CHKFILE_P +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_CHEMISTRY_CHKFILE_P1( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHEMISTRY_CHKFILE_P1 creates GEOS-CHEM restart files of tracers +c$$$! in binary punch file format for chemistry checkpoints of type1 information. +c$$$! (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CHK, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK_P1.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Store GEOS-CHEM tracers in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2_CHK( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_CHEMISTRY_CHKFILE_P1 +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_CHEMISTRY_CHKFILE_P1( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_CHEMISTRY_CHKFILE_P1 initializes GEOS-CHEM tracer concentrations +c$$$! from a binary punch file for chemistry checkpoints of type1 informations. +c$$$! (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR) +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK_P1.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ DO +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +c$$$ +c$$$ ! IOS < 0 is end-of-file, so exit +c$$$ IF ( IOS < 0 ) EXIT +c$$$ +c$$$ ! IOS > 0 is a real I/O error -- print error message +c$$$ IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:4' ) +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +c$$$ & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +c$$$ & NSKIP +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$ !============================================================== +c$$$ ! Assign data from the TRACER array to the STT array. +c$$$ !============================================================== +c$$$ CALL COPY_STT( NTRACER, TRACER, NCOUNT ) +c$$$ +c$$$ ENDDO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Check for missing or duplicate data blocks +c$$$ CALL CHECK_DATA_BLOCKS( N_TRACERS, NCOUNT ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_CHEMISTRY_CHKFILE_P1 +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_HSAVE_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_HSAVE_CHKFILE creates GEOS-CHEM restart files of KPP chemistry +c$$$! step size in binary punch file format. (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE COMODE_MOD, ONLY : IXSAVE, IYSAVE, IZSAVE, HSAVE_KPP +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ USE GCKPP_Global +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS, JJLOOP +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('HSAVE_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ N = 1 +c$$$ +c$$$ ! Store KPP Chemistry step size in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( JJLOOP ) +c$$$ DO JJLOOP = 1,NTT +c$$$ I = IXSAVE(JJLOOP) +c$$$ J = IYSAVE(JJLOOP) +c$$$ L = IZSAVE(JJLOOP) +c$$$ TRACER(I,J,L) = HSAVE_KPP(I,J,L) +c$$$ END DO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_HSAVE_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_HSAVE_CHKFILE( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_HSAVE_CHKFILE initializes GEOS-CHEM tracer concentrations +c$$$! from a binary punch file with KPP chemistry step size. (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ USE GCKPP_Global +c$$$ USE COMODE_MOD, ONLY : IXSAVE, IYSAVE, IZSAVE, HSAVE_KPP +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR), JJLOOP +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('HSAVE_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +c$$$ +c$$$ ! IOS > 0 is a real I/O error -- print error message +c$$$ IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:4' ) +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +c$$$ & NI, NJJ, NL, IFIRST, JFIRST, LFIRST, +c$$$ & NSKIP +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJJ ), L=1,NL ) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( JJLOOP ) +c$$$ DO JJLOOP = 1,NTT +c$$$ I = IXSAVE(JJLOOP) +c$$$ J = IYSAVE(JJLOOP) +c$$$ L = IZSAVE(JJLOOP) +c$$$ HSAVE_KPP(I,J,L) = TRACER(I,J,L) !* TCVV(N) / AD(I,J,L) +c$$$ END DO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_HSAVE_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_PART_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_HSAVE_CHKFILE creates GEOS-CHEM restart files of KPP chemistry +c$$$! step size in binary punch file format. (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE COMODE_MOD, ONLY : IXSAVE, IYSAVE, IZSAVE, PART_CASE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ USE GCKPP_Global +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS, JJLOOP +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('PART_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ N = 1 +c$$$ +c$$$ ! Store KPP Chemistry step size in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( JJLOOP ) +c$$$ DO JJLOOP = 1,NTT +c$$$ I = IXSAVE(JJLOOP) +c$$$ J = IYSAVE(JJLOOP) +c$$$ L = IZSAVE(JJLOOP) +c$$$ TRACER(I,J,L) = PART_CASE(JJLOOP) +c$$$ END DO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_PART_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_PART_CHKFILE( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_HSAVE_CHKFILE initializes GEOS-CHEM tracer concentrations +c$$$! from a binary punch file with KPP chemistry step size. (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ USE GCKPP_Global +c$$$ USE COMODE_MOD, ONLY : IXSAVE, IYSAVE, IZSAVE, PART_CASE +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR), JJLOOP +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('PART_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +c$$$ +c$$$ ! IOS > 0 is a real I/O error -- print error message +c$$$ IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:4' ) +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +c$$$ & NI, NJJ, NL, IFIRST, JFIRST, LFIRST, +c$$$ & NSKIP +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJJ ), L=1,NL ) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( JJLOOP ) +c$$$ DO JJLOOP = 1,NTT +c$$$ I = IXSAVE(JJLOOP) +c$$$ J = IYSAVE(JJLOOP) +c$$$ L = IZSAVE(JJLOOP) +c$$$ PART_CASE(JJLOOP) = TRACER(I,J,L) !* TCVV(N) / AD(I,J,L) +c$$$ END DO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_PART_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_CHEMISTRY_CHKFILE_P2( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHEMISTRY_CHKFILE_P3 creates GEOS-CHEM restart files of tracers +c$$$! in binary punch file format. Used to checkpoint tracers for type2 information +c$$$! (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK_P2.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Store GEOS-CHEM tracers in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_CHEMISTRY_CHKFILE_P2 +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_CHEMISTRY_CHKFILE_P3( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHEMISTRY_CHKFILE_P3 creates GEOS-CHEM restart files of tracers +c$$$! in binary punch file format. Used to checkpoint tracers for type3 information +c$$$! (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CHEM_CHK_P3.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! store GEOS-CHEM tracer in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_CHEMISTRY_CHKFILE_P3 +c$$$ +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_PRESSURE_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +! +!****************************************************************************** +! Subroutine MAKE_PRESSURE_CHKFILE make pressure checkpoint file. +! Originally from v7 adj (ks), updated (dkh, 03/07/10) +! +! Based on fwd model code MAKE_RESTART_FILE +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME + USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE + USE DAO_MOD, ONLY : AD + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV, TMP_PRESS + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + REAL*8, INTENT(IN) :: TAU + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + INTEGER :: JLOOP,JJ, KK + REAL*4 :: TRACER(IIPAR,JJPAR,1) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER :: HALFPOLAR + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + CHARACTER*10 :: SUFFIX1 + CHARACTER*1 :: SUFFIX2(4) + INTEGER :: T,MULT,IT,LT + !================================================================= + ! MAKE_PRESSURE_CHKFILE begins here! + !================================================================= + +! v7 adj kludge +! WRITE (SUFFIX1,'(I8)')YYYYMMDD +! +! T = HHMMSS/100 +! +! DO IT = 1, 4 +! LT = T-(T/10)*10 +! WRITE (SUFFIX2(4-IT+1),'(I1)')LT +! T = T/10 +! END DO +! +! OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +! & //TRIM('PRESS_CHK.')//TRIM(SUFFIX1)//TRIM('.') +! & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +! & //TRIM(SUFFIX2(4)) + + OUTPUT_CHECKPOINT_FILE = TRIM('press.chk.YYYYMMDD.hhmm') + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM CHECKPOINT File: ' + CATEGORY = 'IJ-CHK-$' + LONRES = DISIZE + LATRES = DJSIZE + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + UNIT = 'hPa' + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + + !================================================================= + ! Open the restart file for output -- binary punch format + !================================================================= + + ! Copy the output restart file name into a local variable + FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_PRESSURE_CHKFILE: Writing ', a ) + + ! Open restart file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each tracer to the restart file + !================================================================= + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + ! Compute tracer concentration [molec/cm3/box] by + ! looping over all species belonging to this tracer + TRACER(I,J,1) = TMP_PRESS(I,J) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER ) + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT )CALL DEBUG_MSG('### MAKE_PRESSURE_CHKFILE: wrote file') + + + ! Return to calling program + END SUBROUTINE MAKE_PRESSURE_CHKFILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_PRESSURE_CHKFILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine READ_PRESSURE_CHKFILE reads PRESS_CHK files. +! (ks, 2008; dkh, 03/07/10) +! +! Based on READ_RESTART_FILE from fwd model +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! NOTES: +! (1 ) Now remove files after they have been read (dkh, 05/02/10) +! (2 ) Now delete the press.chk.* files after reading (dkh, 05/02/10) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DAO_MOD, ONLY : AD + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_MOD, ONLY : LSPLIT, LPRT + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS, STT, TMP_PRESS + USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G + USE COMODE_MOD, ONLY : JLOP + USE UNIX_CMDS_MOD, ONLY : REMOVE_CMD + + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,1) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + CHARACTER*10 :: SUFFIX1 + CHARACTER*1 :: SUFFIX2(4) + INTEGER :: T,MULT,IT,LT + + !================================================================= + ! READ_PRESSURE_CHKFILE begins here! + !================================================================= + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open restart file and read top-of-file header + !================================================================= + + ! v7 adjoint kludge +! WRITE (SUFFIX1,'(I8)')YYYYMMDD +! +! T = HHMMSS/100 +! +! DO IT = 1, 4 +! LT = T-(T/10)*10 +! WRITE (SUFFIX2(4-IT+1),'(I1)')LT +! T = T/10 +! END DO +! +! INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +! & //TRIM('PRESS_CHK.')//TRIM(SUFFIX1)//TRIM('.') +! & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +! & //TRIM(SUFFIX2(4)) + + INPUT_CHECKPOINT_FILE = TRIM('press.chk.YYYYMMDD.hhmm') + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Echo some input to the screen + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + +! ! Echo more output +! WRITE( 6, 110 ) +! 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +! & /, '(in volume mixing ratio units: v/v)' ) + + !================================================================= + ! Read concentrations -- store in the TRACER array + !================================================================= + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'READ_PRESSURE_CHKFILE:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'READ_PRESSURE_CHKFILE:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'READ_PRESSURE_CHKFILE:6') + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + ! Compute tracer concentration [molec/cm3/box] by + ! looping over all species belonging to this tracer + TMP_PRESS(I,J) = TRACER(I,J,1) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Examine data blocks, print totals, and return + !================================================================= + + ! Close file + CLOSE( IU_RST ) + + + ! Remove files if L_CHK_DEL = TRUE + IF ( LDEL_CHKPT ) THEN + + REMOVE_CHK_FILE_CMD = TRIM ( REMOVE_CMD ) // ' ' // + & TRIM ( FILENAME ) + + CALL SYSTEM( TRIM( REMOVE_CHK_FILE_CMD ) ) + + WRITE( 6, 102 ) TRIM( REMOVE_CHK_FILE_CMD ) + 102 FORMAT( ' - READ_PRESSURE_CHKFILE: Executing: ',a ) + + ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG('### READ_PRESSURE_CHKFILE: read file') + + ! Return to calling program + END SUBROUTINE READ_PRESSURE_CHKFILE + +! now obsolete (dkh, 03/07/10) +!!------------------------------------------------------------------------------ +! +! SUBROUTINE MAKE_FPBL_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +!! +!!****************************************************************************** +!! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +!! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) YYYYMMDD : Year-Month-Date +!! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +!! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +!! +!! NOTES: +!! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +!! Y2K compliant string for all data sets. (bmy, 6/22/00) +!! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +!! BPCH2, and GET_MODELNAME for writing data to binary punch files. +!! (bmy, 6/22/00) +!! (3 ) Now do not write more than NTRACE data blocks to disk. +!! Also updated comments. (bmy, 7/17/00) +!! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +!! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +!! restart file. (bmy, 6/24/02) +!! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +!! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +!! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +!! Now references function GET_TAU from "time_mod.f". Now added a call +!! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +!! (8 ) Cosmetic changes (bmy, 4/29/03) +!! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +!! remove hardwired output restart filename. Now references LPRT +!! from "logical_mod.f". (bmy, 7/20/04) +!! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +!! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +!! grids. (bmy, 6/28/05) +!! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (12) Add TAU to the argument list (bmy, 12/16/05) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : BPCH2_CSP, GET_MODELNAME +! USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +! USE DAO_MOD, ONLY : AD +! USE ERROR_MOD, ONLY : DEBUG_MSG +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE LOGICAL_MOD, ONLY : LPRT +! USE TIME_MOD, ONLY : EXPAND_DATE +! USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV, FP +! +!# include "CMN_SIZE" ! Size parameters +!# include "comode.h" +! +! ! Arguments +! INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +! REAL*8, INTENT(IN) :: TAU +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, N +! INTEGER :: YYYY, MM, DD, HH, SS +! INTEGER :: JLOOP,JJ, KK +! REAL*4 :: TRACER(IIPAR,JJPAR) +! CHARACTER(LEN=255) :: FILENAME +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER :: HALFPOLAR +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! CHARACTER*10 :: SUFFIX1 +! CHARACTER*1 :: SUFFIX2(4) +! INTEGER :: T,MULT,IT,LT +! !================================================================= +! ! MAKE_CHECKPOINT_FILE begins here! +! !================================================================= +! +! WRITE (SUFFIX1,'(I8)')YYYYMMDD +! +! T = HHMMSS/100 +! +! DO IT = 1, 4 +! LT = T-(T/10)*10 +! WRITE (SUFFIX2(4-IT+1),'(I1)')LT +! T = T/10 +! END DO +! +! OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +! & //TRIM('FPBL_CHK.')//TRIM(SUFFIX1)//TRIM('.') +! & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +! & //TRIM(SUFFIX2(4)) +! +! !PRINT*,'ITLOOP, IGAS = ',ITLOOP,IGAS +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +! & 'Instantaneous Tracer Concentrations (v/v)' +! !================================================================= +! ! Open the restart file for output -- binary punch format +! !================================================================= +! +! ! Copy the output restart file name into a local variable +! FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +! +! ! Open restart file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +! !================================================================= +! ! Write each tracer to the restart file +! !================================================================= +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! ! Compute tracer concentration [molec/cm3/box] by +! ! looping over all species belonging to this tracer +! TRACER(I,J) = FP(I,J) +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! !------------------------------------------- +! ! *****TESTING CHECKPOINTING***** +! !------------------------------------------- +! +! CALL BPCH2_CSP( IU_RST, IIPAR, JJPAR, TRACER ) +! +! ! Close file +! CLOSE( IU_RST ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +! +! +! ! Return to calling program +! END SUBROUTINE MAKE_FPBL_CHKFILE +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_FPBL_CHKFILE( YYYYMMDD, HHMMSS ) +!! +!!****************************************************************************** +!! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +!! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +!! +!! Arguments as input: +!! ============================================================================ +!! (1 ) YYYYMMDD : Year-Month-Day +!! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +!! +!! NOTES: +!! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +!! Also reorganize some print statements (bmy, 10/25/99) +!! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +!! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +!! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +!! Y2K compliant string for all data sets. (bmy, 6/22/00) +!! (5 ) Broke up sections of code into internal subroutines. Also updated +!! comments & cleaned up a few things. (bmy, 7/17/00) +!! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +!! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +!! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +!! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +!! (10) Added updates from amf for tagged Ox run. Also updated comments +!! and made some cosmetic changes (bmy, 7/3/01) +!! (11) Bug fix: if starting from multiox restart file, then NTRACER +!! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +!! accordingly. (amf, bmy, 9/6/01) +!! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +!! (13) Updated comments (bmy, 1/25/02) +!! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +!! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +!! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +!! (17) Add fancy output string (bmy, 4/26/04) +!! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +!! and "tracer_mod.f" (bmy, 7/20/04) +!! (19) Remove code for obsolete CO-OH simulation. Also remove references +!! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +!! (bmy, 6/24/05) +!! (20) Updated comments (bmy, 12/16/05) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +! USE DAO_MOD, ONLY : AD +! USE ERROR_MOD, ONLY : DEBUG_MSG +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +! USE TIME_MOD, ONLY : EXPAND_DATE +! USE TRACER_MOD, ONLY : N_TRACERS +! USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G, FP +! USE COMODE_MOD, ONLY : JLOP +! +!# include "CMN_SIZE" ! Size parameters +!# include "comode.h" +! +! ! Arguments +! INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +! +! ! Local Variables +! INTEGER :: I, IOS, J, L, N +! INTEGER :: NCOUNT(NNPAR) +! REAL*4 :: TRACER(IIPAR,JJPAR) +! REAL*8 :: SUMTC +! CHARACTER(LEN=255) :: FILENAME +! +! ! For binary punch file, version 2.0 +! INTEGER :: NI, NJ, NL +! INTEGER :: IFIRST, JFIRST, LFIRST +! INTEGER :: NTRACER, NSKIP +! INTEGER :: HALFPOLAR, CENTER180 +! REAL*4 :: LONRES, LATRES +! REAL*8 :: ZTAU0, ZTAU1 +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED +! CHARACTER*10 :: SUFFIX1 +! CHARACTER*1 :: SUFFIX2(4) +! INTEGER :: T,MULT,IT,LT +! +! !================================================================= +! ! READ_CHECKPOINT_FILE begins here! +! !================================================================= +! +! ! Initialize some variables +! NCOUNT(:) = 0 +! TRACER(:,:) = 0e0 +! +! !================================================================= +! ! Open restart file and read top-of-file header +! !================================================================= +! +! WRITE (SUFFIX1,'(I8)')YYYYMMDD +! +! T = HHMMSS/100 +! +! DO IT = 1, 4 +! LT = T-(T/10)*10 +! WRITE (SUFFIX2(4-IT+1),'(I1)')LT +! T = T/10 +! END DO +! +! INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +! & //TRIM('FPBL_CHK.')//TRIM(SUFFIX1)//TRIM('.') +! & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +! & //TRIM(SUFFIX2(4)) +! +! ! Copy input file name to a local variable +! FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +! +! ! Echo some input to the screen +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +! +! ! Open the binary punch file for input +! CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +! +! ! Echo more output +! WRITE( 6, 110 ) +! 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +! & /, '(in volume mixing ratio units: v/v)' ) +! +! !================================================================= +! ! Read concentrations -- store in the TRACER array +! !================================================================= +! +! READ( IU_RST, IOSTAT=IOS ) +! & NI, NJ +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( TRACER(I,J), I=1,IIPAR ), J=1,JJPAR ) +! +! !------------------------------------------- +! ! *****TESTING CHECKPOINTING***** +! !------------------------------------------- +! !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! ! Compute tracer concentration [molec/cm3/box] by +! ! looping over all species belonging to this tracer +! FP(I,J) = TRACER(I,J) +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! !================================================================= +! ! Examine data blocks, print totals, and return +! !================================================================= +! +! ! Close file +! CLOSE( IU_RST ) +! +! ! Print totals atmospheric mass for each tracer +! WRITE( 6, 120 ) +! 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +! +! ! Fancy output +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +! +! ! Return to calling program +! END SUBROUTINE READ_FPBL_CHKFILE +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE MAKE_IMIX_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +!! +!!****************************************************************************** +!! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +!! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) YYYYMMDD : Year-Month-Date +!! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +!! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +!! +!! NOTES: +!! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +!! Y2K compliant string for all data sets. (bmy, 6/22/00) +!! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +!! BPCH2, and GET_MODELNAME for writing data to binary punch files. +!! (bmy, 6/22/00) +!! (3 ) Now do not write more than NTRACE data blocks to disk. +!! Also updated comments. (bmy, 7/17/00) +!! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +!! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +!! restart file. (bmy, 6/24/02) +!! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +!! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +!! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +!! Now references function GET_TAU from "time_mod.f". Now added a call +!! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +!! (8 ) Cosmetic changes (bmy, 4/29/03) +!! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +!! remove hardwired output restart filename. Now references LPRT +!! from "logical_mod.f". (bmy, 7/20/04) +!! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +!! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +!! grids. (bmy, 6/28/05) +!! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (12) Add TAU to the argument list (bmy, 12/16/05) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : BPCH2_INT, GET_MODELNAME +! USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +! USE DAO_MOD, ONLY : AD +! USE ERROR_MOD, ONLY : DEBUG_MSG +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE LOGICAL_MOD, ONLY : LPRT +! USE TIME_MOD, ONLY : EXPAND_DATE +! USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV, IM +! +!# include "CMN_SIZE" ! Size parameters +!# include "comode.h" +! +! ! Arguments +! INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +! REAL*8, INTENT(IN) :: TAU +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, N +! INTEGER :: YYYY, MM, DD, HH, SS +! INTEGER :: JLOOP,JJ, KK +! INTEGER :: TRACER(IIPAR,JJPAR) +! CHARACTER(LEN=255) :: FILENAME +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER :: HALFPOLAR +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! CHARACTER*10 :: SUFFIX1 +! CHARACTER*1 :: SUFFIX2(4) +! INTEGER :: T,MULT,IT,LT +! !================================================================= +! ! MAKE_CHECKPOINT_FILE begins here! +! !================================================================= +! +! WRITE (SUFFIX1,'(I8)')YYYYMMDD +! +! T = HHMMSS/100 +! +! DO IT = 1, 4 +! LT = T-(T/10)*10 +! WRITE (SUFFIX2(4-IT+1),'(I1)')LT +! T = T/10 +! END DO +! +! OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +! & //TRIM('IMIX_CHK.')//TRIM(SUFFIX1)//TRIM('.') +! & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +! & //TRIM(SUFFIX2(4)) +! +! !PRINT*,'ITLOOP, IGAS = ',ITLOOP,IGAS +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +! & 'Instantaneous Tracer Concentrations (v/v)' +! !================================================================= +! ! Open the restart file for output -- binary punch format +! !================================================================= +! +! ! Copy the output restart file name into a local variable +! FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +! +! ! Open restart file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +! !================================================================= +! ! Write each tracer to the restart file +! !================================================================= +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! ! Compute tracer concentration [molec/cm3/box] by +! ! looping over all species belonging to this tracer +! TRACER(I,J) = IM(I,J) +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! !------------------------------------------- +! ! *****TESTING CHECKPOINTING***** +! !------------------------------------------- +! +! CALL BPCH2_INT( IU_RST, IIPAR, JJPAR, TRACER ) +! +! ! Close file +! CLOSE( IU_RST ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +! +! +! ! Return to calling program +! END SUBROUTINE MAKE_IMIX_CHKFILE +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_IMIX_CHKFILE( YYYYMMDD, HHMMSS ) +!! +!!****************************************************************************** +!! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +!! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +!! +!! Arguments as input: +!! ============================================================================ +!! (1 ) YYYYMMDD : Year-Month-Day +!! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +!! +!! NOTES: +!! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +!! Also reorganize some print statements (bmy, 10/25/99) +!! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +!! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +!! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +!! Y2K compliant string for all data sets. (bmy, 6/22/00) +!! (5 ) Broke up sections of code into internal subroutines. Also updated +!! comments & cleaned up a few things. (bmy, 7/17/00) +!! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +!! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +!! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +!! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +!! (10) Added updates from amf for tagged Ox run. Also updated comments +!! and made some cosmetic changes (bmy, 7/3/01) +!! (11) Bug fix: if starting from multiox restart file, then NTRACER +!! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +!! accordingly. (amf, bmy, 9/6/01) +!! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +!! (13) Updated comments (bmy, 1/25/02) +!! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +!! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +!! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +!! (17) Add fancy output string (bmy, 4/26/04) +!! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +!! and "tracer_mod.f" (bmy, 7/20/04) +!! (19) Remove code for obsolete CO-OH simulation. Also remove references +!! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +!! (bmy, 6/24/05) +!! (20) Updated comments (bmy, 12/16/05) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +! USE DAO_MOD, ONLY : AD +! USE ERROR_MOD, ONLY : DEBUG_MSG +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +! USE TIME_MOD, ONLY : EXPAND_DATE +! USE TRACER_MOD, ONLY : N_TRACERS +! USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G, IM +! USE COMODE_MOD, ONLY : JLOP +! +!# include "CMN_SIZE" ! Size parameters +!# include "comode.h" +! +! ! Arguments +! INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +! +! ! Local Variables +! INTEGER :: I, IOS, J, L, N +! INTEGER :: NCOUNT(NNPAR) +! INTEGER :: TRACER(IIPAR,JJPAR) +! REAL*8 :: SUMTC +! CHARACTER(LEN=255) :: FILENAME +! +! ! For binary punch file, version 2.0 +! INTEGER :: NI, NJ, NL +! INTEGER :: IFIRST, JFIRST, LFIRST +! INTEGER :: NTRACER, NSKIP +! INTEGER :: HALFPOLAR, CENTER180 +! REAL*4 :: LONRES, LATRES +! REAL*8 :: ZTAU0, ZTAU1 +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED +! CHARACTER*10 :: SUFFIX1 +! CHARACTER*1 :: SUFFIX2(4) +! INTEGER :: T,MULT,IT,LT +! +! !================================================================= +! ! READ_CHECKPOINT_FILE begins here! +! !================================================================= +! +! ! Initialize some variables +! NCOUNT(:) = 0 +! TRACER(:,:) = 0 +! +! !================================================================= +! ! Open restart file and read top-of-file header +! !================================================================= +! +! WRITE (SUFFIX1,'(I8)')YYYYMMDD +! +! T = HHMMSS/100 +! +! DO IT = 1, 4 +! LT = T-(T/10)*10 +! WRITE (SUFFIX2(4-IT+1),'(I1)')LT +! T = T/10 +! END DO +! +! INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +! & //TRIM('IMIX_CHK.')//TRIM(SUFFIX1)//TRIM('.') +! & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +! & //TRIM(SUFFIX2(4)) +! +! ! Copy input file name to a local variable +! FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +! +! ! Echo some input to the screen +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +! +! ! Open the binary punch file for input +! CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +! +! ! Echo more output +! WRITE( 6, 110 ) +! 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +! & /, '(in volume mixing ratio units: v/v)' ) +! +! !================================================================= +! ! Read concentrations -- store in the TRACER array +! !================================================================= +! +! READ( IU_RST, IOSTAT=IOS ) +! & NI, NJ +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( TRACER(I,J), I=1,IIPAR ), J=1,JJPAR ) +! +! !------------------------------------------- +! ! *****TESTING CHECKPOINTING***** +! !------------------------------------------- +! !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! ! Compute tracer concentration [molec/cm3/box] by +! ! looping over all species belonging to this tracer +! IM(I,J) = TRACER(I,J) +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! !================================================================= +! ! Examine data blocks, print totals, and return +! !================================================================= +! +! ! Close file +! CLOSE( IU_RST ) +! +! ! Print totals atmospheric mass for each tracer +! WRITE( 6, 120 ) +! 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +! +! ! Fancy output +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +! +! ! Return to calling program +! END SUBROUTINE READ_IMIX_CHKFILE +! +!------------------------------------------------------------------------------ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_EMISRATE_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CSP, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ USE COMODE_MOD, ONLY : EMIS_RATE +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$# include "comode.h" +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ INTEGER :: JLOOP,JJ, KK +c$$$ INTEGER, PARAMETER :: IND = 40 +c$$$ REAL*4 :: TRACER(ITLOOP,IND) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('EMISRATE_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ !PRINT*,'ITLOOP, IGAS = ',ITLOOP,IGAS +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_EMISRATE_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J ) +c$$$ DO J = 1, IND +c$$$ DO I = 1, ITLOOP +c$$$ ! Compute tracer concentration [molec/cm3/box] by +c$$$ ! looping over all species belonging to this tracer +c$$$ TRACER(I,J) = EMIS_RATE(I,J) +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ +c$$$ CALL BPCH2_CSP( IU_RST, ITLOOP, IND, TRACER ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_EMISRATE_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_EMISRATE_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_EMISRATE_CHKFILE( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +c$$$! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +c$$$! Also reorganize some print statements (bmy, 10/25/99) +c$$$! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +c$$$! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +c$$$! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (5 ) Broke up sections of code into internal subroutines. Also updated +c$$$! comments & cleaned up a few things. (bmy, 7/17/00) +c$$$! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +c$$$! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +c$$$! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +c$$$! (10) Added updates from amf for tagged Ox run. Also updated comments +c$$$! and made some cosmetic changes (bmy, 7/3/01) +c$$$! (11) Bug fix: if starting from multiox restart file, then NTRACER +c$$$! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +c$$$! accordingly. (amf, bmy, 9/6/01) +c$$$! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +c$$$! (13) Updated comments (bmy, 1/25/02) +c$$$! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +c$$$! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +c$$$! (17) Add fancy output string (bmy, 4/26/04) +c$$$! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +c$$$! and "tracer_mod.f" (bmy, 7/20/04) +c$$$! (19) Remove code for obsolete CO-OH simulation. Also remove references +c$$$! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +c$$$! (bmy, 6/24/05) +c$$$! (20) Updated comments (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ USE COMODE_MOD, ONLY : EMIS_RATE, JLOP +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$# include "comode.h" +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR) +c$$$ INTEGER, PARAMETER :: IND = 40 +c$$$ REAL*4 :: TRACER(ITLOOP,IND) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('EMISRATE_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_EMISRATE_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & NI, NJ +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( TRACER(I,J), I=1,ITLOOP ), J=1,IND ) +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$ !============================================================== +c$$$ ! Assign data from the TRACER array to the STT array. +c$$$ !============================================================== +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J ) +c$$$ DO J = 1, IND +c$$$ DO I = 1, ITLOOP +c$$$ ! Compute tracer concentration [molec/cm3/box] by +c$$$ ! looping over all species belonging to this tracer +c$$$ EMIS_RATE(I,J) = TRACER(I,J) +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_EMISRATE_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_EMISRATE_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_F_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CHK, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : F, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ REAL*8, PARAMETER :: SMALLNUM = 1d-12 +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('F_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Convert from [kg] to [v/v] and store in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = F(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ! Convert STT from [kg] to [v/v] mixing ratio +c$$$ ! and store in temporary variable TRACER +c$$$ CALL BPCH2_CHK( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_F_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_F_CHKFILE( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +c$$$! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +c$$$! Also reorganize some print statements (bmy, 10/25/99) +c$$$! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +c$$$! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +c$$$! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (5 ) Broke up sections of code into internal subroutines. Also updated +c$$$! comments & cleaned up a few things. (bmy, 7/17/00) +c$$$! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +c$$$! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +c$$$! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +c$$$! (10) Added updates from amf for tagged Ox run. Also updated comments +c$$$! and made some cosmetic changes (bmy, 7/3/01) +c$$$! (11) Bug fix: if starting from multiox restart file, then NTRACER +c$$$! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +c$$$! accordingly. (amf, bmy, 9/6/01) +c$$$! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +c$$$! (13) Updated comments (bmy, 1/25/02) +c$$$! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +c$$$! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +c$$$! (17) Add fancy output string (bmy, 4/26/04) +c$$$! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +c$$$! and "tracer_mod.f" (bmy, 7/20/04) +c$$$! (19) Remove code for obsolete CO-OH simulation. Also remove references +c$$$! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +c$$$! (bmy, 6/24/05) +c$$$! (20) Updated comments (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, F +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR) +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('F_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ DO +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +c$$$ +c$$$ ! IOS < 0 is end-of-file, so exit +c$$$ IF ( IOS < 0 ) EXIT +c$$$ +c$$$ ! IOS > 0 is a real I/O error -- print error message +c$$$ IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:4' ) +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +c$$$ & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +c$$$ & NSKIP +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$ !============================================================== +c$$$ ! Assign data from the TRACER array to the STT array. +c$$$ !============================================================== +c$$$ +c$$$ ! Only process concentration data (i.e. mixing ratio) +c$$$ IF ( CATEGORY(1:8) == 'IJ-AVG-$' ) THEN +c$$$ +c$$$ ! Convert TRACER from [v/v] to [kg] and copy into STT array +c$$$ CALL COPY_F( NTRACER, TRACER, NCOUNT ) +c$$$ +c$$$ ENDIF +c$$$ ENDDO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Check for missing or duplicate data blocks +c$$$ CALL CHECK_DATA_BLOCKS( N_TRACERS, NCOUNT ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_F_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_EMISDEP_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ REAL*8, PARAMETER :: SMALLOX = 1d-6 +c$$$ REAL*8, PARAMETER :: SMALLNOX = 1d-8 +c$$$ REAL*8, PARAMETER :: SMALLCO = 1d-9 +c$$$ +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('EMISDEP.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_ADJ_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Convert from [kg] to [v/v] and store in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ! Convert STT from [kg] to [v/v] mixing ratio +c$$$ ! and store in temporary variable TRACER +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_EMISDEP_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_SRCEMIS_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ REAL*8, PARAMETER :: SMALLOX = 1d-6 +c$$$ REAL*8, PARAMETER :: SMALLNOX = 1d-8 +c$$$ REAL*8, PARAMETER :: SMALLCO = 1d-9 +c$$$ +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('SRCEMIS.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_ADJ_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Convert from [kg] to [v/v] and store in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ! Convert STT from [kg] to [v/v] mixing ratio +c$$$ ! and store in temporary variable TRACER +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_SRCEMIS_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_OBS_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CHK, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('OBS_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Convert from [kg] to [v/v] and store in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ! Convert STT from [kg] to [v/v] mixing ratio +c$$$ ! and store in temporary variable TRACER +c$$$ CALL BPCH2_CHK( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_OBS_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_OBS_CHKFILE( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +c$$$! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +c$$$! Also reorganize some print statements (bmy, 10/25/99) +c$$$! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +c$$$! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +c$$$! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (5 ) Broke up sections of code into internal subroutines. Also updated +c$$$! comments & cleaned up a few things. (bmy, 7/17/00) +c$$$! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +c$$$! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +c$$$! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +c$$$! (10) Added updates from amf for tagged Ox run. Also updated comments +c$$$! and made some cosmetic changes (bmy, 7/3/01) +c$$$! (11) Bug fix: if starting from multiox restart file, then NTRACER +c$$$! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +c$$$! accordingly. (amf, bmy, 9/6/01) +c$$$! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +c$$$! (13) Updated comments (bmy, 1/25/02) +c$$$! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +c$$$! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +c$$$! (17) Add fancy output string (bmy, 4/26/04) +c$$$! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +c$$$! and "tracer_mod.f" (bmy, 7/20/04) +c$$$! (19) Remove code for obsolete CO-OH simulation. Also remove references +c$$$! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +c$$$! (bmy, 6/24/05) +c$$$! (20) Updated comments (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR) +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('OBS_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ DO +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +c$$$ +c$$$ ! IOS < 0 is end-of-file, so exit +c$$$ IF ( IOS < 0 ) EXIT +c$$$ +c$$$ ! IOS > 0 is a real I/O error -- print error message +c$$$ IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:4' ) +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +c$$$ & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +c$$$ & NSKIP +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$ !============================================================== +c$$$ ! Assign data from the TRACER array to the STT array. +c$$$ !============================================================== +c$$$ +c$$$ CALL COPY_STT( NTRACER, TRACER, NCOUNT ) +c$$$ +c$$$ ENDDO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Check for missing or duplicate data blocks +c$$$ CALL CHECK_DATA_BLOCKS( N_TRACERS, NCOUNT ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_OBS_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_CURR_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CHK, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CURR_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Convert from [kg] to [v/v] and store in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ! Convert STT from [kg] to [v/v] mixing ratio +c$$$ ! and store in temporary variable TRACER +c$$$ CALL BPCH2_CHK( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_CURR_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_CURR_CHKFILE( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +c$$$! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +c$$$! Also reorganize some print statements (bmy, 10/25/99) +c$$$! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +c$$$! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +c$$$! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (5 ) Broke up sections of code into internal subroutines. Also updated +c$$$! comments & cleaned up a few things. (bmy, 7/17/00) +c$$$! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +c$$$! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +c$$$! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +c$$$! (10) Added updates from amf for tagged Ox run. Also updated comments +c$$$! and made some cosmetic changes (bmy, 7/3/01) +c$$$! (11) Bug fix: if starting from multiox restart file, then NTRACER +c$$$! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +c$$$! accordingly. (amf, bmy, 9/6/01) +c$$$! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +c$$$! (13) Updated comments (bmy, 1/25/02) +c$$$! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +c$$$! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +c$$$! (17) Add fancy output string (bmy, 4/26/04) +c$$$! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +c$$$! and "tracer_mod.f" (bmy, 7/20/04) +c$$$! (19) Remove code for obsolete CO-OH simulation. Also remove references +c$$$! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +c$$$! (bmy, 6/24/05) +c$$$! (20) Updated comments (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR) +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('CURR_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ DO +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +c$$$ +c$$$ ! IOS < 0 is end-of-file, so exit +c$$$ IF ( IOS < 0 ) EXIT +c$$$ +c$$$ ! IOS > 0 is a real I/O error -- print error message +c$$$ IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:4' ) +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +c$$$ & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +c$$$ & NSKIP +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$ !============================================================== +c$$$ ! Assign data from the TRACER array to the STT array. +c$$$ !============================================================== +c$$$ +c$$$ CALL COPY_STT( NTRACER, TRACER, NCOUNT ) +c$$$ +c$$$ ENDDO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Check for missing or duplicate data blocks +c$$$ CALL CHECK_DATA_BLOCKS( N_TRACERS, NCOUNT ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_CURR_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_BG_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHECKPOINT_FILE creates GEOS-CHEM restart files of tracer +c$$$! mixing ratios (v/v), in binary punch file format. (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (2 ) Reference F90 module "bpch2_mod.f" which contains routines BPCH2_HDR, +c$$$! BPCH2, and GET_MODELNAME for writing data to binary punch files. +c$$$! (bmy, 6/22/00) +c$$$! (3 ) Now do not write more than NTRACE data blocks to disk. +c$$$! Also updated comments. (bmy, 7/17/00) +c$$$! (4 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (5 ) Added to "restart_mod.f". Also now save the entire grid to the +c$$$! restart file. (bmy, 6/24/02) +c$$$! (6 ) Bug fix: Remove duplicate definition of MM. This causes compile-time +c$$$! problems on the ALPHA platform. (gcc, bmy, 11/6/02) +c$$$! (7 ) Now references functions GET_OFFSET, GET_YOFFSET from "grid_mod.f". +c$$$! Now references function GET_TAU from "time_mod.f". Now added a call +c$$$! to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (8 ) Cosmetic changes (bmy, 4/29/03) +c$$$! (9 ) Now reference STT, N_TRACERS, TCVV from "tracer_mod.f". Also now +c$$$! remove hardwired output restart filename. Now references LPRT +c$$$! from "logical_mod.f". (bmy, 7/20/04) +c$$$! (10) Remove references to CMN_DIAG and TRCOFFSET. Now call GET_HALFPOLAR +c$$$! from "bpch2_mod.f" to get the HALFPOLAR flag value for GEOS or GCAP +c$$$! grids. (bmy, 6/28/05) +c$$$! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +c$$$! (12) Add TAU to the argument list (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2_CHK, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('BG_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Convert from [kg] to [v/v] and store in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) !* TCVV(N) / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ! Convert STT from [kg] to [v/v] mixing ratio +c$$$ ! and store in temporary variable TRACER +c$$$ CALL BPCH2_CHK( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_BG_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE READ_BG_CHKFILE( YYYYMMDD, HHMMSS ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine READ_CHECKPOINT_FILE initializes GEOS-CHEM tracer concentrations +c$$$! from a restart file (binary punch file format) (bmy, 5/27/99, 12/16/05) +c$$$! +c$$$! Arguments as input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Day +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +c$$$! +c$$$! NOTES: +c$$$! (1 ) Now check that N = NTRACER - TRCOFFSET is valid. +c$$$! Also reorganize some print statements (bmy, 10/25/99) +c$$$! (2 ) Now pass LFORCE, LSPLIT via CMN_SETUP. (bmy, 11/4/99) +c$$$! (3 ) Cosmetic changes, added comments (bmy, 3/17/00) +c$$$! (4 ) Now use function NYMD_STRING from "time_mod.f" to generate a +c$$$! Y2K compliant string for all data sets. (bmy, 6/22/00) +c$$$! (5 ) Broke up sections of code into internal subroutines. Also updated +c$$$! comments & cleaned up a few things. (bmy, 7/17/00) +c$$$! (6 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +c$$$! (7 ) Print max & min of tracer regardless of the units (bmy, 10/5/00) +c$$$! (8 ) Removed obsolete code from 10/00 (bmy, 12/21/00) +c$$$! (9 ) Removed obsolete commented out code (bmy, 4/23/01) +c$$$! (10) Added updates from amf for tagged Ox run. Also updated comments +c$$$! and made some cosmetic changes (bmy, 7/3/01) +c$$$! (11) Bug fix: if starting from multiox restart file, then NTRACER +c$$$! will be greater than 40 but less than 60. Adjust COPY_STT_FOR_OX +c$$$! accordingly. (amf, bmy, 9/6/01) +c$$$! (12) Now reference TRANUC from "charpak_mod.f" (bmy, 11/15/01) +c$$$! (13) Updated comments (bmy, 1/25/02) +c$$$! (14) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +c$$$! (15) Now added a call to DEBUG_MSG from "error_mod.f" (bmy, 2/11/03) +c$$$! (16) Remove call to COPY_STT_FOR_OX, it's obsolete. (bmy, 8/18/03) +c$$$! (17) Add fancy output string (bmy, 4/26/04) +c$$$! (18) No longer use hardwired filename. Also now reference "logical_mod.f" +c$$$! and "tracer_mod.f" (bmy, 7/20/04) +c$$$! (19) Remove code for obsolete CO-OH simulation. Also remove references +c$$$! to CMN_DIAG and TRCOFFSET. Change tracer name format string to A10. +c$$$! (bmy, 6/24/05) +c$$$! (20) Updated comments (bmy, 12/16/05) +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE LOGICAL_MOD, ONLY : LSPLIT, LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : N_TRACERS, STT, TCVV +c$$$ USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, IOS, J, L, N +c$$$ INTEGER :: NCOUNT(NNPAR) +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ REAL*8 :: SUMTC +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ INTEGER :: NI, NJ, NL +c$$$ INTEGER :: IFIRST, JFIRST, LFIRST +c$$$ INTEGER :: NTRACER, NSKIP +c$$$ INTEGER :: HALFPOLAR, CENTER180 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ REAL*8 :: ZTAU0, ZTAU1 +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ +c$$$ !================================================================= +c$$$ ! READ_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ ! Initialize some variables +c$$$ NCOUNT(:) = 0 +c$$$ TRACER(:,:,:) = 0e0 +c$$$ +c$$$ !================================================================= +c$$$ ! Open restart file and read top-of-file header +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +c$$$ & //TRIM('BG_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Copy input file name to a local variable +c$$$ FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ ! Echo some input to the screen +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ WRITE( 6, '(a,/)' ) 'R E S T A R T F I L E I N P U T' +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( 'READ_CHECKPOINT_FILE: Reading ', a ) +c$$$ +c$$$ ! Open the binary punch file for input +c$$$ CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +c$$$ +c$$$ ! Echo more output +c$$$ WRITE( 6, 110 ) +c$$$ 110 FORMAT( /, 'Min and Max of each tracer, as read from the file:', +c$$$ & /, '(in volume mixing ratio units: v/v)' ) +c$$$ +c$$$ !================================================================= +c$$$ ! Read concentrations -- store in the TRACER array +c$$$ !================================================================= +c$$$ +c$$$ DO +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +c$$$ +c$$$ ! IOS < 0 is end-of-file, so exit +c$$$ IF ( IOS < 0 ) EXIT +c$$$ +c$$$ ! IOS > 0 is a real I/O error -- print error message +c$$$ IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:4' ) +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +c$$$ & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +c$$$ & NSKIP +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:5') +c$$$ +c$$$ READ( IU_RST, IOSTAT=IOS ) +c$$$ & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +c$$$ +c$$$ !------------------------------------------- +c$$$ ! *****TESTING CHECKPOINTING***** +c$$$ !------------------------------------------- +c$$$ !PRINT*,'TRACER(2,2,2)=',TRACER(2,2,2) +c$$$ +c$$$ IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_restart_file:6') +c$$$ +c$$$ !============================================================== +c$$$ ! Assign data from the TRACER array to the STT array. +c$$$ !============================================================== +c$$$ +c$$$ CALL COPY_STT( NTRACER, TRACER, NCOUNT ) +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ STT(I,J,L,NTRACER) = STT(I,J,L,NTRACER) !* AD(I,J,L) / +c$$$! & TCVV(NTRACER) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ ENDDO +c$$$ +c$$$ !================================================================= +c$$$ ! Examine data blocks, print totals, and return +c$$$ !================================================================= +c$$$ +c$$$ ! Check for missing or duplicate data blocks +c$$$ CALL CHECK_DATA_BLOCKS( N_TRACERS, NCOUNT ) +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ ! Print totals atmospheric mass for each tracer +c$$$ WRITE( 6, 120 ) +c$$$ 120 FORMAT( /, 'Total atmospheric masses for each tracer: ' ) +c$$$ +c$$$ ! Fancy output +c$$$ WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### READ_CHECKPOINT_FILE: read file') +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE READ_BG_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +! This still needs updating, plus I don't think it's even used +! (dkh, 06/23/09) +! SUBROUTINE MAKE_ORIG_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +!! +!!****************************************************************************** +!! Subroutine MAKE_ORIG_CHKFILE ??? ks ??? +!! +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) YYYYMMDD : Year-Month-Date +!! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +!! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +! USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +! USE DAO_MOD, ONLY : AD +! USE ERROR_MOD, ONLY : DEBUG_MSG +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE LOGICAL_MOD, ONLY : LPRT +! USE TIME_MOD, ONLY : EXPAND_DATE +! USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +! REAL*8, INTENT(IN) :: TAU +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, N +! INTEGER :: YYYY, MM, DD, HH, SS +! REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +! CHARACTER(LEN=255) :: FILENAME +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER :: HALFPOLAR +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! CHARACTER*10 :: SUFFIX1 +! CHARACTER*1 :: SUFFIX2(4) +! INTEGER :: T,MULT,IT,LT +! !================================================================= +! ! MAKE_CHECKPOINT_FILE begins here! +! !================================================================= +! +! WRITE (SUFFIX1,'(I8)')YYYYMMDD +! +! T = HHMMSS/100 +! +! DO IT = 1, 4 +! LT = T-(T/10)*10 +! WRITE (SUFFIX2(4-IT+1),'(I1)')LT +! T = T/10 +! END DO +! +! OUTPUT_CHECKPOINT_FILE = TRIM('opt/') +! & //TRIM('ORIG_CHK.')//TRIM(SUFFIX1)//TRIM('.') +! & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +! & //TRIM(SUFFIX2(4)) +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +! & 'Instantaneous Tracer Concentrations (v/v)' +! UNIT = 'v/v' +! CATEGORY = 'IJ-AVG-$' +! LONRES = DISIZE +! LATRES = DJSIZE +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Call GET_HALFPOLAR to return the proper value +! ! for either GCAP or GEOS grids (bmy, 6/28/05) +! HALFPOLAR = GET_HALFPOLAR() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the restart file for output -- binary punch format +! !================================================================= +! +! ! Copy the output restart file name into a local variable +! FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +! +! ! Open restart file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +! !================================================================= +! ! Write each tracer to the restart file +! !================================================================= +! +! DO N = 1, N_TRACERS +! +! ! Store GEOS-CHEM tracers in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! TRACER(I,J,L) = STT(I,J,L,N) * TCVV(N) * 1d9 / AD(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, TAU, TAU, RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, TRACER ) +! ENDDO +! +! ! Close file +! CLOSE( IU_RST ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +! +! +! ! Return to calling program +! END SUBROUTINE MAKE_ORIG_CHKFILE +! +!!------------------------------------------------------------------------------ + +c$$$ SUBROUTINE MAKE_PERT_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHEMISTRY_CHKFILE_P3 creates GEOS-CHEM restart files of tracers +c$$$! in binary punch file format. Used to checkpoint tracers for type2 information +c$$$! (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('opt/') +c$$$ & //TRIM('PERT_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Store GEOS-CHEM tracers in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) * TCVV(N) * 1d9 / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_PERT_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_OPTZ_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHEMISTRY_CHKFILE_P3 creates GEOS-CHEM restart files of tracers +c$$$! in binary punch file format. Used to checkpoint tracers for type2 information +c$$$! (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('opt/') +c$$$ & //TRIM('OPTZ_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Store GEOS-CHEM tracers in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) * TCVV(N) * 1d9 / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_OPTZ_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_DIFFPERT_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHEMISTRY_CHKFILE_P3 creates GEOS-CHEM restart files of tracers +c$$$! in binary punch file format. Used to checkpoint tracers for type2 information +c$$$! (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('opt/') +c$$$ & //TRIM('DIFFPERT_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Store GEOS-CHEM tracers in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) * TCVV(N) * 1d9 / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_DIFFPERT_CHKFILE +c$$$ +c$$$!------------------------------------------------------------------------------ +c$$$ +c$$$ SUBROUTINE MAKE_DIFFOPTZ_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +c$$$! +c$$$!****************************************************************************** +c$$$! Subroutine MAKE_CHEMISTRY_CHKFILE_P3 creates GEOS-CHEM restart files of tracers +c$$$! in binary punch file format. Used to checkpoint tracers for type2 information +c$$$! (Kumaresh, 01/24/08) +c$$$! +c$$$! Arguments as Input: +c$$$! ============================================================================ +c$$$! (1 ) YYYYMMDD : Year-Month-Date +c$$$! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +c$$$! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +c$$$!****************************************************************************** +c$$$! +c$$$ ! References to F90 modules +c$$$ USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME +c$$$ USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE +c$$$ USE DAO_MOD, ONLY : AD +c$$$ USE ERROR_MOD, ONLY : DEBUG_MSG +c$$$ USE FILE_MOD, ONLY : IU_RST, IOERROR +c$$$ USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +c$$$ USE LOGICAL_MOD, ONLY : LPRT +c$$$ USE TIME_MOD, ONLY : EXPAND_DATE +c$$$ USE TRACER_MOD, ONLY : STT, N_TRACERS, TCVV +c$$$ +c$$$# include "CMN_SIZE" ! Size parameters +c$$$ +c$$$ ! Arguments +c$$$ INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +c$$$ REAL*8, INTENT(IN) :: TAU +c$$$ +c$$$ ! Local Variables +c$$$ INTEGER :: I, I0, IOS, J, J0, L, N +c$$$ INTEGER :: YYYY, MM, DD, HH, SS +c$$$ REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +c$$$ CHARACTER(LEN=255) :: FILENAME +c$$$ +c$$$ ! For binary punch file, version 2.0 +c$$$ REAL*4 :: LONRES, LATRES +c$$$ INTEGER :: HALFPOLAR +c$$$ INTEGER, PARAMETER :: CENTER180 = 1 +c$$$ +c$$$ CHARACTER(LEN=20) :: MODELNAME +c$$$ CHARACTER(LEN=40) :: CATEGORY +c$$$ CHARACTER(LEN=40) :: UNIT +c$$$ CHARACTER(LEN=40) :: RESERVED = '' +c$$$ CHARACTER(LEN=80) :: TITLE +c$$$ CHARACTER*10 :: SUFFIX1 +c$$$ CHARACTER*1 :: SUFFIX2(4) +c$$$ INTEGER :: T,MULT,IT,LT +c$$$ !================================================================= +c$$$ ! MAKE_CHECKPOINT_FILE begins here! +c$$$ !================================================================= +c$$$ +c$$$ WRITE (SUFFIX1,'(I8)')YYYYMMDD +c$$$ +c$$$ T = HHMMSS/100 +c$$$ +c$$$ DO IT = 1, 4 +c$$$ LT = T-(T/10)*10 +c$$$ WRITE (SUFFIX2(4-IT+1),'(I1)')LT +c$$$ T = T/10 +c$$$ END DO +c$$$ +c$$$ OUTPUT_CHECKPOINT_FILE = TRIM('opt/') +c$$$ & //TRIM('DIFFOPTZ_CHK.')//TRIM(SUFFIX1)//TRIM('.') +c$$$ & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +c$$$ & //TRIM(SUFFIX2(4)) +c$$$ +c$$$ ! Define variables for BINARY PUNCH FILE OUTPUT +c$$$ TITLE = 'GEOS-CHEM CHECKPOINT File: ' // +c$$$ & 'Instantaneous Tracer Concentrations (v/v)' +c$$$ UNIT = 'v/v' +c$$$ CATEGORY = 'IJ-AVG-$' +c$$$ LONRES = DISIZE +c$$$ LATRES = DJSIZE +c$$$ +c$$$ ! Call GET_MODELNAME to return the proper model name for +c$$$ ! the given met data being used (bmy, 6/22/00) +c$$$ MODELNAME = GET_MODELNAME() +c$$$ +c$$$ ! Call GET_HALFPOLAR to return the proper value +c$$$ ! for either GCAP or GEOS grids (bmy, 6/28/05) +c$$$ HALFPOLAR = GET_HALFPOLAR() +c$$$ +c$$$ ! Get the nested-grid offsets +c$$$ I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +c$$$ J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +c$$$ +c$$$ !================================================================= +c$$$ ! Open the restart file for output -- binary punch format +c$$$ !================================================================= +c$$$ +c$$$ ! Copy the output restart file name into a local variable +c$$$ FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) +c$$$ +c$$$ ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +c$$$ CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +c$$$ +c$$$ WRITE( 6, 100 ) TRIM( FILENAME ) +c$$$ 100 FORMAT( ' - MAKE_CHECKPOINT_FILE: Writing ', a ) +c$$$ +c$$$ ! Open restart file for output +c$$$ CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +c$$$ +c$$$ !================================================================= +c$$$ ! Write each tracer to the restart file +c$$$ !================================================================= +c$$$ +c$$$ DO N = 1, N_TRACERS +c$$$ +c$$$ ! Store GEOS-CHEM tracers in the TRACER array +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, L ) +c$$$ DO L = 1, LLPAR +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ TRACER(I,J,L) = STT(I,J,L,N) * TCVV(N) * 1d9 / AD(I,J,L) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, N, +c$$$ & UNIT, TAU, TAU, RESERVED, +c$$$ & IIPAR, JJPAR, LLPAR, I0+1, +c$$$ & J0+1, 1, TRACER ) +c$$$ ENDDO +c$$$ +c$$$ ! Close file +c$$$ CLOSE( IU_RST ) +c$$$ +c$$$ !### Debug +c$$$ IF ( LPRT ) CALL DEBUG_MSG('### MAKE_CHECKPOINT_FILE: wrote file') +c$$$ +c$$$ +c$$$ ! Return to calling program +c$$$ END SUBROUTINE MAKE_DIFFOPTZ_CHKFILE + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_UPBDFLX_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +! +!****************************************************************************** +! Subroutine MAKE_UPBDFLX_CHKFILE saves STT values for LINOZE adjoint +! (ks, dkh, 05/02/10) +! +! Based on MAKE_RESTART_FILE (bmy, 5/27/99, 12/16/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +! +! NOTES: +! ( 1) Add date tokens, clean up (dkh, 05/02/10) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME + USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE + USE DAO_MOD, ONLY : AD + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : STT_TMP, N_TRACERS, TCVV + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + REAL*8, INTENT(IN) :: TAU + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER :: HALFPOLAR + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE +! old code from ks +! CHARACTER*10 :: SUFFIX1 +! CHARACTER*1 :: SUFFIX2(4) +! INTEGER :: T,MULT,IT,LT +! REAL*8, PARAMETER :: SMALLNUM = 1d-12 + + !================================================================= + ! MAKE_UPBDFLX_CHKFILE begins here! + !================================================================= + +! old code from ks +! WRITE (SUFFIX1,'(I8)')YYYYMMDD +! +! T = HHMMSS/100 +! +! DO IT = 1, 4 +! LT = T-(T/10)*10 +! WRITE (SUFFIX2(4-IT+1),'(I1)')LT +! T = T/10 +! END DO +! +! OUTPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +! & //TRIM('UPBD_CHK.')//TRIM(SUFFIX1)//TRIM('.') +! & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +! & //TRIM(SUFFIX2(4)) + + ! now use date tokens (dkh, 05/02/10) + OUTPUT_CHECKPOINT_FILE = 'upbd.chk.YYYYMMDD.hhmm' + + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM CHECKPOINT File: ' // + & 'Instantaneous Tracer Concentrations (v/v)' + UNIT = 'v/v' + CATEGORY = 'IJ-AVG-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Call GET_HALFPOLAR to return the proper value + ! for either GCAP or GEOS grids (bmy, 6/28/05) + HALFPOLAR = GET_HALFPOLAR() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the restart file for output -- binary punch format + !================================================================= + + ! Copy the output restart file name into a local variable + FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + FILENAME = TRIM( ADJTMP_DIR ) // + & TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_UPBDFLX_CHKFILE: Writing ', a ) + + ! Open restart file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each tracer to the restart file + !================================================================= + DO N = 1, 2 + + ! Convert from [kg] to [v/v] and store in the TRACER array +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,L) = STT_TMP(I,J,L,N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Convert STT from [kg] to [v/v] mixing ratio + ! and store in temporary variable TRACER + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG('### MAKE_UPBDFLX_CHKFILE: wrote file') + + + ! Return to calling program + END SUBROUTINE MAKE_UPBDFLX_CHKFILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_UPBDFLX_CHKFILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine READ_UPBDFLX_CHKFILE reads in STT_TMP for LINOZE. +! (ks, dkh, 05/02/10) +! +! Based on READ_RESTART_FILE (bmy, 5/27/99, 12/16/05) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! NOTES: +! ( 1) Now use date tokens to make filename (dkh, 05/02/10) +! ( 2) Now delete the upbd.chk.* files after reading (dkh, 05/02/10) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DAO_MOD, ONLY : AD + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_MOD, ONLY : LSPLIT, LPRT + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS, STT_TMP + USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE UNIX_CMDS_MOD, ONLY : REMOVE_CMD + + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_UPBDFLX_CHKFILE begins here! + !================================================================= + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open restart file and read top-of-file header + !================================================================= + +! WRITE (SUFFIX1,'(I8)')YYYYMMDD +! +! T = HHMMSS/100 +! +! DO IT = 1, 4 +! LT = T-(T/10)*10 +! WRITE (SUFFIX2(4-IT+1),'(I1)')LT +! T = T/10 +! END DO +! +! INPUT_CHECKPOINT_FILE = TRIM('adjtmp/') +! & //TRIM('UPBD_CHK.')//TRIM(SUFFIX1)//TRIM('.') +! & //TRIM(SUFFIX2(1))//TRIM(SUFFIX2(2))//TRIM(SUFFIX2(3)) +! & //TRIM(SUFFIX2(4)) + + INPUT_CHECKPOINT_FILE = 'upbd.chk.YYYYMMDD.hhmm' + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_UPBDFLX_CHKFILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read concentrations -- store in the TRACER array + !================================================================= + DO + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'READ_UPBDFLX:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'READ_UPBDFLX:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'READ_UPBDFLX:6') + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process concentration data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-AVG-$' ) THEN + + ! Convert TRACER from [v/v] to [kg] and copy into STT array + CALL COPY_STT_TMP( NTRACER, TRACER, NCOUNT ) + + ENDIF + ENDDO + + !================================================================= + ! Examine data blocks, print totals, and return + !================================================================= + + ! Check for missing or duplicate data blocks + CALL CHECK_DATA_BLOCKS( 2, NCOUNT ) + + ! Close file + CLOSE( IU_RST ) + + ! Remove files if L_CHK_DEL = TRUE + IF ( LDEL_CHKPT ) THEN + + REMOVE_CHK_FILE_CMD = TRIM ( REMOVE_CMD ) // ' ' // + & TRIM ( FILENAME ) + + CALL SYSTEM( TRIM( REMOVE_CHK_FILE_CMD ) ) + + WRITE( 6, 102 ) TRIM( REMOVE_CHK_FILE_CMD ) + 102 FORMAT( ' - READ_UPBDFLX_CHKFILE: Executing: ',a ) + + ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG('### READ_UPBDFLX_CHKFILE: read file') + + ! Return to calling program + END SUBROUTINE READ_UPBDFLX_CHKFILE + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_BEFSTRAT_CHKFILE( YYYYMMDD, HHMMSS, TAU ) +! +!****************************************************************************** +! Subroutine MAKE_BEFSTRAT_CHKFILE saves STT values for STRAT_CHEM adjoint +! (hml, 07/28/11, adj32_025) +! +! Based on MAKE_UPBDFLX_FILE (bmy, 5/27/99, 12/16/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +! +! NOTES: +! ( 1) Add date tokens, clean up (dkh, 05/02/10) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : BPCH2, GET_MODELNAME + USE BPCH2_MOD, ONLY : GET_HALFPOLAR, OPEN_BPCH2_FOR_WRITE + USE DAO_MOD, ONLY : AD + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : STT_STRAT_TMP, N_TRACERS, TCVV + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE TROPOPAUSE_MOD, ONLY : GET_MIN_TPAUSE_LEVEL + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT + + ! for new strat chem (hml, 10/07/11) + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_A_TAGOX_SIM + USE TRACERID_MOD, ONLY : IDTOX + + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + REAL*8, INTENT(IN) :: TAU + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + INTEGER :: LMIN + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + CHARACTER(LEN=255) :: FILENAME + + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER :: HALFPOLAR + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_BEFSTRAT_CHKFILE begins here! + !================================================================= + + ! now use date tokens (hml, 07/31/11) + OUTPUT_CHECKPOINT_FILE = 'befstrat.chk.YYYYMMDD.hhmm' + + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM CHECKPOINT File: ' // + & 'Instantaneous Tracer Concentrations (v/v)' + UNIT = 'v/v' + CATEGORY = 'IJ-AVG-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Call GET_HALFPOLAR to return the proper value + ! for either GCAP or GEOS grids (bmy, 6/28/05) + HALFPOLAR = GET_HALFPOLAR() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the restart file for output -- binary punch format + !================================================================= + + ! Copy the output restart file name into a local variable + FILENAME = TRIM( OUTPUT_CHECKPOINT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + FILENAME = TRIM( ADJTMP_DIR ) // + & TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_BEFSTRAT_CHKFILE: Writing ', a ) + + ! Open restart file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each tracer to the restart file + !================================================================= + DO N = 1,N_TRACERS + + ! Now use GMI rate for Ox (hml) +! IF ( ( ITS_A_FULLCHEM_SIM() .or. ITS_A_TAGOX_SIM() ) .and. +! & ( N .eq. IDTOx ) ) CYCLE + + ! Get the minimum level extent of the tropopause + LMIN = GET_MIN_TPAUSE_LEVEL() + + ! Convert from [kg] to [v/v] and store in the TRACER array +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = LMIN, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,L) = STT_STRAT_TMP(I,J,L,N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Convert STT from [kg] to [v/v] mixing ratio + ! and store in temporary variable TRACER + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG + & ('### MAKE_BEFSTRAT_CHKFILE: wrote file') + + + ! Return to calling program + END SUBROUTINE MAKE_BEFSTRAT_CHKFILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_BEFSTRAT_CHKFILE( YYYYMMDD, HHMMSS ) + +! +!****************************************************************************** +! Subroutine READ_BEFSTRAT_CHKFILE reads in STT_STRAT_TMP for STRAT_CHEM_ADJ. +! (hml, 07/28/11, adj32_025) +! +! Based on READ_UPDBFLX_FILE (hml, 07/28/11) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! NOTES: +! ( 1) Now use date tokens to make filename (dkh, 05/02/10) +! ( 2) Now delete the upbd.chk.* files after reading (dkh, 05/02/10) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DAO_MOD, ONLY : AD + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_MOD, ONLY : LSPLIT, LPRT + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS, STT_STRAT_TMP + USE TRACER_MOD, ONLY : TRACER_NAME, TRACER_MW_G + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE UNIX_CMDS_MOD, ONLY : REMOVE_CMD + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + !================================================================= + ! READ_BEFSTRAT_CHKFILE begins here! + !================================================================= + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open restart file and read top-of-file header + !================================================================= + + INPUT_CHECKPOINT_FILE = 'befstrat.chk.YYYYMMDD.hhmm' + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_CHECKPOINT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_BEFSTRAT_CHKFILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read concentrations -- store in the TRACER array + !================================================================= + DO + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'READ_BEFSTRAT:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'READ_BEFSTRAT:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'READ_BEFSTRAT:6') + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + ! Only process concentration data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-AVG-$' ) THEN + + ! Convert TRACER from [v/v] to [kg] and copy into STT array + CALL COPY_STT_STRAT_TMP( NTRACER, TRACER, NCOUNT ) + + ENDIF + ENDDO + + !================================================================= + ! Examine data blocks, print totals, and return + !================================================================= + + ! Check for missing or duplicate data blocks + CALL CHECK_DATA_BLOCKS( N_TRACERS, NCOUNT ) + + ! Close file + CLOSE( IU_RST ) + + ! Remove files if L_CHK_DEL = TRUE + IF ( LDEL_CHKPT ) THEN + + REMOVE_CHK_FILE_CMD = TRIM ( REMOVE_CMD ) // ' ' // + & TRIM ( FILENAME ) + + CALL SYSTEM( TRIM( REMOVE_CHK_FILE_CMD ) ) + + WRITE( 6, 102 ) TRIM( REMOVE_CHK_FILE_CMD ) + 102 FORMAT( ' - READ_BEFSTRAT_CHKFILE: Executing: ',a ) + + ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG('### READ_BEFSTRAT_CHKFILE: read file') + + ! Return to calling program + END SUBROUTINE READ_BEFSTRAT_CHKFILE + +!------------------------------------------------------------------------------ + + SUBROUTINE COPY_STT_STRAT_TMP( NTRACER, TRACER, NCOUNT ) +! +!****************************************************************************** +! Subroutine COPY_STT copies the results into the STT tracer array. +! Based on code by Kumaresh, 01/24/08. +! (hml, dkh, 02/14/12, adj32_025) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTRACER (INTEGER) : Tracer number +! (2 ) NCOUNT (INTEGER) : Ctr array - # of data blocks read for each tracer +! (3 ) TRACER (REAL*4 ) : Tracer concentrations from restart file [v/v] +! +! NOTES: +! (1 ) Added to "restart_mod.f". Also added parallel loops. (bmy, 6/25/02) +! (2 ) Now reference AD from "dao_mod.f" (bmy, 9/18/02) +! (3 ) Now exit if N is out of range (bmy, 4/29/03) +! (4 ) Now references N_TRACERS, STT & TCVV from "tracer_mod.f" (bmy, 7/20/04) +! (5 ) Remove call to TRUE_TRACER_INDEX (bmy, 6/24/05) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : AD + USE TRACER_MOD, ONLY : N_TRACERS, STT_STRAT_TMP, TCVV + + ! for new strat chem (hml, 10/07/11) + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_A_TAGOX_SIM + USE TRACERID_MOD, ONLY : IDTOX + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: NTRACER + REAL*4, INTENT(IN) :: TRACER(IIPAR,JJPAR,LLPAR) + INTEGER, INTENT(INOUT) :: NCOUNT(NNPAR) + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! COPY_STT begins here! + !================================================================= + + ! Tracer number + N = NTRACER + + ! Exit if N is out of range + IF ( N < 1 .or. N > N_TRACERS ) RETURN + + ! Now use GMI rate for Ox (hml) +! IF ( ( ITS_A_FULLCHEM_SIM() .or. ITS_A_TAGOX_SIM() ) .and. +! & ( N .eq. IDTOx ) ) RETURN + + ! store Tracers into GEOS-CHEM tracer arry +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + STT_STRAT_TMP(I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Increment the # of records found for tracer N + NCOUNT(N) = NCOUNT(N) + 1 + + END SUBROUTINE COPY_STT_STRAT_TMP + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE CHECKPOINT_MOD diff --git a/code/adjoint/checkpt_mod.f b/code/adjoint/checkpt_mod.f new file mode 100644 index 0000000..027d410 --- /dev/null +++ b/code/adjoint/checkpt_mod.f @@ -0,0 +1,7679 @@ +! $Id: checkpt_mod.f,v 1.23 2012/04/25 22:46:23 nicolas Exp $ + MODULE CHECKPT_MOD +! +!****************************************************************************** +! Module CHECKPT_MOD contains variables and routines which are used to read +! and write GEOS-CHEM checkpoint files, which contain tracer concentrations +! in [v/v] mixing ratio, humidities, temperatures and exit values from rpmares +! (dkh, 8/27/04, adj_group 6/09/09) +! +! Module Variables: +! ============================================================================ +! (1 ) INPUT_CHECKPT_FILE : Full path name of the checkpt file to be read +! (2 ) OUTPUT_CHECKPT_FILE : Full path name (w/ tokens!) of output file +! (3 ) INPUT_OBS_FILE : Full path name of the obs file to be read +! (4 ) OUTPUT_OBS_FILE : Full path hname (w/tokens!) of obs file +! +! Module Routines: +! ============================================================================ +! (1 ) MAKE_CHECKPT_FILE : Writes checkpoint file to disk +! (2 ) READ_CHECKPT_FILE : Reads checkpoint file from disk +! (3 ) READ_OBS_FILE : Read obs file from disk (include this here +! as the observation file is currently the same +! as the checkpt file) +! +! GEOS-CHEM modules referenced by restart_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module containing routines for binary punch file I/O +! (2 ) error_mod.f : Module containing NaN and other error check routines +! (3 ) file_mod.f : Module containing file unit numbers and error checks +! (4 ) grid_mod.f : Module containing horizontal grid information +! (5 ) time_mod.f : Module containing routines for computing time & date +! (6 ) restart_mod.f : Module containing CHECK_DIMENSIONS +! +! NOTES: +! Pretty much like a stripped down version of RESTART_MOD (dkh,8/30/04) +! (2 ) Swtich from OBS and RP_OUT to using OBS_STT and CHK_STT +! (3 ) Add CHK_PSC. (dkh, 03/16/05) +! (4 ) Added support for full chemistry. Add module varialbe PART_CASE. +! Added subroutine CHECK_DIMENSIONS_2. Modified READ / WRITE CHK +! routines and INIT / CLEAN to support full chem.. +! Add SMVGARRAY. +! (dkh, 07/22/05) +! (5 ) Add support for sulfate chemistry -- add SO2_CHK and H2O2_CHK. +! (dkh, 10/12/05) +! add WETD_CHK_H2O2s_CHEMT, WETD_CHK_H2O2s_DYNT, etc. (dkh, 10/23/05) +! (6 ) Add WETD_CHK_SO2_CHEMT and WETD_CHK_SO2_DYNT. (dkh, 10/31/05) +! (7 ) Add CONV_CHK_H2O2s_CHEMT and CONV_CHK_SO2s_DYNT. (dkh, 11/22/05) +! (8 ) Add routines MAKE_SAVE_FILE and EXPAND_NAME. (dkh, 07/19/06) +! (9 ) Add SOILNOX_CHK. (dkh, 02/06/07) +! (10) Add CHK_STT_CON(:,:,:) array for checkpointing STT before convection. +! (mak, 8/2/07) +! (11) Add MAKE_CHK_DYN_FILE and READ_CHK_DYN_FILE, move checkpointing of +! variables that change at dynamic time steps to these routines. (dkh, 02/02/09) +! (12) Update to v8, delete obsolete arrays (like CHK_STT) or ones that are somewhere else +! now (adj_group, 6/09/09) +! (13) Add support for LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (14) Add ANISORROPIA for aerosol thermo (slc, 3/9/13, ***) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + CHARACTER(LEN=255) :: INPUT_CHECKPT_FILE + CHARACTER(LEN=255) :: OUTPUT_CHECKPT_FILE + CHARACTER(LEN=255) :: INPUT_OBS_FILE + CHARACTER(LEN=255) :: OUTPUT_OBS_FILE + + ! Allocatable checkpoint variables + REAL*4, ALLOCATABLE :: RP_IN(:,:,:,:) + REAL*4, ALLOCATABLE :: RP_OUT(:,:,:,:) + REAL*4, ALLOCATABLE :: CHK_STT_CON(:,:,:,:) + REAL*4, ALLOCATABLE :: CHK_STT(:,:,:,:) + ! move to adj_arrays_mod.f (mak, 6/14/09) + !REAL*4, ALLOCATABLE :: OBS_STT(:,:,:,:) + REAL*8, ALLOCATABLE :: CHK_PSC(:,:,:) + REAL*4, ALLOCATABLE :: gamaan_fwd(:,:,:,:) + REAL*4, ALLOCATABLE :: gamold_fwd(:,:,:,:) + REAL*4, ALLOCATABLE :: wh2o_fwd(:,:,:,:) + REAL*4, ALLOCATABLE :: ynh4_fwd(:,:,:,:) + REAL*4, ALLOCATABLE :: eror_fwd(:,:,:,:) + INTEGER, ALLOCATABLE :: exit_fwd(:,:,:,:) + REAL*4, ALLOCATABLE :: gamana_fwd(:,:,:,:) + REAL*4, ALLOCATABLE :: gamas1_fwd(:,:,:,:) + REAL*4, ALLOCATABLE :: gamas2_fwd(:,:,:,:) + INTEGER, ALLOCATABLE :: nitr_max(:,:,:) + REAL*8, ALLOCATABLE :: ORIG_STT(:,:,:,:) + INTEGER, ALLOCATABLE :: PART_CASE(:) + REAL*8, ALLOCATABLE :: CHK_STT_BEFCHEM(:,:,:,:) + REAL*4, ALLOCATABLE :: CHK_HSAVE(:,:,:) + REAL*4, ALLOCATABLE :: SO2_CHK(:,:,:) + REAL*4, ALLOCATABLE :: H2O2_CHK(:,:,:) + REAL*4, ALLOCATABLE :: WETD_CHK_H2O2s(:,:,:) + REAL*4, ALLOCATABLE :: WETD_CHK_SO2s(:,:,:) + REAL*4, ALLOCATABLE :: WETD_CHK_SO4(:,:,:) + REAL*4, ALLOCATABLE :: WETD_CHK_SO2(:,:,:) + REAL*4, ALLOCATABLE :: CONV_CHK_H2O2s(:,:,:) + REAL*4, ALLOCATABLE :: CONV_CHK_SO2s(:,:,:) + REAL*4, ALLOCATABLE :: SOILNOX_CHK(:,:) + !REAL*4, ALLOCATABLE :: CHK_STT_TD(:,:,:,:) + REAL*4, ALLOCATABLE :: CHK_STT_TC(:,:,:,:) + !>>> + ! Now include adjoint of F (dkh, 10/03/08) + REAL*4, ALLOCATABLE :: QC_SO2_CHK(:,:,:,:) + !<<< + + ! adj_group: add for checkpointing lightning NOx emissions + REAL*8, ALLOCATABLE :: SLBASE_CHK(:,:,:) + + ! slc: add ANISORROPIA input checkpointing + REAL*8, ALLOCATABLE :: ANISO_IN(:,:,:,:) + + INTEGER, PARAMETER :: NRPIN = 7 + INTEGER, PARAMETER :: NRPOUT = 9 + INTEGER, PARAMETER :: NNNMAX = 50 + INTEGER, PARAMETER :: NANISOIN = 15 + + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_CHECKPT_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine MAKE_CHECKPT_FILE creates GEOS-CHEM checkpt files of tracer +! mixing ratios (v/v), temp, rh and exit values in binary punch file format. +! (dkh, 8/27/04)! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a checkpoint file +! +! Passed via CMN: +! ============================================================================ +! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +! +! Passed via ???: +! ============================================================================ +! (1 ) CHECKPT : Array of quantities to be checkpointed +! dim=(IIPAR,JJPAR,LLPAR,NCHECKPT) +! +! NOTES: +! Just like MAKE_RESTART_FILE except +! - only include quantities used as input to RPMARES +! - include hhmmss in file name +! - writes files to ADJ_DIR and can zip them +! dkh, 9/30/04 +! (2 ) Zip *.chk.* files one day at a time in a parallel loop. Add access +! to GET_TS_CHEM. (dkh, 11/22/04) +! (3 ) Add support for L_RECOMP option to recompute (rather than checkpoint) +! variables RP_OUT etc. (dkh, 02/09/05) +! (4 ) Now write values from CHK_STT. (dkh, 03/03/05) +! (5 ) Add CHK_PSC. (03/16/05) +! (6 ) Added support for full chemistry. Add references to NVAR, CSPEC, IXSAVE, +! IYSAVE, IZSAVE, NTLOOP_FORKPP, NSRCX +! Add variables PART_CASE, JLOOP. Disable L_RECOMP = FALSE option for now. +! Added SMVGARRAY. +! (dkh, 07/22/05) +! (7 ) Add SO2_CHK and H2O2_CHK. (dkh, 10/12/05) +! (8 ) Add WETD_CHK_H2O2s_CHEMT, WETD_CHK_H2O2s_DYNT, etc. (dkh, 10/23/05) +! (9 ) Add WETD_CHK_SO2_CHEMT, WETD_CHK_SO2_DYNT. (dkh, 10/31/05) +! (10) Add SOILNOX_CHK. (dkh, 02/06/07) +! (11) Now completely split dynamic from chemical time step checkpoints (dkh, 02/01/09) +! (12) Remove obsolete options (L_DEL_CHECKPT, L_ZIP_CHECKPT, L_RECOMP), +! check for aeroosl simulation (LSULF) and update names to v8 (dkh, 06/11/09) +! (13) Now checkpoint XYLAI (dkh, 10/14/09) +! (14) BUG FIX: LVARTROP treated correctly (dkh, 01/26/11) +! (15) Add support for CH4 simulation (kjw, dkh, 02/12/12, adj32_023) +! (16) Add ANISORROPIA for aerosol thermo (slc, 3/9/13, ***) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + USE LOGICAL_MOD, ONLY : LCHEM, LSULF, LSSALT + USE LOGICAL_MOD, ONLY : LSOILNOX, LLIGHTNOX + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LAERO_THERM + USE LOGICAL_ADJ_MOD, ONLY : LISO + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : N_TRACERS + USE COMODE_MOD, ONLY : CSPEC_PRIOR , JLOP + USE GCKPP_ADJ_GLOBAL, ONLY : NTT + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM, STT + + + ! LVARTROP support for adj (dkh, 01/26/11) + USE COMODE_MOD, ONLY : CSPEC_FULL_PRIOR + USE LOGICAL_MOD, ONLY : LVARTROP + USE COMODE_MOD, ONLY : ISAVE_PRIOR + USE COMODE_MOD, ONLY : NTLOOP_PRIOR + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NTLOOP, IGAS +# include "CMN_VEL" ! XYLAI + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N, JLOOP + INTEGER :: YYYY, MM, DD, HH, SS, ZIP_HH + INTEGER :: IJLOOP + CHARACTER(LEN=255) :: FILENAME + !>>> + ! Now include adjoint of F (dkh, 10/03/08) + INTEGER :: NS + !<<< + + + ! Temporary storage arrays for checkpointed variables + REAL*4 :: CHECK_RP_IN(IIPAR,JJPAR,LLPAR) + REAL*4 :: CHECK_FINAL(IIPAR,JJPAR,LLPAR) + REAL*4 :: CHECK_RP_OUT(IIPAR,JJPAR,LLPAR) + REAL*8 :: CHECK_ANISO_IN(IIPAR,JJPAR,LLPAR) + ! Always recompute, so these don't need to be checkponted (dkh, 06/11/09) +! REAL*4 :: CHECK1(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK2(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK3(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK4(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK5(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK6(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK7(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK8(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK9(IIPAR,JJPAR,LLPAR) + ! Now use NTLOOP because we want everything incase LVARTROP (dkh, 08/04/09) + !REAL*4 :: SMVGARRAY(NTT,IGAS) + REAL*4 :: SMVGARRAY(NTLOOP,IGAS) + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + INTEGER :: MAX_nitr_max + INTEGER :: NSOFAR, NTHERMO + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + + !================================================================= + ! MAKE_CHECKPT_FILE begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_CHECKPT_FILE = 'gctm.chk.YYYYMMDD.hhmm' + + ! Clear some arrays + CHECK_RP_IN(:,:,:) = 0e0 + CHECK_FINAL(:,:,:) = 0e0 + CHECK_RP_OUT(:,:,:) = 0e0 + CHECK_ANISO_IN(:,:,:) = 0e0 + ! Always recompute, so these don't need to be checkponted (dkh, 06/11/09) +! CHECK1(:,:,:) = 0e0 +! CHECK2(:,:,:) = 0e0 +! CHECK3(:,:,:) = 0e0 +! CHECK4(:,:,:) = 0e0 +! CHECK5(:,:,:) = 0e0 +! CHECK6(:,:,:) = 0e0 +! CHECK7(:,:,:) = 0e0 +! CHECK8(:,:,:) = 0e0 +! CHECK9(:,:,:) = 0e0 + SMVGARRAY(:,:) = 0e0 + + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM Checkpoint File: ' // + & 'Instantaneous Tracer Concentrations (v/v)' + CATEGORY = 'IJ-CHK-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the checkpoint file for output -- binary punch format + !================================================================= + + ! Copy the output checkpoint file name into a local variable + FILENAME = TRIM( OUTPUT_CHECKPT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to filename + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_CHECKPT_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each checkpointed quantity to the checkpoint file + !================================================================= + + IF ( LSULF .and. LAERO_THERM ) THEN + + IF ( LISO ) THEN + ! ISOROPIA II takes Na+, Cl- into account + ! First write the input to ISORROPIA + + NTHERMO = NANISOIN ! Determine initial index in the BPCH + + DO N = 1, NANISOIN + + ! Set UNIT + IF ( N == 9 .OR. N > 10 ) THEN + + ! RH + UNIT = 'unitless' + + ELSEIF ( N == 10 ) THEN + + ! Temp + UNIT = 'K' + + ELSE + + ! Some concentration + UNIT = 'mole/m3' + + ENDIF + + + ! Temporarily store data in CHECK_ANISO_IN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + CHECK_ANISO_IN(I,J,L) = ANISO_IN(I,J,L,N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH3( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, CHECK_ANISO_IN ) + ENDDO + + + ELSE ! Call checkpointing for RPMARES + + NTHERMO = NRPIN ! Determine initial index in the BPCH + + ! First write the input to RPMARES + DO N = 1, NRPIN + + ! Set UNIT + IF ( N == 6 ) THEN + + ! RH + UNIT = '%' + + ELSEIF ( N == 7 ) THEN + + ! Temp + UNIT = 'K' + + ELSE + + ! Some concentration + UNIT = 'ug/m3' + + ENDIF + + + ! Temporarily store data in CHECK_RP_IN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + CHECK_RP_IN(I,J,L) = RP_IN(I,J,L,N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, CHECK_RP_IN ) + ENDDO + + ENDIF ! LSSALT + + ENDIF ! LSULF + + ! Support for CH4 (kjw, dkh, 02/12/12, adj32_023) + IF ( .not. ITS_A_CH4_SIM() ) THEN + + ! Write the final concetration values as saved at the end of geos_mod.f + UNIT = 'kg/box' + ! Change to N_TRACERS (dkh, 06/11/09) + !DO N = 1, NOBS + DO N = 1, N_TRACERS + + ! Temporarily store data in CHECK_FINAL +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + CHECK_FINAL(I,J,L) = CHK_STT(I,J,L,N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N + NTHERMO, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, CHECK_FINAL ) + ENDDO + + ! It is a CH4 simulation + ELSE + ! Write the final concetration values as saved at the end of geos_mod.f + UNIT = 'kg/box' + DO N = 1, N_TRACERS + + ! Temporarily store data in CHECK_FINAL +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + CHECK_FINAL(I,J,L) = STT(I,J,L,N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + print*,'READ_CHECKPT: stt(14,14,14,1) =', + & stt(14,14,14,1) + print*,'READ_CHECKPT: check_final(14,14,14,1) =', + & CHECK_FINAL(14,14,14) + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, CHECK_FINAL ) + ENDDO + ENDIF ! ITS_A_CH4_SIM + + ! Checkpt additional values for full chem simulation + ! Replace NSRCX (dkh, 06/11/09) + !IF ( NSRCX == 3 .AND. LCHEM ) THEN + IF ( ITS_A_FULLCHEM_SIM() .AND. LCHEM ) THEN + + ! Write the final species concetrations after full chemistry + UNIT = 'molec/cm3/box' + + ! Transfer to temp array so that we only checkpt NTLOOP values, + ! not ITLOOP. +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP, N ) + DO N = 1, IGAS + !DO JLOOP = 1, NTT + DO JLOOP = 1, NTLOOP + + SMVGARRAY(JLOOP,N) = CSPEC_PRIOR(JLOOP,N) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & NTLOOP, IGAS, 1, I0+1, + & J0+1, 1, SMVGARRAY ) + + + ! Set NSOFAR + NSOFAR = NSOFAR + 1 + + ! Transfer to temp array so that we only checkpt NTLOOP values, + ! not ITLOOP. +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP ) + DO JLOOP = 1, NTT + + SMVGARRAY(JLOOP,1) = REAL( PART_CASE(JLOOP) ) + + ENDDO +!$OMP END PARALLEL DO + + ! Checkpoint PART_CASE + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & NTT, 1, 1, I0+1, + & J0+1, 1, SMVGARRAY ) + + + ! Set NSOFAR + NSOFAR = NSOFAR + 1 + + ! Write the tracer concetrations before chemisty + UNIT = 'kg/box' + DO N = 1, N_TRACERS + + ! Temporarily store data in CHECK_FINAL + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + CHECK_FINAL(I,J,L) = CHK_STT_BEFCHEM(I,J,L,N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, CHECK_FINAL ) + ENDDO + + ! Set NSOFAR + NSOFAR = NSOFAR + N_TRACERS + + ! LVARTROP support for adj (dkh, 01/26/11) + ! Write CSPEC_FULL_PRIOR + IF ( LVARTROP ) THEN + UNIT = 'molec/cm3' + DO N = 1, IGAS + + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & ILONG, ILAT, IPVERT, I0+1, + & J0+1, 1, + & REAL(CSPEC_FULL_PRIOR(1:ILONG,1:ILAT,1:IPVERT,N),4)) + + + ENDDO + + ! Set NSOFAR + NSOFAR = NSOFAR + IGAS + + + ! Write the 3-D to 1-D mappings + UNIT = 'none' + CATEGORY = 'isave' + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & NTLOOP_PRIOR, 3, 1, I0+1, + & J0+1, 1, + & REAL(ISAVE_PRIOR(1:NTLOOP_PRIOR,:),4) ) + + + ! Set NSOFAR + NSOFAR = NSOFAR + 1 + + ! reset CATEGORY + CATEGORY = 'IJ-CHK-$' + + + ENDIF + + ! Write last internal time step used by Rosenbrock Solver + ! (dkh, 09/06/05) + UNIT = 's' + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLTROP, I0+1, + & J0+1, 1, CHK_HSAVE ) + + + ! Set NSOFAR + NSOFAR = NSOFAR + 1 + ENDIF + + IF ( LSULF .AND. LCHEM ) THEN + ! Write the concentrations of SO2 and H2O2 used by CHEM_SO2 + ! (dkh, 10/12/05) + UNIT = 'v/v' + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLTROP, I0+1, + & J0+1, 1, SO2_CHK ) + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 2 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLTROP, I0+1, + & J0+1, 1, H2O2_CHK ) + + ! Set NSOFAR + NSOFAR = NSOFAR + 2 + + ENDIF + + + ! SOILNOX + IF ( LSOILNOX ) THEN + UNIT = 'molec/cm2/s' + + ! Temporarily store data in CHECK_FINAL +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + CHECK_FINAL(I,J,1) = SOILNOX_CHK(I,J) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! write to file + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, CHECK_FINAL(:,:,1) ) + + ! Update NSOFAR + NSOFAR = NSOFAR + 1 + + ENDIF + + ! Only do this for fullchem (mak, dkh, 01/06/10) + IF ( LCHEM .and. ITS_A_FULLCHEM_SIM() ) THEN + + ! Now checkpoint XYLAI as well, as it is difficult to recalc + DO N = 1, NTYPE + + ! This mapping is clunky, but copied directly from rdlai.f + IJLOOP = 0 + DO J = 1, JJPAR + DO I = 1, IIPAR + IJLOOP = IJLOOP + 1 + SMVGARRAY(IJLOOP,1) = REAL( XYLAI(IJLOOP,N) ) + END DO + END DO + + ! Checkpoint XYLAI + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & NTT, 1, 1, I0+1, + & J0+1, 1, SMVGARRAY ) + + ! Set NSOFAR + NSOFAR = NSOFAR + 1 + + ENDDO + + + ENDIF + + + ! SLBASE + IF ( LLIGHTNOX ) THEN + UNIT = 'molec/6h/box' + + ! Temporarily store data in CHECK_FINAL +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO l = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + CHECK_FINAL(I,J,L) = SLBASE_CHK(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! write to file + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, CHECK_FINAL(:,:,:) ) + + ! Update NSOFAR + NSOFAR = NSOFAR + 1 + + ENDIF + + ! Remove this, it wasn't a noticable improvement (dkh, 06/11/09) +! IF ( LADJ_TRAN ) THEN +! UNIT = 'v/v' +! +! ! CHK_STT_TD +! DO N = 1, NTRACE +! ! Temporarily store data in CHECK_FINAL +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO l = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHECK_FINAL(I,J,L) = CHK_STT_TD(I,J,L,N) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! write to file +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK_FINAL(:,:,:) ) +! +! ! Update NSOFAR +! NSOFAR = NSOFAR + 1 +! ENDDO +! ! CHK_STT_TC +! DO N = 1, NTRACE +! ! Temporarily store data in CHECK_FINAL +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO l = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHECK_FINAL(I,J,L) = CHK_STT_TC(I,J,L,N) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! write to file +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK_FINAL(:,:,:) ) +! +! ! Update NSOFAR +! NSOFAR = NSOFAR + 1 +! ENDDO +! ENDIF + + ! Remove this obsolete option (which was always T) (dkh, 06/11/09) +! ! Check for recomputation -- if so, go ahead and finish up. +! IF (L_RECOMP) GOTO 444 +! +! ! It's been awhile since I've tried L_RECOMP = .FALSE. Some things +! ! need to be update (NSOFAR, anything else?) dkh, 07/22/05 +! CALL ERROR_STOP( 'L_RECOMP = F not supported', +! & 'MAKE_CHECKPT_FILE' ) +! +! +! ! Write the output from RPMARES +! DO N = 1, NRPOUT +! +! ! Set UNIT +! IF ( N == 9 ) THEN +! +! ! EXIT value +! UNIT = 'unitless' +! +! ELSE +! +! ! Some concentration +! UNIT = 'ug/m3' +! +! ENDIF +! +! ! Temporarily store data in CHECK_RPOUT +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHECK_RP_OUT(I,J,L) = RP_OUT(I,J,L,N) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK_RP_OUT ) +! +! ENDDO +! +! NSOFAR = NSOFAR + NRPOUT +! +! ! Write the values of nitr_max +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, REAL( nitr_max ) ) +! +! ! Calculate max of nitr_max +! MAX_nitr_max = MAXVAL( nitr_max(:,:,:) ) +! +! ! Check to see that nitr_max is in the right range +! IF ( MAX_nitr_max > NNNMAX ) +! & CALL ERROR_STOP( 'nitr_max > NNNMAX', 'MAKE_CHECKPT_FILE' ) +! IF ( MAX_nitr_max == 0 ) +! & CALL ERROR_STOP( 'MAXVAL (nitr_max) = 0', 'MAKE_CHECKPT_FILE' ) +! +! ! Now write the intermediate values necessary for adjoint computation +! DO N = 1, MAX_nitr_max +! +! ! Update tracer number +! NSOFAR = NRPIN + NOBS + 1 + NRPOUT + 1 + 9 * (N-1) +! !Temporarily store quantities in the TRACER array +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! IF ( N <= nitr_max(I,J,L) ) THEN +! CHECK1(I,J,L) = gamaan_fwd (I,J,L,N) +! CHECK2(I,J,L) = gamold_fwd (I,J,L,N) +! CHECK3(I,J,L) = wh2o_fwd (I,J,L,N) +! CHECK4(I,J,L) = ynh4_fwd (I,J,L,N) +! CHECK5(I,J,L) = eror_fwd (I,J,L,N) +! CHECK6(I,J,L) = REAL ( exit_fwd (I,J,L,N) ) +! CHECK7(I,J,L) = gamana_fwd (I,J,L,N) +! CHECK8(I,J,L) = gamas1_fwd (I,J,L,N) +! CHECK9(I,J,L) = gamas2_fwd (I,J,L,N) +! ENDIF +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK1 ) +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 2 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK2 ) +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 3 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK3 ) +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 4 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK4 ) +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 5 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK5 ) +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 6 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK6 ) +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 7 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK7 ) +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 8 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK8 ) +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 9 + NSOFAR, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK9 ) +! ENDDO +! + 444 CONTINUE + + ! Close file + CLOSE( IU_RST ) + + + ! Remove obsolete option (dkh, 06/11/09) +! ! Zip files +! IF ( L_ZIP_CHECKPT ) CALL BATCH_ZIP( YYYYMMDD, HHMMSS, 'chk', 1 ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_CHECKPT_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_CHECKPT_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_CHECKPT_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine READ_CHECKPT_FILE initializes GEOS-CHEM tracer concentrations +! from a checkpoint file (binary punch file format) +! (dkh, 8/30/04) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! Passed via CMN: +! ============================================================================ +! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +! +! Notes +! (1 ) Just like READ_RESTART_FILE except +! - load the variables from TRACER directly back into the CHECKPT array +! - file name now includes hhmmss +! - reads files from ADJ_DIR (and can unzip them if L_ZIP_CHECKPT) +! - removes .chk. files after reading (if L_DEL_CHECKPT) +! dkh, 9/30/04 +! (2 ) Add DATE(2) and reference GET_NHMDe and GET_NHMSe to enable BATCH_ZIP +! (dkh, 11/22/04) +! (3 ) Add support for L_RECOMP option to recompute (rather than checkpoint) +! variables RP_OUT etc. (dkh, 02/09/05) +! (4 ) Now read in values to CHK_STT (dkh, 03/03/05) +! (5 ) Add CHK_PSC. (dkh, 03/16/05) +! (6 ) Added support for full chemistry. Add references to NVAR, CSPEC, JLOP, +! NTLOOP_FORKPP. +! Add variables PART_CASE, JLOOP. Disable L_RECOMP = FALSE option for now. +! Add SMVGARRAY +! (dkh, 07/22/05) +! (7 ) Add SO2_CHK and H2O2_CHK. (dkh, 10/12/05) +! (8 ) Add WETD_CHK_H2O2s_CHEMT, WETD_CHK_H2O2s_DYNT, etc. (dkh, 10/23/05) +! (9 ) Add WETD_CHK_SO2CHEMT, WETD_CHK_SO2_DYNT. (dkh, 10/31/05) +! (10) Add CONV_CHK_H2O2s_CHEMT, CONV_CHK_SO2s_CHEMT, etc. (dkh, 11/22/05) +! (11) Add SOILNOX. (dkh, 02/06/07) +! (12) Move dynamic checkpointing to READ_CHK_DYN_FILE. (dkh, 02/01/09) +! (13) Remove obsolete options (L_DEL_CHECKPT, L_ZIP_CHECKPT, L_RECOMP), +! check for aeroosl simulation (LSULF) and update names to v8 (dkh, 06/11/09) +! (14) Add XYLAI (dkh, 10/14/09) +! (15) BUG FIX: LVARTROP treated correctly (dkh, 01/26/11) +! (16) BUF FIX: Fill CSPEC with SMAL2 to prevent underflow later (dkh, 02/18/11) +! (17) Add ANISORROPIA for aerosol thermo (slc, 3/9/13, ***) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE COMODE_MOD, ONLY : CHK_CSPEC, JLOP + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GCKPP_ADJ_GLOBAL, ONLY : NTT + USE LOGICAL_MOD, ONLY : LCHEM , LSULF, LSSALT + USE LOGICAL_MOD, ONLY : LSOILNOX, LLIGHTNOX + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LAERO_THERM + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE LOGICAL_ADJ_MOD, ONLY : LISO + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : N_TRACERS + USE UNIX_CMDS_MOD, ONLY : REMOVE_CMD + + ! LVARTROP support for adj (dkh, 01/26/11) + USE COMODE_MOD, ONLY : CSPEC_FULL + USE LOGICAL_MOD, ONLY : LVARTROP + USE COMODE_MOD, ONLY : ISAVE_PRIOR + + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! ITLOOP, IGAS +# include "CMN_VEL" ! XYLAI + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N, JLOOP, NN, NTL + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*8 :: TRACERANISO(IIPAR,JJPAR,LLPAR) + ! Remove these since we always recompute instead + ! of checkpointing (dkh, 06/11/09) +! REAL*4 :: CHECK1(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK2(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK3(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK4(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK5(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK6(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK7(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK8(IIPAR,JJPAR,LLPAR) +! REAL*4 :: CHECK9(IIPAR,JJPAR,LLPAR) + REAL*4 :: SMVGARRAY(ITLOOP,IGAS) + + !>>> + ! Now include adjoint of F (dkh, 10/03/08) + INTEGER :: NS + !<<< + + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: UNZIP_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL, NV + INTEGER :: IJLOOP + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_CHECKPT_FILE begins here! + !================================================================= + + ! Hardwire output file for now + INPUT_CHECKPT_FILE = 'gctm.chk.YYYYMMDD.hhmm' + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + TRACERANISO(:,:,:) = 0e0 + ! Remove these since we always recompute instead + ! of checkpointing (dkh, 06/11/09) +! CHECK1(:,:,:) = 0e0 +! CHECK2(:,:,:) = 0e0 +! CHECK3(:,:,:) = 0e0 +! CHECK4(:,:,:) = 0e0 +! CHECK5(:,:,:) = 0e0 +! CHECK6(:,:,:) = 0e0 +! CHECK7(:,:,:) = 0e0 +! CHECK8(:,:,:) = 0e0 +! CHECK9(:,:,:) = 0e0 + SMVGARRAY(:,:) = 0e0 + + !================================================================= + ! Open checkpoint file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_CHECKPT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to name + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C H E C K P T F I L E I N P U T' + + ! Obsolete (dkh, 06/11/09) +! ! Unzip checkpt file +! IF ( L_ZIP_CHECKPT ) THEN +! UNZIP_FILE_CMD = TRIM( GUNZIP_CMD ) // ' ' // +! & TRIM( FILENAME ) // ZIP_SUFFIX +! CALL SYSTEM( TRIM( UNZIP_FILE_CMD ) ) +! WRITE( 6, 99 ) TRIM( UNZIP_FILE_CMD ) +! 99 FORMAT( ' - READ_CHECKPT_FILE: Executing: ',a ) +! ENDIF + + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_CHECKPT_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read checkpointed variables + !================================================================= + + ! First read the input to thermo - ISORROPIA or RPMARES + ! Add check for full chem with aerosols (dkh, 06/11/09) + IF ( LSULF .and. LAERO_THERM ) THEN + IF ( LISO ) THEN + ! ISOROPIA II takes Na+, Cl- into account + DO N = 1, NANISOIN + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACERANISO(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') + + + !=========================================================== + ! Assign data from the TRACER array to the STT array. + !=========================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN !???! + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ANISO_IN(I,J,L,N) = TRACERANISO(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ELSE + ! RPMARES checkpointing + DO N = 1, NRPIN + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') + + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + RP_IN(I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + ENDIF ! ISORROPIA or RPMARES + ENDIF + + ! Read the values of CHK_STT + ! Change to N_TRACES (dkh, 06/11/09) + !DO N = 1, NOBS + DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:7' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:8' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:9' ) + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + CHK_STT(I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ! Replace NSRCX (dkh, 06/11/09) + !IF ( NSRCX == 3 .AND. LCHEM ) THEN + IF ( ITS_A_FULLCHEM_SIM() .AND. LCHEM ) THEN + + ! Read the values of CHK_CSPEC + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 555 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:13' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NTL, NN, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:14' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( SMVGARRAY(JLOOP,N), JLOOP=1,NTL ), N=1,NN ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:16' ) + + !============================================================== + ! Assign data from the SMVGARRAY array to CHK_CSPEC + !============================================================== + + ! Only process checkpoint data + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Check to make sure data is NTLOOPxNVAR + !Can't do this because RURALBOX hasn't been called for this + !time step yet, so we don't know NTT yet (dkh, 07/31/09 + !CALL CHECK_DIMENSIONS_2( NTL, NN, NL, + ! NTT, IGAS, 1 ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP, N ) + DO N = 1, NN + DO JLOOP = 1, NTLOOP + + ! BUG FIX: fill with 1d-99 to prevent underflow later (dkh, 02/18/11) + !CHK_CSPEC(JLOOP,N) = SMVGARRAY(JLOOP,N) + CHK_CSPEC(JLOOP,N) = MAX(SMVGARRAY(JLOOP,N),SMAL2) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + +! dkh debug +! print*, ' In reac_checkpt: chk_cspec(FD) = ', +! & CHK_CSPEC(JLOP(IFD,JFD,LFD),:) +! print*, ' In reac_checkpt: smvgarray(FD) = ', +! & SMVGARRAY(JLOP(IFD,JFD,LFD),:) + ELSE + CALL ERROR_STOP(' Category is not correct ', + & ' reading CHK_CSPEC, checkpt_mod') + + ENDIF + + ! Read in partition case PART_CASE + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 555 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:17' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NTL, NN, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:18' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( SMVGARRAY(JLOOP,N), JLOOP=1,NTL ), N=1,NN ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:20' ) + + ! Convert from SMVGARRAY (REAL) to PART_CASE (INT) + +! ! Check to make sure data is NTLOOPx1 +! CALL CHECK_DIMENSIONS_2( NTL, NN, NL, +! & NTT 1, 1 ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP ) + DO JLOOP = 1, NTL + + PART_CASE(JLOOP) = INT( SMVGARRAY(JLOOP,NN) ) + + ENDDO +!$OMP END PARALLEL DO + + ! Read the values of CHK_STT_BEFCHEM + DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:21' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:22' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:23' ) + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + CHK_STT_BEFCHEM(I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ! LVARTROP support for adj (dkh, 01/26/11) + + IF ( LVARTROP ) THEN + ! Read the values of CSPEC_FULL + DO N = 1, IGAS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:210' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:220' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:230' ) + + !============================================================== + ! Assign data from the TRACER array to the CSPEC_FULL array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + !CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, IPVERT + DO J = 1, ILAT + DO I = 1, ILONG + ! BUG FIX: fill with 1d-99 to prevent underflow later (dkh, 02/18/11) + !CSPEC_FULL(I,J,L,N) = TRACER(I,J,L) + CSPEC_FULL(I,J,L,N) = MAX(TRACER(I,J,L),SMAL2) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ! Read the values of ISAVE_PRIOR + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 555 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:13' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NTL, NN, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:14' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( SMVGARRAY(JLOOP,N), JLOOP=1,NTL ), N=1,NN ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:16' ) + + !============================================================== + ! Assign data from the SMVGARRAY array to CHK_CSPEC + !============================================================== + + ! Only process checkpoint data + IF ( CATEGORY(1:8) == 'isave' ) THEN + + ! Check to make sure data is NTLOOPxNVAR + !Can't do this because RURALBOX hasn't been called for this + !time step yet, so we don't know NTT yet (dkh, 07/31/09 + !CALL CHECK_DIMENSIONS_2( NTL, NN, NL, + ! NTT, IGAS, 1 ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP, N ) + DO N = 1, 3 + DO JLOOP = 1, NTL + + ISAVE_PRIOR(JLOOP,N) = INT(SMVGARRAY(JLOOP,N)) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ELSE + CALL ERROR_STOP(' Category is not correct ', + & ' reading CHK_CSPEC, checkpt_mod') + + ENDIF + + ENDIF ! LVARTROP + + + ! Read the values of CHK_HSAVE + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 555 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:24' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:25' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( CHK_HSAVE(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:26' ) + + ENDIF + + IF ( LSULF .and. LCHEM ) THEN + ! Read the values of SO2_CHK + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 555 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:27' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:28' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( SO2_CHK(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:29' ) + + ! Read the values of H2O2_CHK + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 555 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:30' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:31' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( H2O2_CHK(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:32' ) + + ENDIF ! LCHEM + + ! SOILNOX + IF ( LSOILNOX ) THEN + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 555 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:63' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:64' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:59' ) + + SOILNOX_CHK(:,:) = TRACER(:,:,1) + + ENDIF + + ! Only do this for fullchem (mak, dkh, 01/06/10) + IF ( LCHEM .and. ITS_A_FULLCHEM_SIM() ) THEN + + ! Read in partition case XYLAI (dkh, 10/14/09) + DO NV = 1 , NTYPE + + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 555 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:17' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NTL, NN, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:18' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( SMVGARRAY(JLOOP,N), JLOOP=1,NTL ), N=1,NN ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:20' ) + + ! This mapping is clunky, but copied directly from rdlai.f + IJLOOP = 0 + DO J = 1, JJPAR + DO I = 1, IIPAR + IJLOOP = IJLOOP + 1 + XYLAI(IJLOOP,NV) = SMVGARRAY(IJLOOP,1) + END DO + END DO + + ENDDO + + ENDIF + + ! SLBASE + IF ( LLIGHTNOX ) THEN + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 555 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:63' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:64' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:59' ) + + SLBASE_CHK(:,:,:) = TRACER(:,:,:) + + ENDIF + + ! Take this part out, it didn't help much (dkh, 06/11/09) +! IF ( LADJ_TRAN ) THEN +! ! Read the values of CHK_STT_TD +! DO N = 1, NTRACE +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:121' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) +! & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:122' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:123' ) +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +! ! Only process checkpoint data (i.e. mixing ratio) +! IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN +! +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! CALL CHECK_DIMENSIONS( NI, NJ, NL ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHK_STT_TD(I,J,L,N) = TRACER(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! +! ! Read the values of CHK_STT_TC +! DO N = 1, NTRACE +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:221' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) +! & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:222' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:223' ) +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +! ! Only process checkpoint data (i.e. mixing ratio) +! IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN +! +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! CALL CHECK_DIMENSIONS( NI, NJ, NL ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHK_STT_TC(I,J,L,N) = TRACER(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! +! ENDIF ! LADJ_TRAN + + + + ! Take this out as I always had L_RECOMP = T +! ! Check for recomputation -- if so, go ahead and finish up +! IF ( L_RECOMP ) GOTO 555 +! +! ! Read output from RPMARES +! DO N = 1, NRPOUT +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +! ! Only process checkpoint data (i.e. mixing ratio) +! IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN +! +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! CALL CHECK_DIMENSIONS( NI, NJ, NL ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! RP_OUT(I,J,L,N) = TRACER(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! +! ! Read nitr_max +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +! ! Only process checkpoint data (i.e. mixing ratio) +! IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN +! +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! CALL CHECK_DIMENSIONS( NI, NJ, NL ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! nitr_max(I,J,L) = INT( TRACER(I,J,L) ) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! +! ! Read the variables checkpointed for the adjoint calculation +! ! CHECK1 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( CHECK1(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! +! ! CHECK2 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( CHECK2(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! +! ! CHECK3 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( CHECK3(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! +! ! CHECK4 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( CHECK4(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! +! ! CHECK5 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( CHECK5(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! +! ! CHECK6 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( CHECK6(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! +! ! CHECK7 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( CHECK7(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! +! ! CHECK7 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( CHECK7(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! +! ! CHECK8 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( CHECK8(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! +! ! CHECK9 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so return +! IF ( IOS < 0 ) RETURN +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:4' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( CHECK9(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:6') +! +! +! ! Write check arrays to the appropriate adjoint variables +! DO N = 1, MAXVAL ( nitr_max(:,:,:) ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! gamaan_fwd (I,J,L,N) = CHECK1(I,J,L) +! gamold_fwd (I,J,L,N) = CHECK2(I,J,L) +! wh2o_fwd (I,J,L,N) = CHECK3(I,J,L) +! ynh4_fwd (I,J,L,N) = CHECK4(I,J,L) +! eror_fwd (I,J,L,N) = CHECK5(I,J,L) +! exit_fwd (I,J,L,N) = INT( CHECK6(I,J,L) ) +! gamana_fwd (I,J,L,N) = CHECK7(I,J,L) +! gamas1_fwd (I,J,L,N) = CHECK8(I,J,L) +! gamas2_fwd (I,J,L,N) = CHECK9(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDDO +! + 555 CONTINUE + + ! Close file + CLOSE( IU_RST ) + + ! Remove files if L_CHK_DEL = TRUE + IF ( LDEL_CHKPT ) THEN + + REMOVE_CHK_FILE_CMD = TRIM ( REMOVE_CMD ) // ' ' // + & TRIM ( FILENAME ) + + CALL SYSTEM( TRIM( REMOVE_CHK_FILE_CMD ) ) + + WRITE( 6, 102 ) TRIM( REMOVE_CHK_FILE_CMD ) + 102 FORMAT( ' - READ_CHECKPT_FILE: Executing: ',a ) + + ENDIF + +! ! Zip the .chk. file if it hasn't been deleted and zipping +! ! is requested +! IF ( L_ZIP_CHECKPT .AND. (.NOT. L_DEL_CHECKPT) ) THEN +! CALL BATCH_ZIP( YYYYMMDD, HHMMSS, 'chk', -1 ) +! ENDIF + + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_CHECKPT_FILE: read file' ) + + ! Return to calling program + END SUBROUTINE READ_CHECKPT_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_OBS_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine MAKE_OBS_FILE creates GEOS-CHEM observation files of tracer +! mixing ratios (v/v) in binary punch file format. +! (dkh, 9/01/04) +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a checkpoint file +! +! Passed via CMN: +! ============================================================================ +! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +! +! Passed via CMN_ADJ +! ============================================================================ +! (1 ) CHECKPT : Array of quantities to be checkpointed +! dim=(IIPAR,JJPAR,LLPAR,NCHECKPT) +! +! NOTES: +! (1 ) Just like MAKE_CHK_FILE except +! - write to .obs. file +! - only write output from rpmares, +! (2 ) Switch to using OBS_STT rather than OBS +! (3 ) Update to v8 format, remove obsolete options (dkh, 06/11/09) +! (18) OBS_STT now in adj_arrays_mod.f instead of checkpt_mod.f (mak, 6/14/09) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + USE ADJ_ARRAYS_MOD, ONLY : OBS_STT + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_OBS_FILE begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_OBS_FILE = 'gctm.obs.YYYYMMDD.hhmm' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM OBS File: ' // + & 'Observation Concentrations (kg/box)' + UNIT = 'kg/box' + CATEGORY = 'IJ-OBS-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the observation file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_OBS_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to FILENAME + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_OBS_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + + !DO N = 1, NOBS + DO N = 1, N_TRACERS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,L) = OBS_STT(I,J,L,N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TRACER ) + + ENDDO + + ! Close file + CLOSE( IU_RST ) + + ! Obsolete (dkh, 06/11/09) +! ! Zip the obs file +! IF ( L_ZIP_OBS ) THEN +! +! CALL BATCH_ZIP( YYYYMMDD, HHMMSS, 'obs', 1 ) +! +! ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_OBS_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_OBS_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_OBS_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine READ_OBS_FILE reads the output of the reference run from an +! observation file (binary punch file format) +! (dkh, 9/01/04) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! Passed via CMN: +! ============================================================================ +! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +! +! Notes +! (1 ) Just like READ_CHECKPT_FILE except +! - read NOBS variables into OBS array +! (2 ) Switch to using OBS_STT rather than OBS (dkh 03/03/05) +! (3 ) Update to v8 format, remove obsolete options (dkh, 06/11/09) +! (4 ) OBS_STT now in adj_arrays_mod.f instead of checkpt_mod.f (mak, 6/14/09) +!****************************************************************************** +! + ! References to F90 modules + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS + USE ADJ_ARRAYS_MOD, ONLY : OBS_STT + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: UNZIP_FILE_CMD + CHARACTER(LEN=255) :: ZIP_FILE_CMD + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_OBS_FILE begins here! + !================================================================= + + ! Hardwire output file for now + INPUT_OBS_FILE = 'gctm.obs.YYYYMMDD.hhmm' + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open observation file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_OBS_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to FILENAME + !FILENAME = TRIM( ADJ_DIR ) // TRIM( FILENAME ) + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'O B S F I L E I N P U T' + + ! Remove obsolete options (dkh, 06/11/09) +! ! Unzip obs file +! IF ( L_ZIP_OBS ) THEN +! UNZIP_FILE_CMD = TRIM( GUNZIP_CMD ) // ' ' // +! & TRIM( FILENAME ) // ZIP_SUFFIX +! CALL SYSTEM( TRIM( UNZIP_FILE_CMD ) ) +! WRITE( 6, 99 ) TRIM( UNZIP_FILE_CMD ) +! 99 FORMAT( ' - READ_OBS_FILE: Executing: ',a ) +! ENDIF + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_OBS_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read concentrations -- store in the TRACER array + !================================================================= + !DO N = 1, NOBS + DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_obs_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_obs_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_obs_file:6') + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-OBS-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + OBS_STT(I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ! Close file + CLOSE( IU_RST ) + + ! Remove obsolete options (dkh, 06/11/09) +! ! Zip the obs file +! IF ( L_ZIP_OBS ) THEN +! +! CALL BATCH_ZIP( YYYYMMDD, HHMMSS, 'obs', -1 ) +! +! ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_OBS_FILE: read file' ) + + ! Return to calling program + END SUBROUTINE READ_OBS_FILE + +!----------------------------------------------------------------------- +! Remove obsolete subroutines (dkh, 06/11/09) +! SUBROUTINE BATCH_ZIP( YYYYMMDD, HHMMSS, FID, MODE ) +!! +!!********************************************************************** +!! Subroutine BATCH_ZIP zips a days worth of *.obs.*, *.adj.*, +!! and *.chk.* files using multiple processors. Only works for +!! TS_CHEM = 60 (min) and simulations that begin at HHMMSS = 000000. +!! Simulation ending at times other than HHMMSS = 000000 are allowed. +!! The argument MODE indicates whether the batch of files to be zipped +!! begins (-1) or ends (+1) at HHMMSS, and adjustments are then made so +!! that DATE(2) always indicates the time stamp of the latest file to be +!! zipped. (dkh, 11/22/04) +!! +!! NOTES +!! +!!********************************************************************** +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_NYMDe, GET_NHMSe, EXPAND_DATE, +! & GET_TS_CHEM, GET_TIME_AHEAD, GET_NHMSb +! USE ERROR_MOD, ONLY : ERROR_STOP +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_ADJ" ! OBS_FREQ, GZIP_CMD +! +! +! ! Arguments +! INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS +! CHARACTER(LEN=3) :: FID +! INTEGER :: MODE ! +1 for fwd, -1 for backwd +! +! ! Local variables +! INTEGER :: HH, ZIP_INTERVAL, HH_MAX, ZHHMMSS +! INTEGER :: NHMSe, NYMDe +! INTEGER :: DATE(2) +! INTEGER :: OBS_FREQ_HH = OBS_FREQ / 6 * 1000 +! CHARACTER(LEN=255) :: ZIP_FILE_CMD +! CHARACTER(LEN=255) :: ZIP_FILENAME +! CHARACTER(LEN=255) :: TO_ZIP_FILENAME +! +! !------------------------------------------------------------ +! ! BATCH_ZIP begins here! +! !------------------------------------------------------------ +! +! ! Check to make sure that TS_CHEM is actually 60 min +! ! and that the simulation began at the beginning of a day +! IF ( GET_TS_CHEM() /= 60 .OR. GET_NHMSb() /= 000000 ) THEN +! WRITE(6,*) ' -- Timeing inappropriate for batch zip' +! RETURN +! ENDIF +! +! ! Get HHMMSS at end of run +! NHMSe = GET_NHMSe() +! NYMDe = GET_NYMDe() +! +! ! Adjust the arguments YYYYMMDD and HHMMSS if we are operating +! ! in reverse mode (i.e. zipping after reading) +! IF ( MODE == -1 ) THEN +! +! ! Get YYYYMMDD and HHMMSS for 23 hours ahead +! DATE = GET_TIME_AHEAD( 60 * 23 ) +! +! ! Adjust for case when is the zeroeth hour of final day +! IF ( YYYYMMDD == NYMDe .AND. HHMMSS == 000000 ) THEN +! +! ! Set DATE(2) so that the final day's files get zipped +! DATE(2) = NHMSe - 10000 +! +! ENDIF +! +! ELSE +! +! DATE(1) = YYYYMMDD +! DATE(2) = HHMMSS +! +! ENDIF +! +! ! Determine range of batch of files to zip +! IF ( NHMSe == 000000 ) THEN +! +! ! Batches will always span a full day +! HH_MAX = 230000 +! +! ELSE +! +! ! Batch range depends upon the day +! IF ( YYYYMMDD == NYMDe ) THEN +! +! ! The batch for the last day is shorter +! HH_MAX = NHMSe - 10000 +! +! ELSE +! +! ! Not the last day yet, so batch still spans a full day +! HH_MAX = 230000 +! +! ENDIF +! +! ENDIF +! +! IF ( FID == 'obs' ) THEN +! IF ( YYYYMMDD == NYMDe .AND. +! & ( DATE(2) + OBS_FREQ_HH) > ( NHMSe - 10000 ) ) THEN +! HH_MAX = DATE(2) +! ELSEIF ( ( DATE(2) + OBS_FREQ_HH ) > (230000) ) THEN +! HH_MAX = DATE(2) +! ENDIF +! ENDIF +! +! ! Only zip the batch of files at the end of the day (or partial day). +! IF ( DATE(2) /= HH_MAX ) RETURN +! +! ! Determine the number of files in the batch +! IF ( FID == 'chk' .OR. FID == 'adj' ) THEN +! +! ! There is (at least) one file for every hour +! ZIP_INTERVAL = 10000 +! +! ELSEIF ( FID == 'obs' ) THEN +! +! ! Convert the obseration interval (min) into the right units +! ZIP_INTERVAL = OBS_FREQ_HH +! +! ELSE +! +! CALL ERROR_STOP('File type not defined!', +! & 'BATCH_ZIP (checkpt_mod.f)' ) +! +! ENDIF +! +! ! Create generic file name +!#if defined( GEOS_1 ) || defined( GEOS_STRAT ) +! TO_ZIP_FILENAME = 'gctm.' // FID // '.YYYYMMDD.hhmmss' +!#else +! TO_ZIP_FILENAME = 'gctm.' // FID // '.YYYYMMDD.hhmmss' +!#endif +! +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( ZIP_FILENAME, HH ) +!!$OMP+PRIVATE( ZIP_FILE_CMD, ZHHMMSS ) +! DO HH = 000000, HH_MAX , ZIP_INTERVAL +! +! ! Set the HHMMSS of the file to be zipped +! ZHHMMSS = HH +! +! ! Reconstruct name of file to be zipped +! ZIP_FILENAME = TRIM(TO_ZIP_FILENAME) +! +! ! Replace YYYY, MM, DD, HH tokens in ZIP_FILENAME w/actual values +! CALL EXPAND_DATE( ZIP_FILENAME, DATE(1), ZHHMMSS ) +! +! ! Add ADJ_DIR prefix to filename +! ZIP_FILENAME = TRIM( ADJ_DIR ) // TRIM( ZIP_FILENAME ) +! +! ! Create zip command +! ZIP_FILE_CMD = TRIM( GZIP_CMD ) // ' ' // +! & TRIM( ZIP_FILENAME ) +! CALL SYSTEM( TRIM ( ZIP_FILE_CMD ) ) +! WRITE( 6, 101 ) TRIM( ZIP_FILE_CMD ) +! 101 FORMAT( ' - BATCH_ZIP: Executing: ',a ) +! +! ENDDO +!!$OMP END PARALLEL DO +! +! ! Only continue when dealing with *.adj.* files +! IF (FID /= 'adj' ) RETURN +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( ZIP_FILENAME, HH ) +!!$OMP+PRIVATE( ZIP_FILE_CMD, ZHHMMSS ) +! DO HH = 003000, HH_MAX + 3000, ZIP_INTERVAL +! +! ! Set the HHMMSS of the file to be zipped +! ZHHMMSS = HH +! +! ! Replace YYYY, MM, DD, HH tokens in ZIP_FILENAME w/actual values +! CALL EXPAND_DATE( ZIP_FILENAME, DATE(1), ZHHMMSS ) +! +! ! Add ADJ_DIR prefix to filename +! ZIP_FILENAME = TRIM( ADJ_DIR ) // TRIM( ZIP_FILENAME ) +! +! ! Create zip command +! ZIP_FILE_CMD = TRIM( GZIP_CMD ) // ' ' // +! & TRIM( ZIP_FILENAME ) +! CALL SYSTEM( TRIM ( ZIP_FILE_CMD ) ) +! WRITE( 6, 101 ) TRIM( ZIP_FILE_CMD ) +! +! ENDDO +!!$OMP END PARALLEL DO +! +! +! END SUBROUTINE BATCH_ZIP +! +!!---------------------------------------------------------------------- + + SUBROUTINE CHECK_DIMENSIONS_2( XPASS, YPASS, ZPASS, + & XTRUE, YTRUE, ZTRUE ) +! +!****************************************************************************** +! Subroutine CHECK_DIMENSIONS_2makes sure that the dimensions of the +! data for block that was checkpointed are correct. XPASS should equal XTRUE, +! etc. +! (dkh, 07/22/05) +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + + ! Arguments + INTEGER, INTENT(IN) :: XPASS, YPASS, ZPASS + INTEGER, INTENT(IN) :: XTRUE, YTRUE, ZTRUE + + !================================================================= + ! CHECK_DIMENSIONS_2 begins here! + !================================================================= + + ! Error check longitude dimension: NI must equal IIPAR + IF ( XPASS /= XTRUE .OR. + & YPASS /= YTRUE .OR. + & ZPASS /= ZTRUE ) THEN + print*, XPASS, XTRUE + print*, YPASS, YTRUE + print*, ZPASS, ZTRUE + WRITE( 6, '(a)' ) 'ERROR reading in checkpt file!' + WRITE( 6, '(a)' ) 'Wrong number of grid cells encountered!' + WRITE( 6, '(a)' ) 'STOP in CHECK_DIMENSIONS_2 (checkpt_mod.f)' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK_DIMENSIONS_2 + +!---------------------------------------------------------------------- +! +! SUBROUTINE MAKE_SAVE_FILE( YYYYMMDD, HHMMSS, N_CALC ) +!! +!!****************************************************************************** +!! Subroutine MAKE_SAVE_FILE creates GEOS-CHEM checkpt files of tracer +!! concentrations [kg/box]. +!! For use in checking chemistry adjoints. (dkh, 07/19/06) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) YYYYMMDD : Year-Month-Date +!! (2 ) HHMMSS : and Hour-Min-Sec for which to create a checkpoint file +!! (3 ) N_CALC : Current iteration +!! +!! Passed via CMN: +!! ============================================================================ +!! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +!! +!! Passed via ???: +!! ============================================================================ +!! (1 ) CHECKPT : Array of quantities to be checkpointed +!! dim=(IIPAR,JJPAR,LLPAR,NCHECKPT) +!! +!! NOTES: +!! Just like MAKE_CHECKPT_FILE except: +!! +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD +! USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU +! USE COMODE_MOD, ONLY : CSPEC_PRIOR , JLOP +!! USE GCKPP_PARAMETERS, ONLY : NVAR +! USE GCKPP_ADJ_GLOBAL, ONLY : NTLOOP_FORKPP_ADJ +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN" ! TAU , NSRCX +!# include "CMN_ADJ" ! NRPIN, NRPOUT, L_ZIP_CHECKPT, GZIP_CMD, ADJ_DIR, NOBS +!# include "CMN_SETUP" ! LWETD +!# include "comode.h" ! IGAS +! +! ! Arguments +! INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS, N_CALC +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, N, JLOOP +! INTEGER :: YYYY, MM, DD, HH, SS, ZIP_HH +! CHARACTER(LEN=255) :: FILENAME +! +! ! Temporary storage arrays for checkpointed variables +! REAL*4 :: CHECK_FINAL(IIPAR,JJPAR,LLPAR) +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! +! +! !================================================================= +! ! MAKE_SAVE_FILE begins here! +! !================================================================= +! +! ! Hardwire output file for now +!#if defined( GEOS_1 ) || defined( GEOS_STRAT ) +! OUTPUT_CHECKPT_FILE = 'gctm.save.YYMMDD.hhmmss.NN' +!#else +! OUTPUT_CHECKPT_FILE = 'gctm.save.YYYYMMDD.hhmmss.NN' +!#endif +! +! ! Clear some arrays +! CHECK_FINAL(:,:,:) = 0e0 +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM Checkpoint File: ' // +! & 'Instantaneous Tracer Concentrations (v/v)' +! CATEGORY = 'IJ-CHK-$' +! LONRES = DISIZE +! LATRES = DJSIZE +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the save file for output -- binary punch format +! !================================================================= +! +! ! Copy the output checkpoint file name into a local variable +! FILENAME = TRIM( OUTPUT_CHECKPT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! +! ! Add ADJ_DIR prefix to filename +! FILENAME = TRIM( ADJ_DIR ) // TRIM( FILENAME ) +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_SAVE_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +! !================================================================= +! ! Write each checkpointed quantity to the checkpoint file +! !================================================================= +! +! ! Write the final concetration values as saved at the end of geos_mod.f +! UNIT = 'kg/box' +! DO N = 1, NOBS +! +! ! Temporarily store data in CHECK_FINAL +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHECK_FINAL(I,J,L) = CHK_STT(I,J,L,N) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, CHECK_FINAL ) +! ENDDO +! +! ! Close file +! CLOSE( IU_RST ) +! +! ! Zip files +! IF ( L_ZIP_CHECKPT ) CALL BATCH_ZIP( YYYYMMDD, HHMMSS, 'save', 1 ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_SAVE_FILE: wrote file' ) +! +! ! Return to calling program +! END SUBROUTINE MAKE_SAVE_FILE +!!----------------------------------------------------------------------- +! +! SUBROUTINE MAKE_SAVE_FILE_2( YYYYMMDD, HHMMSS, N_CALC ) +!! +!!****************************************************************************** +!! Subroutine MAKE_SAVE_FILE_2 creates GEOS-CHEM checkpt files of tracer +!! concentrations [kg/box]. Like MAKE_SAVE_FILE, except calculate the finite +!! difference sensitivities directly. Save these, the adjoint sensitivities, +!! and the ratio adj / fd. Save first and 2nd order finite difference +!! sensitivities. Requires running to XSTOP = 3. +!! For use in checking process specific adjoints. (dkh, 01/23/07) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) YYYYMMDD : Year-Month-Date +!! (2 ) HHMMSS : and Hour-Min-Sec for which to create a checkpoint file +!! (3 ) N_CALC : Current iteration +!! +!! Passed via CMN: +!! ============================================================================ +!! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +!! +!! Passed via ???: +!! ============================================================================ +!! (1 ) CHECKPT : Array of quantities to be checkpointed +!! dim=(IIPAR,JJPAR,LLPAR,NCHECKPT) +!! +!! NOTES: +!! Just like MAKE_CHECKPT_FILE except: +!! (1 ) Now write out both sets of 1st order FD gradients, and define a new +!! category (FD-TEST) for viewing in gamap. (dkh, 10/10/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD +! USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU +! USE COMODE_MOD, ONLY : CSPEC_PRIOR , JLOP +!! USE GCKPP_PARAMETERS, ONLY : NVAR +! USE GCKPP_ADJ_GLOBAL, ONLY : NTLOOP_FORKPP_ADJ +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN" ! TAU , NSRCX +!# include "CMN_ADJ" ! NRPIN, NRPOUT, L_ZIP_CHECKPT, GZIP_CMD, ADJ_DIR, NOBS +!# include "CMN_SETUP" ! LWETD +!# include "comode.h" ! IGAS +! +! ! Arguments +! INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS, N_CALC +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, N, JLOOP +! INTEGER :: YYYY, MM, DD, HH, SS, ZIP_HH +! CHARACTER(LEN=255) :: FILENAME +! !CHARACTER(LEN=255) :: INPUT_CHECKPT_FILE +! CHARACTER(LEN=255) :: INPUT_GDT_FILE +! INTEGER :: N_OFF(IIPAR,JJPAR) +! REAL*8, PARAMETER :: FILTER = 1d0 +! +! ! Temporary storage arrays for checkpointed variables +! REAL*8 :: CHK_STT_1(IIPAR,JJPAR,LLPAR,NOBS) +! REAL*8 :: CHK_STT_2(IIPAR,JJPAR,LLPAR,NOBS) +! REAL*8 :: CHK_STT_3(IIPAR,JJPAR,LLPAR,NOBS) +! REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +! REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) +! REAL*8 :: ADJ(IIPAR,JJPAR,1) +! REAL*4 :: TRACER_2D(IIPAR,JJPAR,1) +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER :: HALFPOLAR +! INTEGER :: CENTER180 +! +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! +! INTEGER :: NI, NJ, NL +! INTEGER :: IFIRST, JFIRST, LFIRST +! INTEGER :: NTRACER, NSKIP +! REAL*8 :: ZTAU0, ZTAU1 +! +! +! !================================================================= +! ! MAKE_SAVE_FILE_2 begins here! +! !================================================================= +! +! +! ! Clear some arrays +! CHK_STT_1(:,:,:,:) = 0e0 +! CHK_STT_2(:,:,:,:) = 0e0 +! CHK_STT_3(:,:,:,:) = 0e0 +! EMS_3D(:,:,:) = 0d0 +! ADJ(:,:,:) = 0e0 +! TRACER(:,:,:) = 0e0 +! TRACER_2D(:,:,:) = 0e0 +! N_OFF(:,:) = 0d0 +! +! !======================================== +! ! Read *.save* file from unperturbed run +! !======================================== +! INPUT_CHECKPT_FILE = 'gctm.save.YYYYMMDD.hhmmss.NN' +! +! ! Copy input file name to a local variable +! FILENAME = TRIM( INPUT_CHECKPT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, 1 ) +! +! ! Add ADJ_DIR prefix to name +! FILENAME = TRIM( ADJ_DIR ) // TRIM( FILENAME ) +! +! ! Echo some input to the screen +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, '(a,/)' ) 'C H E C K P T F I L E I N P U T' +! +! +! WRITE( 6, 400 ) TRIM( FILENAME ) +! 400 FORMAT( ' - READ_CHECKPT_FILE: Reading ', a ) +! +! ! Open the binary punch file for input +! CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +! +! !================================================================= +! ! Read checkpointed variables +! !================================================================= +! ! Read the values of CHK_STT +! DO N = 1, NOBS +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:7' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) +! & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:8' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:9' ) +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +! ! Only process checkpoint data (i.e. mixing ratio) +! IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN +! +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! !CALL CHECK_DIMENSIONS( NI, NJ, NL ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHK_STT_1(I,J,L,N) = TRACER(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! ! Close file +! CLOSE( IU_RST ) +! +! +! !======================================== +! ! Read *.save* file from perturbed run +! !======================================== +! INPUT_CHECKPT_FILE = 'gctm.save.YYYYMMDD.hhmmss.NN' +! +! ! Copy input file name to a local variable +! FILENAME = TRIM( INPUT_CHECKPT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, 2 ) +! +! ! Add ADJ_DIR prefix to name +! FILENAME = TRIM( ADJ_DIR ) // TRIM( FILENAME ) +! +! ! Echo some input to the screen +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, '(a,/)' ) 'C H E C K P T F I L E I N P U T' +! +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_CHECKPT_FILE: Reading ', a ) +! +! ! Open the binary punch file for input +! CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +! +! !================================================================= +! ! Read checkpointed variables +! !================================================================= +! ! Read the values of CHK_STT +! DO N = 1, NOBS +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:7' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) +! & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:8' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:9' ) +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +! ! Only process checkpoint data (i.e. mixing ratio) +! IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN +! +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! !CALL CHECK_DIMENSIONS( NI, NJ, NL ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHK_STT_2(I,J,L,N) = TRACER(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! ! Close file +! CLOSE( IU_RST ) +! +! !======================================== +! ! Read *.save* file from 2nd perturbed run +! !======================================== +! INPUT_CHECKPT_FILE = 'gctm.save.YYYYMMDD.hhmmss.NN' +! +! ! Copy input file name to a local variable +! FILENAME = TRIM( INPUT_CHECKPT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, 3 ) +! +! ! Add ADJ_DIR prefix to name +! FILENAME = TRIM( ADJ_DIR ) // TRIM( FILENAME ) +! +! ! Echo some input to the screen +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, '(a,/)' ) 'C H E C K P T F I L E I N P U T' +! +! +! WRITE( 6, 888 ) TRIM( FILENAME ) +! 888 FORMAT( ' - READ_CHECKPT_FILE: Reading ', a ) +! +! ! Open the binary punch file for input +! CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +! +! !================================================================= +! ! Read checkpointed variables +! !================================================================= +! ! Read the values of CHK_STT +! DO N = 1, NOBS +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:7' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) +! & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:8' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:9' ) +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +! ! Only process checkpoint data (i.e. mixing ratio) +! IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN +! +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! !CALL CHECK_DIMENSIONS( NI, NJ, NL ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHK_STT_3(I,J,L,N) = TRACER(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! ! Close file +! CLOSE( IU_RST ) +! +! !======================================== +! ! Read *.gdt.* file from unperturbed run +! !======================================== +! ! Hardwire output file for now +! INPUT_GDT_FILE = 'gctm.gdt.01' +! +! ! Initialize some variables +! TRACER(:,:,:) = 0e0 +! +! !================================================================= +! ! Open gradient file and read top-of-file header +! !================================================================= +! +! ! Copy input file name to a local variable +! FILENAME = TRIM( INPUT_GDT_FILE ) +! +! ! Add OPT_DATA_DIR prefix to FILENAME +! FILENAME = TRIM( OPT_DATA_DIR ) // TRIM( FILENAME ) +! +! ! Echo some input to the screen +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, '(a,/)' ) 'G D T F I L E I N P U T' +! WRITE( 6, 101 ) TRIM( FILENAME ) +! 101 FORMAT( 'READ_GDT_FILE: Reading ', a ) +! +! ! Open the binary punch file for input +! CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +! +! !================================================================= +! ! Read adjoints -- store in the TRACER array +! !================================================================= +! DO N = 1, NNEMS +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:5' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( EMS_3D(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:7') +! +! !============================================================== +! ! Assign data from the TRACER array to the ADJ_STT array. +! !============================================================== +! +! ! Only process observation data (i.e. aerosol and precursors) +! IF ( CATEGORY(1:8) == 'IJ-GDE-$' .and. N == EMSFD +! & .and. MMSCL == 1 ) THEN +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! ADJ(I,J,1) = EMS_3D(I,J,1) +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! ! Close file +! CLOSE( IU_RST ) +! +! +! !======================================== +! ! Write 2nd order FD gradient +! !======================================== +! L = LFD +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! TRACER_2D(I,J,1) =(CHK_STT_2(I,J,L,NFD) - CHK_STT_3(I,J,L,NFD)) +! & / (2 * FD_DIFF ) +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! Hardwire output file for now +! OUTPUT_CHECKPT_FILE = 'gctm.save2.YYYYMMDD.hhmmss' +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM Checkpoint File: ' // +! & 'Instantaneous Tracer Concentrations (v/v)' +! CATEGORY = 'FD-TEST' +! LONRES = DISIZE +! LATRES = DJSIZE +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the save file for output -- binary punch format +! !================================================================= +! +! ! Copy the output checkpoint file name into a local variable +! FILENAME = TRIM( OUTPUT_CHECKPT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) +! +! ! Add ADJ_DIR prefix to filename +! FILENAME = TRIM( ADJ_DIR ) // TRIM( FILENAME ) +! +! WRITE( 6, 102 ) TRIM( FILENAME ) +! 102 FORMAT( ' - MAKE_SAVE_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +! UNIT = 'kg/box' +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 1, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_2D ) +! +! !======================================== +! ! Write ADJ gradient +! !======================================== +! UNIT = 'kg/box' +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 2, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, REAL(ADJ) ) +! +! !======================================== +! ! Write ADJ / FD ratio +! !======================================== +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! IF ( ABS(TRACER_2D(I,J,1)) .gt. FILTER ) THEN +! +! TRACER_2D(I,J,1) = REAL(ADJ(I,J,1)) / TRACER_2D(I,J,1) +! +! ELSE +! +! TRACER_2D(I,J,1) = 1d0 +! +! ENDIF +! +! ! Keep track of number of points that are off +! IF ( ( TRACER_2D(I,J,1) > 1d0 + FD_DIFF ) .OR. +! & ( TRACER_2D(I,J,1) < 1D0 - FD_DIFF ) ) THEN +! N_OFF(I,J) = 1 +! ENDIF +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! UNIT = 'none' +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 3, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_2D ) +! +! ! print out statistics of the ADJ / FD ratio +! WRITE(6,*) '====================================================' +! WRITE(6,*) ' Global validation test for values > ', FILTER +! WRITE(6,*) ' MAX of global 2nd order ADJ / FD = ', +! & MAXVAL(TRACER_2D(:,:,1)) +! WRITE(6,*) ' MIN of global 2nd order ADJ / FD = ', +! & MINVAL(TRACER_2D(:,:,1)) +! WRITE(6,*) ' Number of places where ratio off by ',FD_DIFF,' = ', +! & SUM(N_OFF(:,:)) +! WRITE(6,*) '====================================================' +! +! !======================================== +! ! Write 1st order FD gradient +! !======================================== +! UNIT = 'kg/box' +! L = LFD +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! TRACER_2D(I,J,1) =(CHK_STT_2(I,J,L,NFD) - CHK_STT_1(I,J,L,NFD)) +! & / FD_DIFF +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 4, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_2D ) +! +! !======================================== +! ! Write chekpt values +! !======================================== +! UNIT = 'kg/box' +! L = LFD +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! TRACER_2D(I,J,1) = CHK_STT_1(I,J,L,NFD) +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 5, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_2D ) +! +! !======================================== +! ! Write the other 1st order FD gradient. (dkh, 10/10/08) +! !======================================== +! UNIT = 'kg/box' +! L = LFD +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! TRACER_2D(I,J,1) =(CHK_STT_3(I,J,L,NFD) - CHK_STT_1(I,J,L,NFD)) +! & / ( - FD_DIFF ) +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 6, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_2D ) +! +! ! Close file +! CLOSE( IU_RST ) +! +! ! Zip files +! IF ( L_ZIP_CHECKPT ) CALL BATCH_ZIP( YYYYMMDD, HHMMSS, 'save', 1 ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_SAVE_FILE_2: wrote file' ) +! +! +! ! Return to calling program +! END SUBROUTINE MAKE_SAVE_FILE_2 +!!---------------------------------------------------------------------- +! +! SUBROUTINE MAKE_SAVE_FILE_3( YYYYMMDD, N_CALC ) +!! +!!****************************************************************************** +!! Subroutine MAKE_SAVE_FILE_3 creates GEOS-CHEM checkpt files of radiative +!! forcing [kg/box]. Like MAKE_SAVE_FILE_2, it saves these, the adjoint +!! sensitivities, and the ratio adj / fd. Requires running to XSTOP = 3. +!! For use in checking process specific adjoints. (dkh, 07/09/08) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) YYYYMMDD : Year-Month-Date +!! (2 ) N_CALC : Current iteration +!! +!! Passed via CMN: +!! ============================================================================ +!! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +!! +!! Passed via ???: +!! ============================================================================ +!! (1 ) CHECKPT : Array of quantities to be checkpointed +!! dim=(IIPAR,JJPAR,LLPAR,NCHECKPT) +!! +!! NOTES: +!! Just like MAKE_CHECKPT_FILE except: +!! +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD +! USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU +! USE COMODE_MOD, ONLY : CSPEC_PRIOR , JLOP +!! USE GCKPP_PARAMETERS, ONLY : NVAR +! USE GCKPP_ADJ_GLOBAL, ONLY : NTLOOP_FORKPP_ADJ +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN" ! TAU , NSRCX +!# include "CMN_ADJ" ! NRPIN, NRPOUT, L_ZIP_CHECKPT, GZIP_CMD, ADJ_DIR, NOBS +!# include "CMN_SETUP" ! LWETD +!# include "comode.h" ! IGAS +! +! ! Arguments +! INTEGER, INTENT(IN) :: YYYYMMDD, N_CALC +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, N, W, JLOOP +! INTEGER :: YYYY, MM, DD, HH, SS, ZIP_HH +! INTEGER :: HHMMSS_dum +! CHARACTER(LEN=255) :: FILENAME +! CHARACTER(LEN=255) :: INPUT_GDT_FILE +! CHARACTER(LEN=255) :: INPUT_AOD_FILE +! INTEGER :: N_OFF(IIPAR,JJPAR) +! REAL*8, PARAMETER :: FILTER = 1d-10 +! +! ! Temporary storage arrays for checkpointed variables +! REAL*8 :: CHK_RAD_1(IIPAR,JJPAR) +! REAL*8 :: CHK_RAD_2(IIPAR,JJPAR) +! REAL*8 :: CHK_RAD_3(IIPAR,JJPAR) +! REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +! REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) +! REAL*8 :: ADJ(IIPAR,JJPAR,1) +! REAL*4 :: TRACER_2D(IIPAR,JJPAR,1) +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER :: HALFPOLAR +! INTEGER :: CENTER180 +! +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! +! INTEGER :: NI, NJ, NL +! INTEGER :: IFIRST, JFIRST, LFIRST +! INTEGER :: NTRACER, NSKIP +! REAL*8 :: ZTAU0, ZTAU1 +! +! INTEGER, PARAMETER :: NWL_MAX = 5 +! +! !================================================================= +! ! MAKE_SAVE_FILE_3 begins here! +! !================================================================= +! +! +! ! Clear some arrays +! CHK_RAD_1(:,:) = 0e0 +! CHK_RAD_2(:,:) = 0e0 +! CHK_RAD_3(:,:) = 0e0 +! EMS_3D(:,:,:) = 0d0 +! ADJ(:,:,:) = 0e0 +! TRACER(:,:,:) = 0e0 +! TRACER_2D(:,:,:) = 0e0 +! N_OFF(:,:) = 0d0 +! +! !======================================== +! ! Read *.save* file from unperturbed run +! !======================================== +! !INPUT_CHECKPT_FILE = 'gctm.save.YYYYMMDD.hhmmss.NN' +! INPUT_AOD_FILE = 'aod.YYYYMMDD.NN' +! +! ! Copy input file name to a local variable +! FILENAME = TRIM( INPUT_AOD_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS_dum ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, 1 ) +! +! ! Add ADJ_DIR prefix to name +! FILENAME = TRIM( ADJ_DIR ) // TRIM( FILENAME ) +! +! ! Echo some input to the screen +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, '(a,/)' ) 'A O D F I L E I N P U T' +! +! +! WRITE( 6, 401 ) TRIM( FILENAME ) +! 401 FORMAT( ' - MAKE_SAVE_FILE_3: Reading ', a ) +! +! ! Open the binary punch file for input +! CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +! +! !================================================================= +! ! Read checkpointed variables +! !================================================================= +! ! Read the values of CHK_STT +! DO W = 1, NWL_MAX * 3 + 1 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:7' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) +! & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:8' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:9' ) +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +! ! Only process checkpoint data (i.e. mixing ratio) +! IF ( CATEGORY(1:8) == 'IJ-AOD-$' .and. +! & W == NWL_MAX * 3 + 1 ) THEN +! +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! !CALL CHECK_DIMENSIONS( NI, NJ, NL ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHK_RAD_1(I,J) = TRACER(I,J,1) +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! ! Close file +! CLOSE( IU_RST ) +! +! +! !======================================== +! ! Read *.save* file from perturbed run +! !======================================== +! !INPUT_CHECKPT_FILE = 'gctm.save.YYYYMMDD.hhmmss.NN' +! INPUT_AOD_FILE = 'aod.YYYYMMDD.NN' +! +! ! Copy input file name to a local variable +! FILENAME = TRIM( INPUT_AOD_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS_dum ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, 2 ) +! +! ! Add ADJ_DIR prefix to name +! FILENAME = TRIM( ADJ_DIR ) // TRIM( FILENAME ) +! +! ! Echo some input to the screen +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, '(a,/)' ) 'A O D F I L E I N P U T' +! +! +! WRITE( 6, 101 ) TRIM( FILENAME ) +! 101 FORMAT( ' - MAKE_SAVE_FILE_3: Reading ', a ) +! +! ! Open the binary punch file for input +! CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +! +! !================================================================= +! ! Read checkpointed variables +! !================================================================= +! ! Read the values of CHK_STT +! DO W = 1, NWL_MAX*3 + 1 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:7' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) +! & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:8' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:9' ) +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +! ! Only process checkpoint data (i.e. mixing ratio) +! IF ( CATEGORY(1:8) == 'IJ-AOD-$' .and. +! & W == NWL_MAX * 3 + 1 ) THEN +! +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! !CALL CHECK_DIMENSIONS( NI, NJ, NL ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHK_RAD_2(I,J) = TRACER(I,J,1) +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! ! Close file +! CLOSE( IU_RST ) +! +! !======================================== +! ! Read *.save* file from 2nd perturbed run +! !======================================== +! !INPUT_CHECKPT_FILE = 'gctm.save.YYYYMMDD.hhmmss.NN' +! INPUT_AOD_FILE = 'aod.YYYYMMDD.NN' +! +! ! Copy input file name to a local variable +! FILENAME = TRIM( INPUT_AOD_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS_dum ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, 3 ) +! +! ! Add ADJ_DIR prefix to name +! FILENAME = TRIM( ADJ_DIR ) // TRIM( FILENAME ) +! +! ! Echo some input to the screen +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, '(a,/)' ) 'A O D F I L E I N P U T' +! +! +! WRITE( 6, 889 ) TRIM( FILENAME ) +! 889 FORMAT( ' - MAKE_SAVE_FILE_3: Reading ', a ) +! +! ! Open the binary punch file for input +! CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +! +! !================================================================= +! ! Read checkpointed variables +! !================================================================= +! ! Read the values of CHK_STT +! DO W = 1, NWL_MAX * 3 + 1 +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:7' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) +! & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:8' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) +! & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:9' ) +! +! !============================================================== +! ! Assign data from the TRACER array to the STT array. +! !============================================================== +! +! ! Only process checkpoint data (i.e. mixing ratio) +! IF ( CATEGORY(1:8) == 'IJ-AOD-$' .and. +! & W == NWL_MAX * 3 + 1 ) THEN +! +! ! Make sure array dimensions are of global size +! ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run +! !CALL CHECK_DIMENSIONS( NI, NJ, NL ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! CHK_RAD_3(I,J) = TRACER(I,J,1) +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! ! Close file +! CLOSE( IU_RST ) +! +! !======================================== +! ! Read *.gdt.* file from unperturbed run +! !======================================== +! ! Hardwire output file for now +! INPUT_GDT_FILE = 'gctm.gdt.01' +! +! ! Initialize some variables +! TRACER(:,:,:) = 0e0 +! +! !================================================================= +! ! Open gradient file and read top-of-file header +! !================================================================= +! +! ! Copy input file name to a local variable +! FILENAME = TRIM( INPUT_GDT_FILE ) +! +! ! Add OPT_DATA_DIR prefix to FILENAME +! FILENAME = TRIM( OPT_DATA_DIR ) // TRIM( FILENAME ) +! +! ! Echo some input to the screen +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, '(a,/)' ) 'G D T F I L E I N P U T' +! WRITE( 6, 109 ) TRIM( FILENAME ) +! 109 FORMAT( 'READ_GDT_FILE: Reading ', a ) +! +! ! Open the binary punch file for input +! CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) +! +! !================================================================= +! ! Read adjoints -- store in the TRACER array +! !================================================================= +! DO N = 1, NNEMS +! READ( IU_RST, IOSTAT=IOS ) +! & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 +! +! ! IOS < 0 is end-of-file, so exit +! IF ( IOS < 0 ) EXIT +! +! ! IOS > 0 is a real I/O error -- print error message +! IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:5' ) +! +! READ( IU_RST, IOSTAT=IOS ) +! & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, +! & NI, NJ, NL, IFIRST, JFIRST, LFIRST, +! & NSKIP +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:5') +! +! READ( IU_RST, IOSTAT=IOS ) +! & ( ( ( EMS_3D(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) +! +! IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:7') +! +! !============================================================== +! ! Assign data from the TRACER array to the ADJ_STT array. +! !============================================================== +! +! ! Only process observation data (i.e. aerosol and precursors) +! IF ( CATEGORY(1:8) == 'IJ-GDE-$' .and. N == EMSFD +! & .and. MMSCL == 1 ) THEN +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! ADJ(I,J,1) = EMS_3D(I,J,1) +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! ENDDO +! ! Close file +! CLOSE( IU_RST ) +! +! +! !======================================== +! ! Write 2nd order FD gradient +! !======================================== +! !L = LFD +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! TRACER_2D(I,J,1) =(CHK_RAD_2(I,J) - CHK_RAD_3(I,J)) +! & / (2 * FD_DIFF ) +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! Hardwire output file for now +! OUTPUT_CHECKPT_FILE = 'gctm.save2.YYYYMMDD' +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM Checkpoint File: ' // +! & 'Instantaneous Tracer Concentrations (v/v)' +! CATEGORY = 'IJ-CHK-$' +! LONRES = DISIZE +! LATRES = DJSIZE +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the save file for output -- binary punch format +! !================================================================= +! +! ! Copy the output checkpoint file name into a local variable +! FILENAME = TRIM( OUTPUT_CHECKPT_FILE ) +! +! ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values +! CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS_dum ) +! +! ! Add ADJ_DIR prefix to filename +! FILENAME = TRIM( ADJ_DIR ) // TRIM( FILENAME ) +! +! WRITE( 6, 102 ) TRIM( FILENAME ) +! 102 FORMAT( ' - MAKE_SAVE_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +! UNIT = 'kg/box' +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 1, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_2D ) +! +! !======================================== +! ! Write ADJ gradient +! !======================================== +! UNIT = 'kg/box' +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 2, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, REAL(ADJ) ) +! +! print*, 'MAKE_SAVE_FILE_3 : RAD 1 = ', CHK_RAD_1(IFD,JFD) +! print*, 'MAKE_SAVE_FILE_3 : RAD 2 = ', CHK_RAD_2(IFD,JFD) +! print*, 'MAKE_SAVE_FILE_3 : RAD 3 = ', CHK_RAD_3(IFD,JFD) +! print*, 'MAKE_SAVE_FILE_3 : 2ord FD = ', TRACER_2D(IFD,JFD,1) +! print*, 'MAKE_SAVE_FILE_3 : ADJ = ', ADJ(IFD,JFD,1) +! +! !======================================== +! ! Write ADJ / FD ratio +! !======================================== +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! IF ( ABS(TRACER_2D(I,J,1)) .gt. FILTER ) THEN +! +! TRACER_2D(I,J,1) = REAL(ADJ(I,J,1)) / TRACER_2D(I,J,1) +! +! ELSE +! +! TRACER_2D(I,J,1) = 1d0 +! +! ENDIF +! +! ! Keep track of number of points that are off +! IF ( ( TRACER_2D(I,J,1) > 1d0 + FD_DIFF ) .OR. +! & ( TRACER_2D(I,J,1) < 1D0 - FD_DIFF ) ) THEN +! N_OFF(I,J) = 1 +! ENDIF +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! UNIT = 'none' +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 3, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_2D ) +! +! ! print out statistics of the ADJ / FD ratio +! WRITE(6,*) '====================================================' +! WRITE(6,*) ' Global validation test for values > ', FILTER +! WRITE(6,*) ' MAX of global 2nd order ADJ / FD = ', +! & MAXVAL(TRACER_2D(:,:,1)) +! WRITE(6,*) ' MIN of global 2nd order ADJ / FD = ', +! & MINVAL(TRACER_2D(:,:,1)) +! WRITE(6,*) ' Number of places where ratio off by ',FD_DIFF,' = ', +! & SUM(N_OFF(:,:)) +! WRITE(6,*) '====================================================' +! +! !======================================== +! ! Write 1st order FD gradient +! !======================================== +! UNIT = 'kg/box' +! !L = LFD +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! TRACER_2D(I,J,1) =(CHK_RAD_2(I,J) - CHK_RAD_1(I,J)) +! & / FD_DIFF +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 4, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_2D ) +! +! !======================================== +! ! Write chekpt values +! !======================================== +! UNIT = 'kg/box' +! !L = LFD +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! TRACER_2D(I,J,1) = CHK_RAD_1(I,J) +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 5, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_2D ) +! ! Close file +! CLOSE( IU_RST ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_SAVE_FILE_3: wrote file' ) +! +! +! ! Return to calling program +! END SUBROUTINE MAKE_SAVE_FILE_3 +!!---------------------------------------------------------------------- + + SUBROUTINE MAKE_FD_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine MAKE_FD_FILE creates GEOS-CHEM checkpt files of tracer +! concentrations [kg/box]. +! For use in checking chemistry adjoints. (dkh, 07/19/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a checkpoint file +! +! NOTES: +! (1 ) Updated from MAKE_SAVE_FILE to v8, rename, replace CMN_ADJ, etc +! (dkh, ks, mak, cs, 06/09/09) +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : NFD + USE ADJ_ARRAYS_MOD, ONLY : LFD + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ADJ_ARRAYS_MOD, ONLY : NTR2NOBS + USE ADJ_ARRAYS_MOD, ONLY : DDEP_TRACER + USE ADJ_ARRAYS_MOD, ONLY : DDEP_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : NOBS2NWDEP + USE ADJ_ARRAYS_MOD, ONLY : WDEP_CV, WDEP_LS +! USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE BPCH2_MOD + USE DIAG_MOD, ONLY : AD38 + USE DIAG_MOD, ONLY : AD39 + USE DIAG_MOD, ONLY : AD44 + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR +! USE DRYDEP_MOD, ONLY : NTRAIND +! USE DRYDEP_MOD, ONLY : NUMDEP + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TIME_MOD, ONLY : GET_TS_DYN + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : STT + USE TRACERID_MOD, ONLY : IDTRMB +! USE WETSCAV_MOD, ONLY : GET_WETDEP_IDWETD +! USE WETSCAV_MOD, ONLY : NSOL + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! CSPEC + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: OUTPUT_FD_FILE + INTEGER :: NFD_DEP + + ! Temporary storage arrays for checkpointed variables + REAL*4 :: TEMP(IIPAR,JJPAR,LLPAR) + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + + !================================================================= + ! MAKE_FD_FILE begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_FD_FILE = 'gctm.fd.YYYYMMDD.hhmm.NN' + + ! Clear some arrays + TEMP(:,:,:) = 0e0 + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM Checkpoint File: ' // + & 'Instantaneous Tracer Concentrations (v/v)' + CATEGORY = 'IJ-CHK-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the save file for output -- binary punch format + !================================================================= + + ! Copy the output checkpoint file name into a local variable + FILENAME = TRIM( OUTPUT_FD_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add ADJ_DIR prefix to filename + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_FD_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each checkpointed quantity to the checkpoint file + !================================================================= + + ! concentration based cost function + IF ( .not. LADJ_FDEP ) THEN + + ! Write the final concetration values as saved at the end of geos_mod.f + UNIT = 'kg/box' + + ! Temporarily store data in CHECK_FINAL +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + !TEMP(I,J,L) = CHK_STT(I,J,L,N) + TEMP(I,J,L) = STT(I,J,L,NFD) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! aerosol dry dep + ELSEIF ( LADJ_DDEP_TRACER ) THEN + + ! Write the final concetration values as saved at the end of geos_mod.f + UNIT = 'molec/cm2/s' + + + NFD_DEP = NTR2NOBS(NFD) + + ! Temporarily store data in TEMP +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + TEMP(I,J,LFD) = DDEP_TRACER(I,J,NFD_DEP) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! gas phase dry dep + ELSEIF ( LADJ_DDEP_CSPEC ) THEN + + ! Write the final concetration values as saved at the end of geos_mod.f + UNIT = 'molec/cm2/s' + + ! No conversion of NFD to NFD_DEP necessary, since NFD directly refers + ! to element of NOBS_CSPEC when FD testing of CSPEC species + ! Temporarily store data in TEMP +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + TEMP(I,J,LFD) = DDEP_CSPEC(I,J,NFD) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! wetdep LS + ELSEIF ( LADJ_WDEP_LS ) THEN + + ! Write the final concetration values as saved at the end of geos_mod.f + UNIT = 'kg/s' + + ! Map NFD_DEP from NFD + NFD_DEP = NTR2NOBS(NFD) + + ! Temporarily store data in TEMP +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + TEMP(I,J,LFD) = WDEP_LS(I,J,NFD_DEP) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! wetdep CV + ELSEIF ( LADJ_WDEP_CV ) THEN + + ! Write the final concetration values as saved at the end of geos_mod.f + UNIT = 'kg/s' + + ! Map NFD_DEP from NFD + NFD_DEP = NTR2NOBS(NFD) + + ! Temporarily store data in TEMP +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + TEMP(I,J,LFD) = WDEP_CV(I,J,NFD_DEP) + ENDDO + ENDDO +!OMP END PARALLEL DO + + ENDIF + + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TEMP ) + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_FD_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_FD_FILE +!----------------------------------------------------------------------- + + SUBROUTINE MAKE_FDGLOB_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine MAKE_FDGLOB_FILE creates GEOS-CHEM checkpt files of tracer +! concentrations [kg/box]. Like MAKE_FD_FILE, except calculate the finite +! difference sensitivities directly. Save these, the adjoint sensitivities, +! and the ratio adj / fd. Save first and 2nd order finite difference +! sensitivities. Requires running to XSTOP = 3. +! For use in checking process specific adjoints. (dkh, 01/23/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a checkpoint file +! +! NOTES: +! (1 ) Now write out both sets of 1st order FD gradients, and define a new +! category (FD-TEST) for viewing in gamap. (dkh, 10/10/08) +! (2 ) Updated from MAKE_SAVE_FILE to v8, rename, replace CMN_ADJ, etc +! (dkh, ks, mak, cs, 06/09/09) +! (3 ) NNEMS Now in tracerid_adj_mod.f (mak, 6/14/09) +! (4 ) Updated to include LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : NFD, EMSFD, MFD, LFD, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : FD_DIFF, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD + USE ADJ_ARRAYS_MOD, ONLY : STRFD + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE ADJ_ARRAYS_MOD, ONLY : RATFD, NRRATES + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS, LICS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: INPUT_GDT_FILE + CHARACTER(LEN=255) :: INPUT_FD_FILE + CHARACTER(LEN=255) :: OUTPUT_FDGLOB_FILE + INTEGER :: N_OFF(IIPAR,JJPAR) + REAL*8, PARAMETER :: FILTER = 1d0 + + ! Temporary storage arrays for checkpointed variables + REAL*8 :: TEMP1(IIPAR,JJPAR,LLPAR) + REAL*8 :: TEMP2(IIPAR,JJPAR,LLPAR) + REAL*8 :: TEMP3(IIPAR,JJPAR,LLPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) + REAL*4 :: ADJ_2D(IIPAR,JJPAR,1) + REAL*4 :: TRACER_2D(IIPAR,JJPAR,1) + + ! For strat prod and loss (hml, 09/01/11, adj32_025) + REAL*4 :: PROD_3D(IIPAR,JJPAR,MMSCL) + REAL*4 :: LOSS_3D(IIPAR,JJPAR,MMSCL) + REAL*4 :: EMS_N_3D(IIPAR,JJPAR,MMSCL) + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER :: HALFPOLAR + INTEGER :: CENTER180 + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + REAL*8 :: ZTAU0, ZTAU1 + + + !================================================================= + ! MAKE_FDGLOB_FILE begins here! + !================================================================= + + ! Clear some arrays + TEMP1(:,:,:) = 0e0 + TEMP2(:,:,:) = 0e0 + TEMP3(:,:,:) = 0e0 + EMS_3D(:,:,:) = 0d0 + ADJ_2D(:,:,:) = 0e0 + TRACER(:,:,:) = 0e0 + TRACER_2D(:,:,:) = 0e0 + N_OFF(:,:) = 0d0 + + ! strat prod and loss (hml) + PROD_3D(:,:,:) = 0d0 + LOSS_3D(:,:,:) = 0d0 + EMS_N_3D(:,:,:) = 0d0 + + !======================================== + ! Read *.fd.* file from unperturbed run + !======================================== + INPUT_FD_FILE = 'gctm.fd.YYYYMMDD.hhmm.NN' + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_FD_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, 1 ) + + ! Add ADJ_DIR prefix to name + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'F D F I L E I N P U T: base ' + + + WRITE( 6, 400 ) TRIM( FILENAME ) + 400 FORMAT( ' - READ_FDGLOB_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read checkpointed variables + !================================================================= + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + !! IOS < 0 is end-of-file, so exit + !IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_fdglob_file:1' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_fdglob_file:2' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_fdglob_file:3' ) + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + !CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TEMP1(I,J,L) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! Close file + CLOSE( IU_RST ) + + + !======================================== + ! Read *.fd* file from perturbed run + !======================================== + INPUT_FD_FILE = 'gctm.fd.YYYYMMDD.hhmm.NN' + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_FD_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, 2 ) + + ! Add ADJ_DIR prefix to name + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'F D F I L E I N P U T: +pert ' + + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_FDGLOB_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read checkpointed variables + !================================================================= + ! Read the values of STT + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + !! IOS < 0 is end-of-file, so exit + !IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_fdglob_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_fdglob_file:5' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_fdglob_file:6' ) + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + !CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TEMP2(I,J,L) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !======================================== + ! Read *.fd.* file from 2nd perturbed run + !======================================== + INPUT_FD_FILE = 'gctm.fd.YYYYMMDD.hhmm.NN' + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_FD_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, 3 ) + + ! Add ADJ_DIR prefix to name + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'F D F I L E I N P U T: -pert ' + + + WRITE( 6, 888 ) TRIM( FILENAME ) + 888 FORMAT( ' - READ_FDGLOB_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read checkpointed variables + !================================================================= + ! Read the values of CHK_STT + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + !! IOS < 0 is end-of-file, so exit + !IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_fdglob_file:7' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_fdglob_file:8' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_fdglob_file:9' ) + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + !CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TEMP3(I,J,L) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !======================================== + ! Read *.gdt.* file from unperturbed run + !======================================== + INPUT_GDT_FILE = 'gctm.gdt.01' + + ! Initialize some variables + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open gradient file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_GDT_FILE ) + + ! Add OPT_DATA_DIR prefix to FILENAME + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'G D T F I L E I N P U T' + WRITE( 6, 101 ) TRIM( FILENAME ) + 101 FORMAT( 'READ_GDT_FILE: Reading ', a ) + + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read adjoints -- store in the TRACER array + !================================================================= + + IF ( LADJ_EMS ) THEN + DO N = 1, NNEMS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'fdglob_file:10' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'fdglob_file:11') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( EMS_3D(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'fdglob_file:12') + + ! Don't write if LADJ_STRAT (hml, 10/31/11, adj32_025) +! IF ( .NOT. LADJ_STRAT ) THEN + ! Don't write if LADJ_STRAT (hml, 10/31/11, adj32_025) + ! Same for reaction rates (tww, 05/15/12) + IF ( .NOT. LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + + + !============================================================== + ! Assign data from the TRACER array to the ADJ_STT array. + !============================================================== + + ! Save the gradients selected by EMSFD and MFD + IF ( CATEGORY(1:8) == 'IJ-GDE-$' .and. N == EMSFD ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + ADJ_2D(I,J,1) = EMS_3D(I,J,MFD) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDIF + ENDDO + + ! Read GDEN (hml, 09/11/11, adj32_025) + DO N = 1, NNEMS + + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'fdglob_file:10-b' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'fdglob_file:11-b') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( EMS_N_3D(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'fdglob_file:12-b') + + ENDDO + + ! For strat prod and loss (hml, 08/30/11, adj32_025) + IF ( LADJ_STRAT ) THEN + + ! Strat production + DO N = 1, NSTPL + + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR(IOS,IU_RST,'fdglob_file:13') + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_RST,'fdglob_file:14') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( PROD_3D(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_RST,'fdglob_file:15') + + ENDDO + + ! Strat loss + DO N = 1, NSTPL + + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR(IOS,IU_RST,'fdglob_file:16') + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_RST,'fdglob_file:17') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( LOSS_3D(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_RST,'fdglob_file:18') + + !======================================================== + ! Assign data from the LOSS_3D array to the ADJ_STT array. + !======================================================== + + ! Save the gradients selected by EMSFD and MFD + IF ( CATEGORY(1:8) == 'IJ-GDL-$' .and. N == STRFD ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + ADJ_2D(I,J,1) = LOSS_3D(I,J,MFD) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + ENDIF + + ! For reaction rates (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN + + DO N = 1, NRRATES + + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR(IOS,IU_RST,'fdglob_file:13') + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_RST,'fdglob_file:14') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_RST,'fdglob_file:15') + + !======================================================== + ! Assign data from the TRACER array to the ADJ_STT array. + !======================================================== + + ! Save the gradients selected by EMSFD and MFD + IF ( CATEGORY(1:8) == 'IJ-RATE$' .and. N == RATFD ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + ADJ_2D(I,J,1) = TRACER(I,J,LFD) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + ENDIF + + ELSEIF ( LICS ) THEN + + TRACER(:,:,:) = 0d0 + + DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'fdglob_file:13' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'fdglob_file:14') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'fdglob_file:15') + + !============================================================== + ! Assign data from the TRACER array to the ADJ_STT array. + !============================================================== + + ! Save the gradients selected by EMSFD and MFD + IF ( CATEGORY(1:8) == 'IJ-GDT-$' .and. N == ICSFD ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + ADJ_2D(I,J,1) = TRACER(I,J,LFD) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ENDIF + + ! Close file + CLOSE( IU_RST ) + + + !======================================== + ! Write 2nd order FD gradient + !======================================== +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + TRACER_2D(I,J,1) =(TEMP2(I,J,LFD) - TEMP3(I,J,LFD)) + & / ( 2d0 * FD_DIFF ) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Hardwire output file for now + OUTPUT_FDGLOB_FILE = 'gctm.fdglob.YYYYMMDD.hhmm' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM Checkpoint File: ' // + & 'Instantaneous Tracer Concentrations (v/v)' + CATEGORY = 'FD-TEST' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the save file for output -- binary punch format + !================================================================= + + ! Copy the output checkpoint file name into a local variable + FILENAME = TRIM( OUTPUT_FDGLOB_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to filename + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 102 ) TRIM( FILENAME ) + 102 FORMAT( ' - MAKE_FDGLOB_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + UNIT = 'kg/box' + IF ( LADJ_DDEP_TRACER ) UNIT = 'molec/cm2/s' + IF ( LADJ_WDEP_LS ) UNIT = 'kg/s' + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER_2D ) + + !======================================== + ! Write ADJ gradient + !======================================== + UNIT = 'kg/box' + IF ( LADJ_DDEP_TRACER ) UNIT = 'molec/cm2/s' + IF ( LADJ_WDEP_LS ) UNIT = 'kg/s' + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 2, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, ADJ_2D ) + + !======================================== + ! Write ADJ / FD ratio + !======================================== +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( ABS(TRACER_2D(I,J,1)) .gt. FILTER ) THEN + + TRACER_2D(I,J,1) = ADJ_2D(I,J,1) / TRACER_2D(I,J,1) + + ELSE + + TRACER_2D(I,J,1) = 1d0 + + ENDIF + + ! Keep track of number of points that are off + IF ( ( TRACER_2D(I,J,1) > 1d0 + FD_DIFF ) .OR. + & ( TRACER_2D(I,J,1) < 1D0 - FD_DIFF ) ) THEN + N_OFF(I,J) = 1 + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + UNIT = 'none' + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 3, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER_2D ) + + ! print out statistics of the ADJ / FD ratio + WRITE(6,*) '====================================================' + WRITE(6,*) ' Global validation test for values > ', FILTER + WRITE(6,*) ' MAX of global 2nd order ADJ / FD = ', + & MAXVAL(TRACER_2D(:,:,1)), MAXLOC(TRACER_2D(:,:,1)) + WRITE(6,*) ' MIN of global 2nd order ADJ / FD = ', + & MINVAL(TRACER_2D(:,:,1)), MINLOC(TRACER_2D(:,:,1)) + WRITE(6,*) ' Number of places where ratio off by ',FD_DIFF,' = ', + & SUM(N_OFF(:,:)) + WRITE(6,*) '====================================================' + + print*, ' FD2 ' , (TEMP2(IFD,JFD,LFD) - TEMP3(IFD,JFD,LFD)) + & / ( 2d0 * FD_DIFF ) + print*, ' FD2 from ', TEMP2(IFD,JFD,LFD) , TEMP3(IFD,JFD,LFD) + print*, ' ADJ ' , ADJ_2D(IFD,JFD,1) + + !======================================== + ! Write 1st order FD gradient + !======================================== + UNIT = 'kg/box' +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + TRACER_2D(I,J,1) =( TEMP2(I,J,LFD) - TEMP1(I,J,LFD) ) + & / FD_DIFF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 4, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER_2D ) + + !======================================== + ! Write chekpt values + !======================================== + UNIT = 'kg/box' +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + TRACER(I,J,1) = TEMP1(I,J,LFD) + TRACER(I,J,2) = TEMP2(I,J,LFD) + TRACER(I,J,3) = TEMP3(I,J,LFD) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 5, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 3, I0+1, + & J0+1, 1, REAL(TRACER(:,:,1:3),4) ) + + !======================================== + ! Write the other 1st order FD gradient. (dkh, 10/10/08) + !======================================== + UNIT = 'kg/box' +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + TRACER_2D(I,J,1) =( TEMP3(I,J,LFD) - TEMP1(I,J,LFD) ) + & / ( - FD_DIFF ) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 6, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER_2D ) + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_FDGLOB_FILE: wrote file' ) + + + ! Return to calling program + END SUBROUTINE MAKE_FDGLOB_FILE +!---------------------------------------------------------------------- + + SUBROUTINE MAKE_CHK_CON_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine MAKE_CHK_CON_FILE creates GEOS-CHEM checkpt files of tracer +! mixing ratios (v/v), and exit values in binary punch file format. +! (mak, 8/2/07) +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a checkpoint file +! +! Passed via CMN: +! ============================================================================ +! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +! +! Passed via ???: +! ============================================================================ +! (1 ) CHECKPT : Array of quantities to be checkpointed +! dim=(IIPAR,JJPAR,LLPAR,NCHECKPT) +! +! NOTES: +! Just like MAKE_RESTART_FILE except +! - only include quantities used as input to RPMARES +! - include hhmmss in file name +! - writes files to ADJ_DIR and can zip them +! dkh, 9/30/04 +! (2 ) Zip *.chk.* files one day at a time in a parallel loop. Add access +! to GET_TS_CHEM. (dkh, 11/22/04) +! (3 ) Add support for L_RECOMP option to recompute (rather than checkpoint) +! variables RP_OUT etc. (dkh, 02/09/05) +! (4 ) Now write values from CHK_STT_CON. (mak, 8/2/07) +! (5 ) Change file names to *.chk.con.* so they get cleaned out by shell scripts +! that purge *.chk.* files. (dkh, 10/10/08) +! (6 ) Update to v8 adj (dkh, 06/11/09) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP, ALLOC_ERR + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! IGAS + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N, JLOOP + INTEGER :: YYYY, MM, DD, HH, SS, ZIP_HH, AS + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + REAL*4 :: CHECK_FINAL(IIPAR,JJPAR,LLPAR) + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + INTEGER :: MAX_nitr_max + INTEGER :: NSOFAR + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + REAL*4 :: nitr_max_real(IIPAR, JJPAR, LLPAR) + + !================================================================= + ! MAKE_CHK_CON_FILE begins here! + !================================================================= + + ! NEW: rename them *.chk.con.* (dkh, 10/10/08) + OUTPUT_CHECKPT_FILE = 'gctm.chk.con.YYYYMMDD.hhmm' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM Convection Checkpoint File: ' // + & 'Instantaneous Tracer Concentrations (v/v)' + CATEGORY = 'IJ-CHK-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the checkpoint file for output -- binary punch format + !================================================================= + + ! Copy the output checkpoint file name into a local variable + FILENAME = TRIM( OUTPUT_CHECKPT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to filename + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_CHECKPT_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + !================================================================= + ! Write each checkpointed quantity to the checkpoint file + !================================================================= + + IF ( ITS_A_TAGCO_SIM() )THEN + UNIT = 'v/v' + ENDIF + + DO N = 1, N_TRACERS + + ! Temporarily store data in CHECK_FINAL +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + CHECK_FINAL(I,J,L) = CHK_STT_CON(I,J,L,N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, CHECK_FINAL ) + ENDDO + + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_CHK_CON_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_CHK_CON_FILE + +!------------------------------------------------------------------------------ + SUBROUTINE READ_CHK_CON_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine READ_CHK_CON_FILE initializes GEOS-CHEM tracer concentrations +! from a checkpoint file (binary punch file format) from before convection +! (dkh, 8/30/04, mak, 8/2/07) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! Passed via CMN: +! ============================================================================ +! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +! +! Notes +! (1 ) Just like READ_RESTART_FILE except +! - load the variables from TRACER directly back into the CHECKPT array +! - file name now includes hhmmss +! - reads files from ADJ_DIR (and can unzip them if L_ZIP_CHECKPT) +! - removes .chk. files after reading (if L_DEL_CHECKPT) +! dkh, 9/30/04 +! (2 ) Add DATE(2) and reference GET_NHMDe and GET_NHMSe to enable BATCH_ZIP +! (dkh, 11/22/04) +! (3 ) Read in CHK_STT_CON (mak, 8/2/07) +! (4 ) Rename from *.chkcon.* to *.chk.con.* (dkh, 10/10/08) +! (5 ) Delete files after they've been used. (dkh, 10/10/08) +! (6 ) Remove the IF ( N == 1 ) line. (dkh, 10/10/08) +! (7 ) Remove obsolete options (L_DEL_CHECKPT, L_ZIP_CHECKPT, L_RECOMP), +! check for aeroosl simulation (LSULF) and update names to v8 (dkh, 06/11/09) +! (8 ) Update to v8 adj (dkh, 06/11/09) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP, ALLOC_ERR + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS + USE UNIX_CMDS_MOD, ONLY : REMOVE_CMD + + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! ITLOOP, IGAS + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N, JLOOP, NN, NTL, AS + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_CHECKPT_FILE begins here! + !================================================================= + + INPUT_CHECKPT_FILE = 'gctm.chk.con.YYYYMMDD.hhmm' + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open checkpoint file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_CHECKPT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to name + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C H E C K P T F I L E I N P U T' + + ! Remove obsolete option +! ! Unzip checkpt file +! IF ( L_ZIP_CHECKPT ) THEN +! UNZIP_FILE_CMD = TRIM( GUNZIP_CMD ) // ' ' // +! & TRIM( FILENAME ) // ZIP_SUFFIX +! CALL SYSTEM( TRIM( UNZIP_FILE_CMD ) ) +! WRITE( 6, 99 ) TRIM( UNZIP_FILE_CMD ) +! 99 FORMAT( ' - READ_CHECKPT_FILE: Executing: ',a ) +! ENDIF + + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_CHECKPT_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read checkpointed variables + !================================================================= + + ! Read the values of CHK_STT_CON + !DO N = 1, NOBS!+1 + DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:7' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:8' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:9' ) + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + !print*, 'before check_dimensions ni, nj, nl are', ni, nj, nl + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + + + ! Remove (dkh, 10/10/08) + ! IF ( N == 1) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + CHK_STT_CON(I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !ENDIF + + ENDIF !category is checkpoint + ENDDO + + + ! Close file + CLOSE( IU_RST ) + + + 555 CONTINUE + + ! Remove files if L_CHK_DEL = TRUE + IF ( LDEL_CHKPT ) THEN + REMOVE_CHK_FILE_CMD = TRIM ( REMOVE_CMD ) // ' ' // + & TRIM ( FILENAME ) + + CALL SYSTEM( TRIM( REMOVE_CHK_FILE_CMD ) ) + + WRITE( 6, 102 ) TRIM( REMOVE_CHK_FILE_CMD ) + 102 FORMAT( ' - READ_CHECKPT_FILE: Executing: ',a ) + ENDIF + + + ! Remove obsolete (dkh, 06/11/09) +! ! Zip the .chk. file if it hasn't been deleted and zipping +! ! is requested +! IF ( L_ZIP_CHECKPT .AND. (.NOT. L_DEL_CHECKPT) ) THEN +! CALL BATCH_ZIP( YYYYMMDD, HHMMSS, 'chk', -1 ) +! ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_CHK_CON_FILE: read file' ) + + ! Return to calling program + END SUBROUTINE READ_CHK_CON_FILE + +!----------------------------------------------------------------------- + + SUBROUTINE MAKE_CHK_DYN_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine MAKE_CHK_DYN_FILE creates GEOS-CHEM checkpt files +! at the dynamic time step. (dkh, 02/01/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a checkpoint file +! +! Passed via CMN: +! ============================================================================ +! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +! +! Passed via module variables +! ============================================================================ +! (1 ) to add.... +! +! +! NOTES: +! Just like MAKE_CHK_FILE except +! +! (1 ) Now checkpoint T_DAY, T_15_AVG (dkh, 01/23/10) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : BPCH3, GET_MODELNAME + USE BPCH2_MOD, ONLY : BPCH2, OPEN_BPCH2_FOR_WRITE + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP, ALLOC_ERR + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE MEGAN_MOD, ONLY : GET_T_DAY + USE MEGAN_MOD, ONLY : GET_T_15_AVG + USE MEGAN_MOD, ONLY : DAY_DIM + USE MEGAN_MOD, ONLY : CHK_T_15_AVG + USE MEGAN_MOD, ONLY : CHK_T_DAY + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TIME_MOD, ONLY : GET_TS_CONV + USE TIME_MOD, ONLY : ITS_TIME_FOR_A3_ADJ + USE TIME_MOD, ONLY : ITS_TIME_TO_CHK_T_15_AVG + USE LOGICAL_MOD, ONLY : LWETD, LCONV + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_MOD, ONLY : LMEGAN + USE LOGICAL_ADJ_MOD, ONLY : LAERO_THERM + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! IGAS + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N, JLOOP + INTEGER :: YYYY, MM, DD, HH, SS, ZIP_HH, AS + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + REAL*4 :: CHECK_FINAL(IIPAR,JJPAR,LLPAR) + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + INTEGER :: MAX_nitr_max + INTEGER :: NSOFAR + INTEGER :: NS + INTEGER :: NSTEP + INTEGER :: CONVDT + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + REAL*4 :: nitr_max_real(IIPAR, JJPAR, LLPAR) + + !================================================================= + ! MAKE_CHK_DYN_FILE begins here! + !================================================================= + OUTPUT_CHECKPT_FILE = 'gctm.chk.dyn.YYYYMMDD.hhmm' + + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM Convection Checkpoint File' + CATEGORY = 'IJ-CHKD$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the checkpoint file for output -- binary punch format + !================================================================= + + ! Copy the output checkpoint file name into a local variable + FILENAME = TRIM( OUTPUT_CHECKPT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to filename + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_CHK_DYN_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + ! Initialize NSOFAR + NSOFAR = 0 + + !================================================================= + ! Write each checkpointed quantity to the checkpoint file + !================================================================= + + Unit = 'hPa' + + ! Write the surface pressures before and after transport (IIPAR,JJPAR,2) + CALL BPCH3( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NSOFAR + 1, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 2, I0+1, + & J0+1, 1, CHK_PSC) + + ! Set NSOFAR + NSOFAR = NSOFAR + 1 + + + IF ( LWETD .and. + & ( ITS_AN_AEROSOL_SIM() .or. ITS_A_FULLCHEM_SIM() ) ) THEN + + + + ! H2O2s + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLTROP, I0+1, + & J0+1, 1, WETD_CHK_H2O2s ) + + ! SO2s + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 2 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLTROP, I0+1, + & J0+1, 1, WETD_CHK_SO2s ) + + ! SO4 + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 3 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLTROP, I0+1, + & J0+1, 1, WETD_CHK_SO4 ) + + ! SO2 + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 4 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLTROP, I0+1, + & J0+1, 1, WETD_CHK_SO2 ) + + NSOFAR = NSOFAR + 4 + + ENDIF ! LWETD + + + ! Write the concentrations used in convection + IF ( LCONV .AND. + & ( ITS_AN_AEROSOL_SIM() .or. ITS_A_FULLCHEM_SIM() ) ) THEN + + UNIT = 'kg' + + ! H2O2s + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLTROP, I0+1, + & J0+1, 1, CONV_CHK_H2O2s ) + + ! SO2s + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 2 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLTROP, I0+1, + & J0+1, 1, CONV_CHK_SO2s ) + + ! Update NSOFAR + NSOFAR = NSOFAR + 2 + +!>>> +! Now include adjoint of F (dkh, 10/03/08) + + ! Calculate NS (See DO_CONVECTION, NSTEP or NFCLDMX, NS + CONVDT = GET_TS_CONV() * 60d0 + NSTEP = CONVDT / 300 + NSTEP = MAX( NSTEP, 1 ) + + DO NS = 1, NSTEP + ! QS_SO2 in NFCLDMX + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, QC_SO2_CHK(:,:,:,NS) ) + + ! Update NSOFAR + NSOFAR = NSOFAR + 1 + + ENDDO + + ! need this? i don't think so... + ! Update NSOFAR + !NSOFAR = NSOFAR + 1 +!<<< + + + ENDIF ! LCONV + + ! Now checkpoint T_15_AVG and T_DAY so that we can use MEGAN emissions (dkh, 01/22/10) + IF ( LMEGAN ) THEN + + + ! Only need to do this if it's a new day + IF ( ITS_TIME_TO_CHK_T_15_AVG() ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Get the values from megan_mod + CHK_T_15_AVG(I,J,1) = REAL(GET_T_15_AVG(I,J),4) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, CHK_T_15_AVG ) + + ! Set NSOFAR + NSOFAR = NSOFAR + 1 + + ENDIF + + ! Only need to do this if it's time for more A3 + IF ( ITS_TIME_FOR_A3_ADJ( ) ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, DAY_DIM + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Get the values from megan_mod + CHK_T_DAY(I,J,L) = REAL(GET_T_DAY(I,J,L),4) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1 + NSOFAR, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, DAY_DIM, I0+1, + & J0+1, 1, CHK_T_DAY ) + + ! Set NSOFAR + NSOFAR = NSOFAR + 1 + + ENDIF + ENDIF + + ! Close file + CLOSE( IU_RST ) + + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_CHK_DYN_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_CHK_DYN_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_CHK_DYN_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine READ_CHK_DYN_FILE reads values checkpointed at the dynamic time +! step (dkh, 02/01/09) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! Passed via CMN: +! ============================================================================ +! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval +! +! Notes +! (1 ) Just like READ_CHK_DYN_FILE +! (2 ) Add T_DAY and T_15_AVG (dkh, 01/23/10) +! +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP, ALLOC_ERR + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_MOD, ONLY : LWETD, LCONV + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_MOD, ONLY : LMEGAN + USE LOGICAL_ADJ_MOD, ONLY : LAERO_THERM + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE MEGAN_MOD, ONLY : CHK_T_15_AVG + USE MEGAN_MOD, ONLY : CHK_T_DAY + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TIME_MOD, ONLY : GET_TS_CONV + USE TIME_MOD, ONLY : ITS_TIME_TO_GET_T_15_AVG + USE TIME_MOD, ONLY : ITS_TIME_TO_GET_T_DAY + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + USE UNIX_CMDS_MOD, ONLY : REMOVE_CMD + + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! ITLOOP, IGAS + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N, JLOOP, NN, NTL, AS + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: UNZIP_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: NS + INTEGER :: NSTEP + INTEGER :: CONVDT + + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_CHECKPT_FILE begins here! + !================================================================= + + INPUT_CHECKPT_FILE = 'gctm.chk.dyn.YYYYMMDD.hhmm' + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open checkpoint file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_CHECKPT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to name + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C H E C K P T F I L E I N P U T' + + ! Remove obsolete options (dkh, 06/11/09) +! ! Unzip checkpt file +! IF ( L_ZIP_CHECKPT ) THEN +! UNZIP_FILE_CMD = TRIM( GUNZIP_CMD ) // ' ' // +! & TRIM( FILENAME ) // ZIP_SUFFIX +! CALL SYSTEM( TRIM( UNZIP_FILE_CMD ) ) +! WRITE( 6, 99 ) TRIM( UNZIP_FILE_CMD ) +! 99 FORMAT( ' - READ_CHK_DYN_FILE: Executing: ',a ) +! ENDIF + + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_CHK_DYN_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read checkpointed variables + !================================================================= + + ! Read in surface pressures + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 556 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:10d' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:11d' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( CHK_PSC(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:12d' ) + + + ! Read the values for WETDEP + IF ( LWETD .and. + & ( ITS_AN_AEROSOL_SIM() .or. ITS_A_FULLCHEM_SIM() ) ) THEN + + + ! Read the values of WETD_CHK_H2O2s + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 556 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:33d' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:34d' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( WETD_CHK_H2O2s(I,J,L), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:35d' ) + + ! Read the values of WETD_CHK_SO2s + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 556 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:36d' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:37d' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( WETD_CHK_SO2s(I,J,L), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:38d' ) + + ! Read the values of WETD_CHK_SO4 + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 556 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:39d' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:40d' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( WETD_CHK_SO4(I,J,L), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:41d' ) + + ! Read the values of WETD_CHK_SO2 + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 556 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:42d' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:43d' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( WETD_CHK_SO2(I,J,L), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:44d' ) + + ENDIF ! LWETD + + ! Read the values for CONVECTION + ! Replace NSRCX (dkh, 06/11/09) + !IF ( LCONV .AND. ( NSRCX == 3 .or. NSRCX == 10 ) ) THEN + IF ( LCONV .AND. + & ( ITS_AN_AEROSOL_SIM() .or. ITS_A_FULLCHEM_SIM() ) ) THEN + + + ! Read the values of CONV_CHK_H2O2s + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 556 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:51d' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:52d' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( CONV_CHK_H2O2s(I,J,L), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:53d' ) + + ! Read the values of CONV_CHK + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 556 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:54d' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:55d' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( CONV_CHK_SO2s(I,J,L), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:56d' ) + +!>>> +! Now include adjoint of F (dkh, 10/03/08) + + ! Calculate NS (See DO_CONVECTION, NSTEP or NFCLDMX, NS + CONVDT = GET_TS_CONV() * 60d0 + NSTEP = CONVDT / 300 + NSTEP = MAX( NSTEP, 1 ) + + DO NS = 1, NSTEP + + ! Read the values of QC_SO2_CHK + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 556 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:63d' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:64d' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( QC_SO2_CHK(I,J,L,NS), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:65d' ) + + + ENDDO ! NS +!<<< + + + ENDIF ! LCONV + + IF ( LMEGAN ) THEN + + ! adjoint equivalent of ITS_TIME_TO_CHK_T_15_AVG + IF ( ITS_TIME_TO_GET_T_15_AVG() ) THEN + + ! read in T_15_AVG + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 556 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:63' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:64' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:59' ) + + CHK_T_15_AVG(:,:,1) = TRACER(:,:,1) + + ENDIF + + IF ( ITS_TIME_TO_GET_T_DAY( ) ) THEN + + ! read in T_DAY + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) GOTO 556 + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:63' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_checkpt_file:64' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), + & L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_checkpt_file:59' ) + + CHK_T_DAY(:,:,:) = TRACER(:,:,:) + + ENDIF + + ENDIF + 556 CONTINUE + + + IF ( LDEL_CHKPT ) THEN + REMOVE_CHK_FILE_CMD = TRIM ( REMOVE_CMD ) // ' ' // + & TRIM ( FILENAME ) + + CALL SYSTEM( TRIM( REMOVE_CHK_FILE_CMD ) ) + + WRITE( 6, 102 ) TRIM( REMOVE_CHK_FILE_CMD ) + 102 FORMAT( ' - READ_CHK_DYN_FILE: Executing: ',a ) + ENDIF + + ! Remove obsolete (dkh, 06/11/09) +! ! Zip the .chk. file if it hasn't been deleted and zipping +! ! is requested +! IF ( L_ZIP_CHECKPT .AND. (.NOT. L_DEL_CHECKPT) ) THEN +! CALL BATCH_ZIP( YYYYMMDD, HHMMSS, 'chk', -1 ) +! ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_CHK_DYN_FILE: read file' ) + + ! Return to calling program + END SUBROUTINE READ_CHK_DYN_FILE + +!----------------------------------------------------------------------- + + SUBROUTINE MAKE_ADJ_FILE( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine MAKE_ADJ_FILE creates a binary file of STT_ADJ +! (dkh, 10/03/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create an adjoint file +! +! Passed via CMN_ADJ +! ============================================================================ +! (1 ) ADJ_STT : Array of quantities to be checkpointed +! dim=(IIPAR,JJPAR,LLPAR,NADJ) +! +! NOTES: +! (1 ) Now write out adjoint of concentration scaling factors instead of +! adjoint of concentrations. This requires multiplying by STT. This +! routine is now called before chemistry and transport so that +! we can resale by the STT that was checkpointed after chemistry +! and transport in the forward run. STT is in [kg/box] at this point. +! Also, only write out LLADJKEEP levels and NNADJKEEP species +! (dkh, 11/22/06) +! (2 ) Update for GCv8 (dkh, 02/15/10) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LTRAJ_SCALE + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : STT + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=40) :: OUTPUT_ADJ_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + ! Should make these user defined in input.gcadj + !! Parameter + INTEGER, PARAMETER :: LLADJKEEP = LLPAR + !INTEGER, PARAMETER :: NNADJKEEP = N_TRACERS + ! Now specify this input.gcadj + !LOGICAL, PARAMETER :: LTRAJ_SCALE = .TRUE. + + !================================================================= + ! MAKE_ADJ_FILE begins here! + !================================================================= + + + ! Hardwire output file for now + OUTPUT_ADJ_FILE = 'gctm.adj.YYYYMMDD.hhmm' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM ADJ File: ' // + & 'Instantaneous Adjoint Concentrations ' + CATEGORY = 'IJ-ADJ-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_ADJ_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add the ADJ_DIR prefix to the file name + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_ADJ_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = 1, N_TRACERS + + + ! For saving out semilog sensitivities dJ/dSTT * STT = dJ/dln(STT) + IF ( LTRAJ_SCALE ) THEN + + UNIT = 'J' + + !Temporarily store quantities in the TRACER array +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLADJKEEP + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Now multiply by concentrations so that we write + ! the adjoint of concentration scaling factors + ! BUG FIX: it's better to use CHK_STT (dkh, 07/30/10) + !TRACER(I,J,L) = STT_ADJ (I,J,L,N) * STT(I,J,L,N) + TRACER(I,J,L) = STT_ADJ (I,J,L,N) * CHK_STT(I,J,L,N) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! For saving out sensitivities dJ/dSTT + ELSE + + UNIT = 'J/STT' + + !Temporarily store quantities in the TRACER array +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLADJKEEP + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Now multiply by concentrations so that we write + ! the adjoint of concentration scaling factors + TRACER(I,J,L) = STT_ADJ (I,J,L,N) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLADJKEEP, I0+1, + & J0+1, 1, TRACER(:,:,1:LLADJKEEP) ) + + ENDDO + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_ADJ_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_ADJ_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_EMS_ADJ_FILE( ) +! +!****************************************************************************** +! Subroutine MAKE_EMS_ADJ_FILE creates a binary file of EMS_ADJ (dkh, 02/17/11) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! (2 ) EMS_ADJ : Array of adjoint gradients to be written +! +! NOTES: +! (1 ) Based on MAKE_GDT_FILE +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TIME_MOD, ONLY : GET_CT_EMIS + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NEMIS(NCS) + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, M, N + INTEGER :: YYYY, MM, DD, HH, SS + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: OUTPUT_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_EMS_ADJ_FILE begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_FILE = 'ems.adj.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM ADJ File: ' // + & 'Emissions adjoints ' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the DIAGADJ_DIR prefix to the file name + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_EMS_ADJ_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + ! Set CATEGORY and UNIT + CATEGORY = 'dJ_dEMS' + UNIT = 'J/kg' + + ! dkh debug + !print*, ' CT_EMIS = ', GET_CT_EMIS() + + ! Convert units from J / (kg / box / timestep) to J / (kg / box) + EMS_ADJ(:,:,:,:) = EMS_ADJ(:,:,:,:) / GET_CT_EMIS() + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = 1, NNEMS + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, REAL(EMS_ADJ(:,:,:,N),4) ) + + ENDDO + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_EMS_ADJ_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_EMS_ADJ_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_PROD_GDT_FILE( ) +! +!****************************************************************************** +! Subroutine MAKE_PROD_GDT_FILE (GDT=SF_ADJ) creates a binary file of +! PROD_SF_ADJ (hml, 07/26/11, adj32_025) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! (2 ) PROD_ADJ : Array of adjoint gradients to be written +! +! NOTES: +! (1 ) Based on MAKE_EMS_ADJ_FILE & MAKE_ADJ_FILE +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NEMIS(NCS) + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, M, N + INTEGER :: YYYY, MM, DD, HH, SS + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=40) :: OUTPUT_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + + !================================================================= + ! MAKE_PROD_ADJ_FILE begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_FILE = 'prod.sf.adj.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM ADJ File: ' // + & 'Stratospheric Production Scaling Factor Adjoints ' + UNIT = 'J' + !CATEGORY = 'dJ_dPRSF' + CATEGORY = 'IJ-GDP-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the DIAGADJ_DIR prefix to the file name + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_PROD_GDT_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = 1, NSTPL + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, REAL(PROD_SF_ADJ(:,:,1,N),4)) + + ENDDO + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( + & '### MAKE_PROD_GDT_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_PROD_GDT_FILE + +!------------------------------------------------------------------------------ +! + SUBROUTINE MAKE_LOSS_GDT_FILE( ) +! +!****************************************************************************** +! Subroutine MAKE_LOSS_GDT_FILE (GDT = SF_ADJ) creates a binary file of +! LOSS_SF_ADJ: stratospheric loss rate scaling factor adjoint +! (hml, 07/26/11, adj32_025) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! (2 ) LOSS_ADJ : Array of adjoint gradients to be written +! +! +! NOTES: +! (1 ) Based on MAKE_EMS_ADJ_FILE & MAKE_ADJ_FILE +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NEMIS(NCS) + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, M, N + INTEGER :: YYYY, MM, DD, HH, SS + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=40) :: OUTPUT_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_LOSS_SF_ADJ_FILE begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_FILE = 'loss.sf.adj.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM ADJ File: ' // + & 'Stratospheric Loss Scaling Factor Adjoints ' + !CATEGORY = 'dJ_dLSSF' + CATEGORY = 'IJ-GDL-$' + UNIT = 'J' + + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the DIAGADJ_DIR prefix to the file name + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_LOSS_GDT_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = 1, NSTPL + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, REAL(LOSS_SF_ADJ(:,:,1,N),4)) + + ENDDO + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( + & '### MAKE_LOSS_GDT_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_LOSS_GDT_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_SO2ac_FILE( ESO2_ac, MONTH ) +! +!****************************************************************************** +! Subroutine MAKE_SO2ac_FILE creates GEOS-CHEM checkpt files of SO2 +! emissions from aircraft. +! +! Arguments as Input: +! ============================================================================ +! (1 ) ESO2_ac : Current monthly aircraft SO2 emissions [kg SO2/box/s] +! (2 ) MONTH : Current month +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP, ALLOC_ERR + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=3), INTENT(IN) :: MONTH + REAL*8, INTENT(IN) :: ESO2_ac(IIPAR,JJPAR,LLPAR) + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L + INTEGER :: YYYY, MM, DD, HH, SS, ZIP_HH, AS + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_SO2ac_FILE begins here! + !================================================================= + + ! NEW: rename them *.chk.con.* (dkh, 10/10/08) + OUTPUT_CHECKPT_FILE = 'gctm.chk.SO2ac.YYYY.' // TRIM( MONTH ) + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM SO2 ac Checkpoint File ' + CATEGORY = 'IJ-CHK-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the checkpoint file for output -- binary punch format + !================================================================= + + ! Copy the output checkpoint file name into a local variable + FILENAME = TRIM( OUTPUT_CHECKPT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, GET_NYMD(), GET_NHMS() ) + + ! Add ADJ_DIR prefix to filename + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_SO2ac_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each checkpointed quantity to the checkpoint file + !================================================================= + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, 1, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, REAL(ESO2_ac,4) ) + + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_SO2ac_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_SO2ac_FILE + +!------------------------------------------------------------------------------ + SUBROUTINE READ_SO2ac_FILE( ESO2_ac, MONTH ) +! +!****************************************************************************** +! Subroutine READ_SO2ac_FILE initializes GEOS-CHEM tracer concentrations +! from a checkpoint file (binary punch file format) from before convection +! (dkh, 8/30/04, mak, 8/2/07) +! +! Arguments as input: +! ============================================================================ +! (1 ) MONTH : Current month +! +! Arguments as output: +! ============================================================================ +! (1 ) ESO2_ac : Current monthly aircraft SO2 emissions [kg SO2/box/s] +! +! Notes +! +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP, ALLOC_ERR + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TIME_MOD, ONLY : GET_NYMD + USE TIME_MOD, ONLY : GET_NHMS + USE UNIX_CMDS_MOD, ONLY : REMOVE_CMD + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=3), INTENT(IN) :: MONTH + REAL*8, INTENT(OUT) :: ESO2_ac(IIPAR,JJPAR,LLPAR) + + ! Local Variables + INTEGER :: I, IOS, J, L, N, JLOOP, NN, NTL, AS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_SO2ac_FILE begins here! + !================================================================= + + INPUT_CHECKPT_FILE = 'gctm.chk.SO2ac.YYYY.' // TRIM( MONTH ) + + ! Initialize some variables + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open checkpoint file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_CHECKPT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, GET_NYMD(), GET_NHMS() ) + + ! Add ADJ_DIR prefix to name + FILENAME = TRIM( ADJTMP_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C H E C K P T F I L E I N P U T' + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_SO2ac: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read checkpointed variables + !================================================================= + + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so print error message + IF ( IOS < 0 ) + & CALL IOERROR( IOS,IU_RST,'read_so2ac_file:6' ) + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) + & CALL IOERROR( IOS,IU_RST,'read_so2ac_file:7' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) + & CALL IOERROR(IOS,IU_RST,'read_so2ac_file:8' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) + & CALL IOERROR( IOS,IU_RST,'read_so2ac_file:9' ) + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + !print*, 'before check_dimensions ni, nj, nl are', ni, nj, nl + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ESO2_ac(I,J,L) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF !category is checkpoint + + ! Close file + CLOSE( IU_RST ) + + + 555 CONTINUE + + ! Remove files if L_CHK_DEL = TRUE + IF ( LDEL_CHKPT ) THEN + REMOVE_CHK_FILE_CMD = TRIM ( REMOVE_CMD ) // ' ' // + & TRIM ( FILENAME ) + + CALL SYSTEM( TRIM( REMOVE_CHK_FILE_CMD ) ) + + WRITE( 6, 102 ) TRIM( REMOVE_CHK_FILE_CMD ) + 102 FORMAT( ' - READ_SO2ac_FILE: Executing: ',a ) + ENDIF + + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_SO2ac_FILE: read file' ) + + ! Return to calling program + END SUBROUTINE READ_SO2ac_FILE + +!----------------------------------------------------------------------- + SUBROUTINE EXPAND_NAME( FILENAME, N_ITRN ) +! +!****************************************************************************** +! Subroutine EXPAND_DATE replaces "NN" token within +! a filename string with the actual values. (bmy, 6/27/02, 12/2/03) +! (dkh, 9/22/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Filename with tokens to replace +! (2 ) N_ITRN (INTEGER ) : Current iteration number +! +! +! Arguments as Output: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Modified filename +! +! NOTES: +! (1 ) Based on EXPAND_DATE +! +!****************************************************************************** +! + ! References to F90 modules + USE CHARPAK_MOD, ONLY : STRREPL + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "define.h" + + ! Arguments + CHARACTER(LEN=*), INTENT(INOUT) :: FILENAME + INTEGER, INTENT(IN) :: N_ITRN + + ! Local variables + CHARACTER(LEN=2) :: NN_STR + + !================================================================= + ! EXPAND_NAME begins here! + !================================================================= + +#if defined( LINUX_PGI ) + + ! Use ENCODE statement for PGI/Linux (bmy, 9/29/03) + ENCODE( 2, '(i2.2)', NN_STR ) N_ITRN + +#else + + ! For other platforms, use an F90 internal write (bmy, 9/29/03) + WRITE( NN_STR, '(i2.2)' ) N_ITRN + +#endif + + ! Replace NN token w/ actual value + CALL STRREPL( FILENAME, 'NN', NN_STR ) + + + ! Return to calling program + END SUBROUTINE EXPAND_NAME + +!----------------------------------------------------------------------- + SUBROUTINE INIT_CHECKPT +! +!***************************************************************************** +! Subroutine INIT_CHECKPT initializes all module arrays (dkh, 9/10/04) +! +! NOTES: +! (1 ) Add CHK_PSC. (dkh, 03/16/05) +! (2 ) Add ORIG_STT. (dkh, 06/14/05) +! (3 ) Add PART_CASE. (dkh, 07/22/05) +! (4 ) Add CHK_STT_BEFCHEM. (dkh, 08/08/05) +! (5 ) Add SO2_CHK, H2O2_CHK. (dkh, 10/23/05) +! (6 ) Add WETD_CHK_H2O2s_CHEMT, WETD_CHK_H2O2s_DYNT, etc. (dkh, 10/23/05) +! (7 ) Add WETD_CHK_SO2_CHEMT, WETD_CHK_SO2_DYNT. (dkh, 10/31/05) +! (8 ) Add CONV_CHK... (dkh, 11/22/05) +! (9 ) Add SOILNOX_CHK (dkh, 02/06/07) +! (10) Change to checkpointing WETD and CONV stuff at every dynamic ts (dkh, 02/02/09) +! (11) Update to v8, (adj_group, 6/09/09) +! (12) Add CHK_T_DAY and CHK_T_15_DAY for MEGAN emissions (dkh, 01/23/10) +!****************************************************************************** +! + ! F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : GET_TS_CONV + !USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + USE LOGICAL_MOD, ONLY : LSOILNOX + USE LOGICAL_MOD, ONLY : LSULF + USE LOGICAL_MOD, ONLY : LCHEM + USE LOGICAL_MOD, ONLY : LWETD, LCONV + USE LOGICAL_MOD, ONLY : LMEGAN + USE LOGICAL_MOD, ONLY : LLIGHTNOX + USE LOGICAL_MOD, ONLY : LWETD + USE LOGICAL_ADJ_MOD, ONLY : LAERO_THERM + USE MEGAN_MOD, ONLY : DAY_DIM + + +# include "CMN_SIZE" ! IIPAR, JJPAR, LLPAR +# include "comode.h" ! ITLOOP + + ! Local variables + INTEGER :: AS + INTEGER :: NSTEP + INTEGER :: CONVDT + + + !================================================================= + ! INIT_CHECKPT begins here + !================================================================= + + IF ( LSULF .and. LAERO_THERM ) THEN + ALLOCATE( ANISO_IN( IIPAR, JJPAR, LLPAR, NANISOIN ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ANISO_IN' ) + + ALLOCATE( RP_IN( IIPAR, JJPAR, LLPAR, NRPIN ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RP_IN' ) + + ALLOCATE( RP_OUT( IIPAR, JJPAR, LLPAR, NRPOUT ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RP_OUT' ) + + ALLOCATE( nitr_max( IIPAR, JJPAR, LLPAR ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'nitr_max' ) + + ALLOCATE( gamaan_fwd( IIPAR, JJPAR, LLPAR, NNNMAX ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'gamaan_fwd' ) + + ALLOCATE( gamold_fwd( IIPAR, JJPAR, LLPAR, NNNMAX ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'gamold_fwd' ) + + ALLOCATE( wh2o_fwd( IIPAR, JJPAR, LLPAR, NNNMAX ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'wh2o_fwd' ) + + ALLOCATE( ynh4_fwd( IIPAR, JJPAR, LLPAR, NNNMAX ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ynh4_fwd' ) + + ALLOCATE( eror_fwd( IIPAR, JJPAR, LLPAR, NNNMAX ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'error_fwd' ) + + ALLOCATE( exit_fwd( IIPAR, JJPAR, LLPAR, NNNMAX ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'exit_fwd' ) + + ALLOCATE( gamana_fwd( IIPAR, JJPAR, LLPAR, NNNMAX ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'gaman_fwd' ) + + ALLOCATE( gamas1_fwd( IIPAR, JJPAR, LLPAR, NNNMAX ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'gamas1_fwd' ) + + ALLOCATE( gamas2_fwd( IIPAR, JJPAR, LLPAR, NNNMAX ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'gamas2_fwd' ) + + ENDIF + + IF ( LSULF .and. LCHEM ) THEN + ALLOCATE( SO2_CHK( IIPAR, JJPAR, LLPAR ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO2_CHK' ) + SO2_CHK = 0.d0 + + ALLOCATE( H2O2_CHK( IIPAR, JJPAR, LLPAR ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'H2O2_CHK' ) + H2O2_CHK = 0.d0 + + ENDIF + + ALLOCATE( CHK_STT( IIPAR, JJPAR, LLPAR, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CHK_STT' ) + + ! mak + ALLOCATE( CHK_STT_CON( IIPAR, JJPAR, LLPAR, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CHK_STT_CON' ) + + ! OBS_STT now in adj_arrays_mod.f instead of checkpt_mod.f (mak, 6/14/09) + !ALLOCATE( OBS_STT( IIPAR, JJPAR, LLPAR, N_TRACERS ) , STAT=AS ) + !IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS' ) + + ALLOCATE( CHK_PSC( IIPAR, JJPAR, 2 ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CHK_PSC' ) + + + ALLOCATE( ORIG_STT( IIPAR, JJPAR, LLPAR, N_TRACERS ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ORIG_STT' ) + + IF ( ITS_A_FULLCHEM_SIM() .and. + & ( LCHEM .or. LWETD ) ) THEN + ALLOCATE( PART_CASE( ITLOOP ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PART_CASE' ) + + ALLOCATE( CHK_STT_BEFCHEM( IIPAR, JJPAR, LLPAR, N_TRACERS ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CHK_STT_BEFCHEM' ) + + ALLOCATE( CHK_HSAVE( IIPAR, JJPAR, LLTROP ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CHK_HSAVE' ) + CHK_HSAVE = 0.d0 + + ENDIF + + IF ( LWETD .and. + & ( ITS_AN_AEROSOL_SIM() .or. ITS_A_FULLCHEM_SIM() ) ) THEN + ALLOCATE( WETD_CHK_H2O2s( IIPAR, JJPAR, LLPAR ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'H2O2s' ) + WETD_CHK_H2O2s = 0.d0 + + ALLOCATE( WETD_CHK_SO2s( IIPAR, JJPAR, LLPAR ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO2s' ) + WETD_CHK_SO2s = 0.d0 + + ALLOCATE( WETD_CHK_SO4( IIPAR, JJPAR, LLPAR ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO4' ) + WETD_CHK_SO4 = 0.d0 + + ALLOCATE( WETD_CHK_SO2( IIPAR, JJPAR, LLPAR ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO2' ) + WETD_CHK_SO2 = 0.d0 + + ENDIF ! LWETD + + IF ( LCONV .AND. + & ( ITS_AN_AEROSOL_SIM() .or. ITS_A_FULLCHEM_SIM() ) ) THEN + + ALLOCATE( CONV_CHK_H2O2s( IIPAR, JJPAR, LLPAR ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CONV_H2O2s' ) + CONV_CHK_H2O2s = 0.d0 + + ALLOCATE( CONV_CHK_SO2s( IIPAR, JJPAR, LLPAR ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CONV_SO2s' ) + CONV_CHK_SO2s = 0.d0 + + !>>> + ! Now include adjoint of F (dkh, 10/03/08) + + ! Calculate NS (See DO_CONVECTION, NSTEP or NFCLDMX, NS + CONVDT = GET_TS_CONV() * 60d0 + NSTEP = CONVDT / 300 + NSTEP = MAX( NSTEP, 1 ) + + ALLOCATE( QC_SO2_CHK( IIPAR, JJPAR, LLPAR, NSTEP), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'QC_SO2_CHK' ) + QC_SO2_CHK = 0.d0 + !<<< + + ENDIF ! LCONV + + IF ( LSOILNOX ) THEN + + ALLOCATE( SOILNOX_CHK( IIPAR, JJPAR ), + & STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SOILNOX_CHK' ) + SOILNOX_CHK = 0.d0 + + ENDIF + + ! Adding this didn't really help (dkh, 06/11/09) + !IF ( LADJ_TRAN ) THEN + ! + ! ALLOCATE( CHK_STT_TD( IIPAR, JJPAR, LLPAR, N_TRACERS ), STAT=AS ) + ! IF ( AS /= 0 ) CALL ALLOC_ERR( 'CHK_STT_TD' ) + ! CHK_STT_TD = 0.d0 + ! + ! ALLOCATE( CHK_STT_TC( IIPAR, JJPAR, LLPAR, N_TRACERS ), STAT=AS ) + ! IF ( AS /= 0 ) CALL ALLOC_ERR( 'CHK_STT_TC' ) + ! CHK_STT_TC = 0.d0 + ! + !ENDIF + + ! adj_group: add for checkpointing lightning NOx emissions + IF ( LLIGHTNOX ) THEN + ALLOCATE( SLBASE_CHK( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SLBASE_CHK' ) + SLBASE_CHK = 0d0 + ENDIF + + END SUBROUTINE INIT_CHECKPT + +!----------------------------------------------------------------------- + + SUBROUTINE CLEANUP_CHECKPT +! +!***************************************************************************** +! Subroutine CLEANUP_CHECKPT deallocates all module arrays (dkh, 9/10/04) +! +! NOTES: +! (1 ) Add CHK_PSC. (dkh, 03/16/05) +! (2 ) Add ORIG_STT. (dkh, 06/14/05) +! (3 ) Add PART_CASE. (dkh, 07/22/05) +! (4 ) Add CHK_STT_BEFCHEM. (dkh, 08/08/05) +! (5 ) Add SO2_CHK, H2O2_CHK. (dkh, 10/23/05) +! (6 ) Add WETD_CHK_H2O2s_CHEMT, WETD_CHK_H2O2s_DYNT, etc. (dkh, 10/23/05) +! (7 ) Add WETD_CHK_SO2_CHEMT, WETD_CHK_SO2_DYNT. (dkh, 10/31/05) +! (8 ) Add CONV_CHK_xxx etc. (dkh, 11/22/05) +! (9 ) Add SOILNOX_CHK. (dkh, 02/06/07) +! (10) Change to checkpointing WETD and CONV stuff at every dynamic ts (dkh, 02/02/09) +! (11) Add ANISORROPIA for aerosol thermo (slc, 3/9/13, ***) +!****************************************************************************** +! + IF ( ALLOCATED( RP_IN ) ) DEALLOCATE( RP_IN ) + IF ( ALLOCATED( RP_OUT) ) DEALLOCATE( RP_OUT ) + IF ( ALLOCATED( ANISO_IN ) ) DEALLOCATE( ANISO_IN ) + !OBS_STT now in adj_arrays_mod.f instead of checkpt_mod.f (mak, 6/14/09) + !IF ( ALLOCATED( OBS_STT ) ) DEALLOCATE( OBS_STT ) + IF ( ALLOCATED( CHK_STT ) ) DEALLOCATE( CHK_STT ) + IF ( ALLOCATED( CHK_PSC ) ) DEALLOCATE( CHK_PSC ) + IF ( ALLOCATED( nitr_max ) ) DEALLOCATE( nitr_max ) + IF ( ALLOCATED( gamaan_fwd ) ) DEALLOCATE( gamaan_fwd ) + IF ( ALLOCATED( gamold_fwd ) ) DEALLOCATE( gamold_fwd ) + IF ( ALLOCATED( wh2o_fwd ) ) DEALLOCATE( wh2o_fwd ) + IF ( ALLOCATED( ynh4_fwd ) ) DEALLOCATE( ynh4_fwd ) + IF ( ALLOCATED( eror_fwd ) ) DEALLOCATE( eror_fwd ) + IF ( ALLOCATED( exit_fwd ) ) DEALLOCATE( exit_fwd ) + IF ( ALLOCATED( gamana_fwd ) ) DEALLOCATE( gamana_fwd ) + IF ( ALLOCATED( gamas1_fwd ) ) DEALLOCATE( gamas1_fwd ) + IF ( ALLOCATED( gamas2_fwd ) ) DEALLOCATE( gamas2_fwd ) + IF ( ALLOCATED( ORIG_STT ) ) DEALLOCATE( ORIG_STT ) + IF ( ALLOCATED( CHK_STT_BEFCHEM ) ) DEALLOCATE( CHK_STT_BEFCHEM ) + IF ( ALLOCATED( PART_CASE ) ) DEALLOCATE( PART_CASE ) + IF ( ALLOCATED( CHK_HSAVE ) ) DEALLOCATE( CHK_HSAVE ) + IF ( ALLOCATED( SO2_CHK ) ) DEALLOCATE( SO2_CHK ) + IF ( ALLOCATED( H2O2_CHK ) ) DEALLOCATE( H2O2_CHK ) + IF ( ALLOCATED( WETD_CHK_H2O2s ) ) + & DEALLOCATE( WETD_CHK_H2O2s ) + IF ( ALLOCATED( WETD_CHK_SO2s ) ) + & DEALLOCATE( WETD_CHK_SO2s ) + IF ( ALLOCATED( WETD_CHK_SO4 ) ) + & DEALLOCATE( WETD_CHK_SO4 ) + IF ( ALLOCATED( WETD_CHK_SO2 ) ) + & DEALLOCATE( WETD_CHK_SO2 ) + IF ( ALLOCATED( CONV_CHK_H2O2s ) ) + & DEALLOCATE( CONV_CHK_H2O2s ) + IF ( ALLOCATED( CONV_CHK_SO2s ) ) + & DEALLOCATE( CONV_CHK_SO2s ) + IF ( ALLOCATED( SOILNOX_CHK ) ) + & DEALLOCATE( SOILNOX_CHK ) + + IF ( ALLOCATED( CHK_STT_CON ) )DEALLOCATE( CHK_STT_CON ) + + !IF ( ALLOCATED( CHK_STT_TD ) )DEALLOCATE( CHK_STT_TD ) + !IF ( ALLOCATED( CHK_STT_TC ) )DEALLOCATE( CHK_STT_TC ) + +!>>> +! Now include adjoint of F (dkh, 10/03/08) + IF ( ALLOCATED( QC_SO2_CHK) ) + & DEALLOCATE( QC_SO2_CHK ) +!<<< + + + IF ( ALLOCATED( SLBASE_CHK ) ) DEALLOCATE( SLBASE_CHK ) + + + ! Return to calling program + END SUBROUTINE CLEANUP_CHECKPT + +!------------------------------------------------------------------------------ + END MODULE CHECKPT_MOD + diff --git a/code/adjoint/chemdr_adj.f b/code/adjoint/chemdr_adj.f new file mode 100644 index 0000000..00af501 --- /dev/null +++ b/code/adjoint/chemdr_adj.f @@ -0,0 +1,798 @@ +!$Id: chemdr_adj.f,v 1.9 2012/03/01 22:00:26 daven Exp $ + SUBROUTINE CHEMDR_ADJ +! +!****************************************************************************** +! Subroutine CHEMDR_ADJ is the driver subroutine for full chemistry adjoint. +! Adapted from original code by lwh, jyl, gmg, djj. (bmy, 11/15/01, 6/3/08) +! Adjoint developed by dkh, ks, 07/30/09 +! +! Important input variables from "dao_mod.f" and "uvalbedo_mod.f": +! ============================================================================ +! ALBD : DAO visible albedo [unitless] +! AVGW : Mixing ratio of water vapor [v/v] +! BXHEIGHT : Grid box heights [m] +! OPTD : DAO grid-box optical depths (for FAST-J) [unitless] +! SUNCOS : Cosine of solar zenith angle [unitless] +! SUNCOSB : Cosine of solar zenith angle 1 hr from now [unitless] +! UVALBEDO : TOMS UV albedo 340-380 nm (for FAST-J) [unitless] +! +! Important input variables from "comode.h" or "comode_mod.f": +! ============================================================================ +! NPTS : Number of points (grid-boxes) to calculate +! REMIS : Emission rates [molec/cm3/s-1] +! RAERSOL : Frequency of gas-aerosol collisions [s-1] +! PRESS : Pressure [Pa] +! TMPK : Temperature [K] +! ABSHUM : Absolute humidity [molec/cm3] +! CSPEC : Initial species concentrations [molec/cm3] +! +! Important output variables in "comode.h" etc. +! ============================================================================ +! NAMESPEC : Character array of species names +! NNSPEC : # of ACTIVE + INACTIVE (not DEAD) species +! CSPEC : Final species concentrations [molec/cm3] +! +! Other Important Variables +! ============================================================================ +! MAXPTS : Maximum number of points or grid-boxes (in "comsol.h") +! (NPTS must be <= MAXPTS, for SLOW-J only) +! MAXDEP : Maximum number of deposition species (note # of +! depositing species listed in tracer.dat must be <= MAXDEP) +! IGAS : Maximum number of gases, ACTIVE + INACTIVE +! IO93 : I/O unit for output for "ctm.chem" file +! +! Input files for SMVGEAR II: +! ============================================================================ +! mglob.dat : control switches (read in "reader.f") +! tracer.dat : list of tracers, emitting species (read in "reader.f") +! and depositing species +! globchem.dat : species list, reaction list, (read in "chemset.f") +! photolysis reaction list +! +! Input files for FAST-J photolysis: +! ============================================================================ +! ratj.d : Lists photo species, branching ratios (read in "rd_js.f") +! jv_atms.dat : Climatology of T and O3 (read in "rd_prof.f") +! jv_spec.dat : Cross-sections for each species (read in "RD_TJPL.f") +! +! Input files for SLOW-J photolysis: +! ============================================================================ +! jvalue.dat : Solar flux data, standard T and O3 (read in "jvaluein.f") +! profiles, aerosol optical depths +! 8col.dat : SLOW-J cross-section data (read in "jvaluein.f") +! chemga.dat : Aerosol data +! o3du.dat : O3 in Dobson units, cloud data (read in "jvaluein.f") +! +! NOTES: +! (1 ) Cleaned up a lot of stuff. SUNCOS, OPTD, ALBD, and AVGW are now +! referenced from dao_mod.f. IREF and JREF are obsolete. Also +! updated comments. (bmy, 9/27/01) +! (2 ) Do not declare LPRT or set LPRT = .FALSE. in "chemdr.f". LPRT is +! included via "CMN" and is defined in "main.f". (bmy, 10/9/01) +! (3 ) Removed obsolete data from 9/01 (bmy, 10/23/01) +! (4 ) ERADIUS(JLOOP) is now ERADIUS(JLOOP,1) and TAREA(JLOOP) is now +! TAREA(JLOOP,1) for sulfate aerosol. Updated comments. (bmy, 11/15/01) +! (5 ) Renamed routine PAFTOP to DEBUG_MSG. Also deleted obsolete code +! from 11/01. Enhanced debug output via DEBUG_MSG. Also reference +! the UVALBEDO array directly from "uvalbedo_mod.f". Remove UVALBEDO +! from the argument list. Removed obsolete comments. (bmy, 1/15/02) +! (6 ) Now pass LPAUSE to "initgas.f" via the arg list (bmy, 2/14/02) +! (7 ) Now call "rdaer.f" instead of RDAEROSOL to read the aerosol and dust +! fields from disk. Also, ignore hygroscopic growth for dust. Now +! pass SAVEHO2 and FRACNO2 arrays in the arg list to "ohsave.f"; these +! return HO2 conc.'s and NO2 fraction. Delete NTRACE from call +! to "ohsave.f", it's obsolete. Delete reference to DARSFCA from +! "comode_mod.f", it's obsolete. (rvm, bmy, 2/27/02) +! (8 ) Removed obsolete code from 2/02. (bmy, 4/15/02) +! (9 ) Replaced all instances of IM with IIPAR and JM with JJPAR, in order +! to prevent namespace confusion for the new TPCORE (bmy, 6/25/02) +! (10) Now reference IU_CTMCHEM from "file_mod.f". Assign the value of +! IU_CTMCHEM (which =93) to IO93 for SMVGEAR routines. Also open +! "ctm.chem" file on the first call as file unit # IO93. Add +! references to "CMN_DIAG" and "planeflight_mod.f". Call routine +! SETUP_PLANEFLIGHT to initialize the plane track diagnostic +! after reading the "chem.dat" file. (bmy, 7/2/02) +! (11) Now reference AD, T and BXHEIGHT from "dao_mod.f". Also removed +! obsolete commented out code in various sections below. Now also +! references "tracerid_mod.f". Also remove reference to BIOTRCE, since +! this is now obsolete. Now make FIRSTCHEM a local SAVED variable +! instead of an argument. Now calls MAKE_AVGW, which was formerly +! called in "main.f". (bmy, 11/15/02) +! (12) Now reference "AIRVOL" from "dao_mod.f". Now declare local array +! SO4_NH4_NIT, which will contain lumped SO4, NH3, NIT aerosol. Now +! pass SO4_NH4_NIT to "rdaer.f" via the arg list if sulfate chemistry +! is turned on. Now also references CMN_SETUP. (rjp, bmy, 3/23/03) +! (13) Removed ITAU from the arg list. Removed reference to IHOUR. Now use +! functions GET_MONTH, GET_YEAR from "time_mod.f" (bmy, 3/27/03) +! (14) Remove KYEAR and TWO_PI, these are now obsolete for SMVGEAR II. Now +! open unit #93 and call READER in the same FIRSTCHEM if-block. Now +! Replace call to CHEMSET with call to READCHEM. JPARSE is now called +! from w/in READCHEM. Replace call to INITGAS w/ call to GASCONC. +! Removed reference to "file_mod.f". Remove call to SETPL, we now must +! call this in "readchem.f" before the call to JSPARSE. +! (bdf, ljm, bmy, 5/8/03) +! (15) Now reference routine GET_GLOBAL_CH4 from "global_ch4_mod.f". Also +! added CH4_YEAR as a SAVEd variable. (bnd, bmy, 7/1/03) +! (16) Remove references to MONTHP, IMIN, ISEC; they are obsolete and not +! defined anywhere. (bmy, 7/16/03) +! (17) Now reference SUNCOSB from "dao_mod.f". Now pass SUNCOSB to "chem.f". +! Also remove LSAMERAD from call to CHEM, since it's obsolete. +! (gcc, bmy, 7/30/03) +! (18) Added BCPO, BCPI, OCPO, OCPI, and SOILDUST arrays. Now pass SOILDUST +! to RDUST_ONLINE (in "dust_mod.f"). Now pass PIEC, POEC, PIOC, POOC to +! "rdaer.f". Now references "dust_mod.f". (rjp, tdf, bmy, 4/1/04) +! (19) Added SALA and SALC arrays for passing seasalt to rdaer.f. Now +! rearranged the DO loop for computational efficiency. (bmy, 4/20/04) +! (20) Added OCF parameter to account for the other chemical components that +! are attached to OC. Also now handle hydrophilic OC differently for +! online & offline SOA. (rjp, bmy, 7/15/04) +! (21) Now reference "logical_mod.f". Now reference STT and N_TRACERS from +! "tracer_mod.f". Now references DO_DIAG_PL from "diag_pl_mod.f". +! Now references DO_DIAG_OH from "diag_oh_mod.f". Now references +! AEROSOL_CONC, RDAER, & SOILDUST from "aerosol_mod.f" (bmy, 7/20/04) +! (22) Now references ITS_A_NEW_DAY from "time_mod.f". Now calls routine +! SETUP_PLANEFLIGHT at the start of each new day. (bmy, 3/24/05) +! (23) FAST-J is now the default, so we don't need the LFASTJ C-preprocessor +! switch any more (bmy, 6/23/05) +! (24) Now remove LPAUSE from the arg list to "ruralbox.f" and "gasconc.f". +! (bmy, 8/22/05) +! (25) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (26) Now references XNUMOL & XNUMOLAIR from "tracer_mod.f" (bmy, 10/25/05) +! (27) Remove more obsolete SLOW-J code references. Also now move function +! calls from subroutine "chem.f" into "chemdr.f". Remove obsolete +! arguments from call to RURALBOX. (bmy, 4/10/06) +! (28) Remove reference to "global_ch4_mod.f". Add error check for LISOPOH +! when using the online SOA tracers. (dkh, bmy, 6/1/06) +! (29) Now support variable tropopause (bdf, phs, bmy, 10/3/06) +! (30) Now get CH4 concentrations for FUTURE_YEAR when using the future +! emissions scale factors (swu, havala, bmy, 1/28/04) +! (31) Now call "save_full_trop" at the end to account for "do_diag_pl" +! resetting some of CSPEC elements (phs, 6/3/08) +! (32) Reading the CSPEC_FULL restart file if asked.(dkh, hotp, ccc 2/26/09) +! (33) Now use GET_DIRECTION +! (34) LVARTROP treated correctly (dkh, 01/26/11) +! (35) Add support for strat chem adj LADJ_STRAT and check to make sure that +! FD location is in the trop prior to printing debug info for LPRINTFD. +! (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE AEROSOL_MOD, ONLY : AEROSOL_CONC, RDAER, SOILDUST + USE COMODE_MOD, ONLY : ABSHUM, CSPEC, ERADIUS, TAREA, + & CSPEC_FOR_KPP, JLOP, R_KPP + USE DAO_MOD, ONLY : AD, AIRVOL, ALBD, AVGW + USE DAO_MOD, ONLY : BXHEIGHT, MAKE_AVGW, OPTD, SUNCOS + USE DAO_MOD, ONLY : SUNCOSB, T + USE DIAG_OH_MOD, ONLY : DO_DIAG_OH + USE DIAG_PL_MOD, ONLY : DO_DIAG_PL + USE DUST_MOD, ONLY : RDUST_ONLINE, RDUST_OFFLINE + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_YEAR + USE LOGICAL_MOD, ONLY : LCARB, LDUST, LEMBED + USE LOGICAL_MOD, ONLY : LPRT, LSSALT, LSULF + USE LOGICAL_MOD, ONLY : LSOA, LVARTROP, LFUTURE + USE LOGICAL_MOD, ONLY : LEMIS + USE PLANEFLIGHT_MOD, ONLY : SETUP_PLANEFLIGHT + USE TIME_MOD, ONLY : GET_MONTH, GET_YEAR + USE TIME_MOD, ONLY : ITS_A_NEW_DAY + USE TRACER_MOD, ONLY : STT, N_TRACERS, XNUMOL + USE TRACERID_MOD, ONLY : IDTNOX, IDTOX, SETTRACE + USE TROPOPAUSE_MOD, ONLY : SAVE_FULL_TROP + USE UVALBEDO_MOD, ONLY : UVALBEDO + ! To use CSPEC_FULL restart (dkh, 02/12/09 + USE RESTART_MOD, ONLY : READ_CSPEC_FILE + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, GET_TAU + USE LOGICAL_MOD, ONLY : LSVCSPEC + ! add for adjoint (dkh, 07/31/09) + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE ADJ_ARRAYS_MOD, ONLY : NFD + USE ADJ_ARRAYS_MOD, ONLY : CHECK_STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE TIME_MOD, ONLY : GET_DIRECTION + USE CHECKPT_MOD, ONLY : CHK_STT_BEFCHEM + USE CHEMISTRY_MOD, ONLY : GCKPP_ADJ_DRIVER + USE COMODE_MOD, ONLY : CSPEC_FOR_KPP, CSPEC_ADJ + !USE COMODE_MOD, ONLY : NO2_AFTER_CHEM_ADJ + !USE COMODE_MOD, ONLY : CSPEC_ADJ_FORCE + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE COMODE_MOD, ONLY : CHK_CSPEC + USE COMODE_MOD, ONLY : CSPEC_ORIG + USE DRYDEP_MOD, ONLY : NUMDEP + USE GCKPP_ADJ_Global, ONLY : NTT + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE LOGICAL_MOD, ONLY : LSCHEM + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD, LFDTEST + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_OBS + USE STRAT_CHEM_ADJ_MOD, ONLY : DO_STRAT_CHEM_ADJ + + USE TIME_MOD, ONLY : GET_NYMDb, GET_NHMSb + USE TIME_MOD, ONLY : GET_LOCALTIME + USE TRACERID_MOD, ONLY : IDTSO2, IDTSO4 + + ! dkh debug + USE TRACERID_MOD, ONLY : IDNO + + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! IEBD1, IEBD2, etc. +# include "CMN_O3" ! EMISRRN, EMISRR +# include "CMN_NOX" ! SLBASE +# include "comode.h" ! SMVGEAR variables +# include "CMN_DEP" ! FRCLND +# include "CMN_DIAG" ! ND40 +# include "define_adj.h" ! OBS operators + + ! Local variables + LOGICAL, SAVE :: FIRSTCHEM = .TRUE. + INTEGER, SAVE :: CH4_YEAR = -1 + INTEGER :: I, J, JLOOP, L, NPTS, N, MONTH, YEAR + ! Now use GET_DIRECTION (dkh, 01/26/10) + !INTEGER :: DIRECTION + + + ! To use CSPEC_FULL restart (dkh, 02/12/09) + LOGICAL :: IT_EXISTS + + ! ADJ_GROUP + INTEGER :: NYMD, NHMS + INTEGER :: JLOOPTMP + INTEGER :: IDCSPEC + REAL*8 :: TAU + REAL*8 :: ADJ_SO4_NH4_NIT(IIPAR,JJPAR,LLPAR) + REAL*8 :: ADJ_BCPI(IIPAR,JJPAR,LLPAR) + REAL*8 :: ADJ_BCPO(IIPAR,JJPAR,LLPAR) + REAL*8 :: ADJ_OCPI(IIPAR,JJPAR,LLPAR) + REAL*8 :: ADJ_OCPO(IIPAR,JJPAR,LLPAR) + ! (dkh, 01/06/12, adj32_006) + INTEGER :: JJ, NK + + + !================================================================= + ! CHEMDR_ADJ begins here! + !================================================================= + + ! Set some size variables + NLAT = JJPAR + NLONG = IIPAR + NVERT = IVERT + NPVERT = NVERT + NPVERT = NVERT + IPLUME + + ! Get month and year + MONTH = GET_MONTH() + YEAR = GET_YEAR() + + !================================================================= + ! Compute AVGW, the mixing ratio of water vapor + !================================================================= + CALL MAKE_AVGW + + ! All the FIRSTCHEM stuff will have been done during the forward run, + ! Only redo this on the final adjoint step. + IF ( GET_NYMD() == GET_NYMDb() .AND. + & GET_NHMS() == GET_NHMSb() ) THEN + ! dkh debug + print*, ' FIRSTCHEM = TRUE ' + FIRSTCHEM = .TRUE. + ELSE + FIRSTCHEM = .FALSE. + ENDIF + + !================================================================= + ! Open "smv2.log" output file and read chem mechanism switches + !================================================================= + IF ( FIRSTCHEM ) THEN + + ! Read from data file mglob.dat + CALL READER( FIRSTCHEM ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after READER' ) + + ! Set NCS for urban chemistry only (since that is where we + ! have defined the GEOS-CHEM mechanism) (bdf, bmy, 4/21/03) + NCS = NCSURBAN + ENDIF + + !================================================================= + ! Call RURALBOX, which defines tropospheric boxes to be sent to + ! the SMVGEAR solver, as well as setting up some SMVGEAR arrays. + !================================================================= + + ! Redefine NTLOOP since READER defines it initially (bmy, 9/28/04) + NLOOP = NLAT * NLONG + NTLOOP = NLOOP * NVERT + + CALL RURALBOX( AD, T, AVGW, ALBD, SUNCOS, + & LEMBED, IEBD1, IEBD2, JEBD1, JEBD2 ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after RURALBOX' ) + + ! Reset NTTLOOP, the # of tropospheric grid boxes + NTTLOOP = NTLOOP + + !================================================================= + ! Call SETMODEL which defines number of grid-blocks in calculation, + ! and copies meteorological parameters into local variables + !================================================================= + CALL SETMODEL + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after SETMODEL' ) + + !================================================================= + ! Do the following only on the first call ... + !================================================================= + IF ( FIRSTCHEM ) THEN + + !--------------------------------- + ! Initialize chemistry mechanism + !--------------------------------- + + + NEMIS(NCSURBAN) = 0 + NNADDV(NCSURBAN) = 0 + NNADDA(NCSURBAN) = 0 + NNADDB(NCSURBAN) = 0 + NNADDC(NCSURBAN) = 0 + NNADDD(NCSURBAN) = 0 + NNADDF(NCSURBAN) = 0 + NNADDH(NCSURBAN) = 0 + NNADDG(NCSURBAN) = 0 + ! dkh debug: try not reading this during adj integration + ! to avoid over incrementing NEMIS (dkh, 07/31/09) + ! Read "globchem.dat" chemistry mechanism + CALL READCHEM + + ! Set NCS=NCSURBAN here since we have defined our tropospheric + ! chemistry mechanism in the urban slot of SMVGEAR II (bmy, 4/21/03) + NCS = NCSURBAN + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after READCHEM' ) + + !--------------------------------- + ! Check for LISOPOH for SOA + !--------------------------------- + IF ( LSOA .and. ILISOPOH == 0 ) THEN + CALL ERROR_STOP( 'LISOPOH needs to be defined for SOA!', + & 'chemdr.f' ) + ENDIF + + !--------------------------------- + ! Set global concentration of CH4 + !--------------------------------- + IF ( ICH4 > 0 .and. ( CH4_YEAR /= GET_YEAR() ) ) THEN + + ! If CH4 is a SMVGEAR II species, then call GET_GLOBAL_CH4 + ! to return the globally-varying CH4 conc. as a function of + ! year and latitude bin. (ICH4 is defined in READCHEM.) + ! (bnd, bmy, 7/1/03) + ! + ! If we are using the future emissions, then get the CH4 + ! concentrations for FUTURE_YEAR. Otherwise get the CH4 + ! concentrations for the current met field year. + ! (swu, havala, bmy, 1/24/08) + IF ( LFUTURE ) THEN + CH4_YEAR = GET_FUTURE_YEAR() + ELSE + CH4_YEAR = GET_YEAR() + ENDIF + + ! Get CH4 [ppbv] in 4 latitude bins for each year + CALL GET_GLOBAL_CH4( CH4_YEAR, .TRUE., C3090S, + & C0030S, C0030N, C3090N ) + ENDIF + + !------------------------------- + ! Initialize FAST-J photolysis + !------------------------------- + CALL INPHOT( LLTROP, NPHOT ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after INPHOT' ) + + !------------------------------- + ! Flag certain chemical species + !------------------------------- + CALL SETTRACE + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after SETTRACE' ) + + !------------------------------- + ! Flag emission & drydep rxns + !------------------------------- + CALL SETEMDEP( N_TRACERS ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after SETEMDEP' ) + + ENDIF + + !================================================================= + ! At the beginning of each new day, call SETUP_PLANEFLIGHT + ! to see if there are any plane flight points to be processed + !================================================================= + IF ( ND40 > 0 .and. ITS_A_NEW_DAY() ) THEN + CALL SETUP_PLANEFLIGHT + ENDIF + + !================================================================ + ! Get concentrations of aerosols in [kg/m3] + ! for FAST-J and optical depth diagnostics + !================================================================= + IF ( LSULF .or. LCARB .or. LDUST .or. LSSALT ) THEN + + ! Skip this section if all these are turned off + CALL AEROSOL_CONC + + ENDIF + +! Now this is done at the end of DO_WETDEP_ADJ +! ! SO2 and SO4 may have changed during DO_ADJ_WETDEP, so +! ! reload their values here. (dkh, 2006) +! IF ( GET_DIRECTION() < 0 ) THEN +! STT(:,:,:,IDTSO2) = CHK_STT_BEFCHEM(:,:,:,IDTSO2) +! STT(:,:,:,IDTSO4) = CHK_STT_BEFCHEM(:,:,:,IDTSO4) +! ENDIF + + + !================================================================= + ! Call GASCONC which initializes gas concentrations and sets + ! miscellaneous parameters. GASCONC also calls PARTITION, which + ! splits up family tracers like NOx and Ox into individual + ! chemical species for SMVGEAR. + ! NOTE: + ! (1) The call to GASCONC is modified to use CSPEC_FULL restart + ! file (dkh, hotp, ccc,2/26/09) + !================================================================= + IT_EXISTS = .FALSE. + IF ( FIRSTCHEM .AND. LSVCSPEC ) THEN + + CALL READ_CSPEC_FILE( GET_NYMD(), GET_NHMS(), IT_EXISTS ) + + IF ( .not. IT_EXISTS ) THEN + + ! Use default background values + WRITE(6,*) + & ' - CHEMDR: CSPEC restart not found, use background values' + + CALL GASCONC( FIRSTCHEM, N_TRACERS, STT, XNUMOL, FRCLND, + & IT_EXISTS ) + + ELSE + + ! Use default background values + WRITE(6,*) + & ' - CHEMDR: using CSPEC values from restart file' + + ! Call GASCONC but don't reset CSPEC values + CALL GASCONC( .FALSE., N_TRACERS, STT, XNUMOL, FRCLND, + & IT_EXISTS ) + + ENDIF + + ELSE + + ! dkh debug + !IF ( LPRINTFD ) THEN + IF ( LPRINTFD .and. JLOP(IFD,JFD,LFD) > 0 ) THEN + print*, ' CSPEC before partition adj = ', + & CSPEC(JLOP(IFD,JFD,LFD),:) + ENDIF + + ! Copy CSPEC top CSPEC_FULL so that CSPEC doesn't get + ! overwritten with an old CSPEC_FULL in GASCONC (dkh, 08/04/09) + ! LVARTROP support for adj (dkh, 01/26/11) + ! don't need to do this now becuase we actually checkpt CSPEC_FULL +! IF ( LVARTROP ) CALL SAVE_FULL_TROP + CALL GASCONC( FIRSTCHEM, N_TRACERS, STT, XNUMOL, FRCLND, + & IT_EXISTS ) + + ENDIF + IT_EXISTS = .FALSE. + + !ADJ_GROUP: Saving CSPEC for KPP calculation + CSPEC_FOR_KPP(:,:) = CSPEC(:,:) + CSPEC_ORIG(:,:) = CSPEC(:,:) + + !IF ( LPRINTFD ) THEN + IF ( LPRINTFD .and. JLOP(IFD,JFD,LFD) > 0 ) THEN + + WRITE(6,*) 'CSPEC(FD) after GASCONC = ', + & CSPEC(JLOP(IFD,JFD,LFD),:) + print*, 'STT_ADJ in chemdr_adj', STT_ADJ(IFD,JFD,LFD,:) + print*, 'CSPEC_ADJ before lump_adj', + & CSPEC_ADJ(JLOP(IFD,JFD,LFD),:) + ENDIF + + + ! Use dkh's adjoint routine for lumping and partioning + CALL LUMP_ADJ( N_TRACERS, XNUMOL, STT_ADJ ) + + !IF ( LPRINTFD ) THEN + IF ( LPRINTFD .and. JLOP(IFD,JFD,LFD) > 0 ) THEN + print*, 'STT_ADJ after lump_adj', STT_ADJ(IFD,JFD,LFD,:) + print*, 'CSPEC_ADJ after lump_adj', + & CSPEC_ADJ(JLOP(IFD,JFD,LFD),:) + ENDIF + + + ! Update for new strat chem (hml dkh, 02/14/12, adj32_025) + !! SCHEM applies a simplified strat chemistry in order + !! to prevent stuff from building up in the stratosphere + !!CALL SCHEM_ADJ + ! Do stratospheric chemistry adjoint + IF ( LSCHEM ) CALL DO_STRAT_CHEM_ADJ + + !### Debug + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMDR_ADJ: after STRAT_CHEM_ADJ' ) + + ! Reset dry dep adjoints (fp, dkh, 01/06/12, adj32_006) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( N, NK, JJ ) + DO N = 1,NUMDEP + NK = NTDEP(N) + IF (NK.NE.0) THEN + JJ = IRM(NPRODLO+1,NK,NCS) + IF (JJ.GT.0) THEN + CSPEC_ADJ(:,JJ) = 0.0D0 + ENDIF + ENDIF + ENDDO +!$OMP END PARALLEL DO + + + ! Apply forcing from observation (or sensitivyt w.r.t) + ! of CSPEC species. (dkh, 10/25/07) + ! Now use CSPEC_AFTER_CHEM_ADJ (dkh, 02/09/11) + IF ( LCSPEC_OBS ) THEN + DO N = 1, NOBS_CSPEC + + IDCSPEC = IDCSPEC_ADJ(N) + + CSPEC_ADJ(:,IDCSPEC) = CSPEC_ADJ(:,IDCSPEC) + & + CSPEC_AFTER_CHEM_ADJ(:,N) + + CSPEC_AFTER_CHEM_ADJ(:,N) = 0d0 + + ENDDO + ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after GASCONC' ) + + !================================================================= + ! Call RDAER -- computes aerosol optical depths + !================================================================= + CALL RDAER( MONTH, YEAR ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after RDAER' ) + + !================================================================= + ! If LDUST is turned on, then we have online dust aerosol in + ! GEOS-CHEM...so just pass SOILDUST to RDUST_ONLINE in order to + ! compute aerosol optical depth for FAST-J, etc. + ! + ! If LDUST is turned off, then we do not have online dust aerosol + ! in GEOS-CHEM...so read monthly-mean dust files from disk. + ! (rjp, tdf, bmy, 4/1/04) + !================================================================= + IF ( LDUST ) THEN + CALL RDUST_ONLINE( SOILDUST ) + ELSE + CALL RDUST_OFFLINE( MONTH, YEAR ) + ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR: after RDUST' ) + + NPTS = NTTLOOP + + ! At present, we are only doing tropospheric chemistry, which + ! for the moment we are storing in SMVGEAR II's "urban" slot + NCS = NCSURBAN + + !================================================================= + ! Call photolysis routine to compute J-Values + !================================================================= + CALL FAST_J( SUNCOS, OPTD, UVALBEDO ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after FAST-J' ) + + !================================================================= + ! Call SETEMIS which sets emission rates REMIS + !================================================================= + CALL SETEMIS( EMISRR, EMISRRN ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after SETEMIS' ) + + !================================================================ + ! Call chemistry routines + !================================================================ + + ! PHYSPROC calls both CALCRATE, which computes rxn rates + ! and SMVGEAR, which is the chemistry solver + CALL PHYSPROC( SUNCOS, SUNCOSB ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMDR_ADJ: after PHYSPROC' ) + + NHMS = GET_NHMS() + NYMD = GET_NYMD() + TAU = GET_TAU() + + NTT = NTTLOOP + + !================================================================ + ! Call KPP generated chemical solver. DIRECTION = -1 is adjoint + !================================================================ + CALL GCKPP_ADJ_DRIVER( GET_DIRECTION() ) + + !### Debug + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMDR_ADJ: after GCKPP_ADJ_DRIVER') + + ! Can compare KPP to SMVGEAR side-by-side (dkh, 06/20/05) + !IF ( LPRINTFD ) THEN + IF ( LPRINTFD .and. JLOP(IFD,JFD,LFD) > 0 ) THEN + + + !! Display times (SMVGEAR time will be padded by time to do CALCRATE ) + !WRITE(6,*) ' SMVGEAR TIME : ', TIME2 - TIME1 + !WRITE(6,*) ' ROSENBK TIME : ', TIME3 - TIME2 + + ! Display comparison for a particular cell + JLOOPTMP = JLOP(IFD,JFD,LFD) + WRITE(6,*) ' Spot test in cell:', JLOOPTMP + WRITE(6,*) ' LON = ', GET_XMID(IFD) + WRITE(6,*) ' LAT = ', GET_YMID(JFD) + WRITE(6,*) ' LOCAL TIME = ', GET_LOCALTIME(IFD) + + WRITE(6,*) ' Species SMVGEAR ROS R/S + & ORIG ' + WRITE(6,69) (NAMEGAS(I),CSPEC(JLOOPTMP,I), + & CSPEC_FOR_KPP(JLOOPTMP,I), + & CSPEC_FOR_KPP(JLOOPTMP,I) / CSPEC(JLOOPTMP,I), + & CSPEC_ORIG(JLOOPTMP,I), + & I=1,87) + 69 FORMAT(A10,1X,F20.2,1X,F20.2,1X,1PE10.2,1X,F20.2) + + ENDIF + + + + ! dkh debug + WRITE(6,*) ' - CHECK_STT_ADJ after GCKPP_ADJ_DRIVER' + CALL CHECK_STT_ADJ('AFTER GCKPP_ADJ_DRIVER') + + ! We don't call any adjoint of PHYSPROC. We just directly call CALCRATE_ADJ + ! from within GCKPP_ADJ_DRIVER. That saves us some RAM. + + + !================================================================= + ! Do adjoint of rdaer + !================================================================= + print*, ' NEED to update ADJ_RDAER ' + print*, ' NEED to update ADJ_RDAER ' + print*, ' NEED to update ADJ_RDAER ' + print*, ' NEED to update RDAER_ADJ ' +! CALL RDAER_ADJ( SO4_NH4_NIT, BCPI, BCPO, OCPI, OCPO, +! & ADJ_SO4_NH4_NIT, ADJ_BCPI, ADJ_BCPO, +! & ADJ_OCPI, ADJ_OCPO ) + + ! For now, don't include these in FDTESTs + IF ( LFDTEST ) THEN + ADJ_SO4_NH4_NIT = 0d0 + ADJ_BCPI = 0D0 + ADJ_BCPO = 0D0 + ADJ_OCPI = 0D0 + ADJ_OCPO = 0D0 + ENDIF + + !================================================================= + ! Do adjoint of setemis + !================================================================= + + CALL SETEMIS_ADJ + + !================================================================= + ! To do this we need STT = STT_BEFCHEM and + ! CSPEC = CSPEC_CHK = CSPEC from after chem of step n - 1. + ! CSPEC neads to be reloaded, it + ! was overwritten in the above call to PARTITION +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + STT(I,J,L,N) = CHK_STT_BEFCHEM(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP, N ) + DO N = 1, IGAS + DO JLOOP = 1, ITLOOP + + CSPEC(JLOOP,N) = CHK_CSPEC(JLOOP,N) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !IF ( LPRINTFD ) THEN + IF ( LPRINTFD .and. JLOP(IFD,JFD,LFD) > 0 ) THEN + print*, 'CSPEC_ADJ before partition_adj', + & CSPEC_ADJ(JLOP(IFD,JFD,LFD),:) + ENDIF + + ! Use partition adjoint from dkh + CALL PARTITION_ADJ( STT_ADJ, STT, N_TRACERS, XNUMOL ) + + ! Now use insead of CSPEC_AFTER_CHEM_ADJ (nb, dkh, 01/06/12, adj32_003) +!#if defined( SCIA_KNMI_NO2_OBS ) || defined( SCIA_DAL_NO2_OBS ) +! ! Apply forcing from satellite observations +! CSPEC_ADJ(:,IDNO2) = CSPEC_ADJ(:,IDNO2) + CSPEC_NO2_ADJ(:) +! CSPEC_NO2_ADJ(:) = 0d0 +!#endif + + + !### Debug + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMDR_ADJ: after PARTITION_ADJ' ) + + !IF ( LPRINTFD ) THEN + IF ( LPRINTFD .and. JLOP(IFD,JFD,LFD) > 0 ) THEN + print*, 'CSPEC_ADJ after partition_adj', + & CSPEC_ADJ(JLOP(IFD,JFD,LFD),:) + print*, 'STT_ADJ after partition_adj', + & STT_ADJ(IFD,JFD,LFD,:) + ENDIF + + ! dkh debug + WRITE(6,*) 'CHECK_STT_ADJ after PARTITION_ADJ' + CALL CHECK_STT_ADJ('after partition_adj') + + + ! Adjoint of AEROSOL_CONT + !================================================================= + IF ( LSULF .or. LCARB .or. LDUST .or. LSSALT ) THEN + + ! Skip this section if all these are turned off + print*, ' NEED to updae AEROSOL_CONC_ADJ' + print*, ' NEED to updae AEROSOL_CONC_ADJ' + print*, ' NEED to updae AEROSOL_CONC_ADJ' + print*, ' NEED to updae AEROSOL_CONC_ADJ' + !CALL AEROSOL_CONC_ADJ + + ENDIF + + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### Now exiting CHEMDR_ADJ!' ) + + ! Return to calling program + END SUBROUTINE CHEMDR_ADJ + + + + diff --git a/code/adjoint/chemistry_adj_mod.f b/code/adjoint/chemistry_adj_mod.f new file mode 100644 index 0000000..df30bb7 --- /dev/null +++ b/code/adjoint/chemistry_adj_mod.f @@ -0,0 +1,715 @@ +! $Id: chemistry_adj_mod.f,v 1.10 2012/09/05 22:35:07 yanko Exp $ + MODULE CHEMISTRY_ADJ_MOD +! +!****************************************************************************** +! Module CHEMISTRY_MOD is used to call the proper chemistry subroutine +! for the various GEOS-CHEM simulations. (bmy, 4/14/03, 4/2/08) +! +! Module Routines: +! ============================================================================ +! (1 ) DO_CHEMISTRY : Driver which calls various chemistry routines +! +! GEOS-CHEM modules referenced by chemistry_mod.f +! ============================================================================ +! (1 ) acetone_mod.f : Module w/ routines for ACET chemistry +! (2 ) c2h6_mod.f : Module w/ routines for C2H6 chemistry +! (3 ) carbon_mod.f : Module w/ routines for carbon arsl chem. +! (4 ) ch3i_mod.f : Module w/ routines for CH3I chemistry +! (5 ) dao_mod.f : Module w/ arrays for DAO met fields +! (6 ) diag_pl_mod.f : Module w/ routines to save P(Ox), L(Ox) +! (7 ) drydep_mod.f : Module w/ GEOS-CHEM drydep routines +! (8 ) dust_mod.f : Module w/ routines for dust arsl chem. +! (9 ) error_mod.f : Module w/ NaN and error checks +! (10) global_ch4_mod.f : Module w/ routines for CH4 chemistry +! (11) hcn_ch3cn_mod.f : Module w/ routines for HCN and CH3CN chemistry +! (12) Kr85_mod.f : Module w/ routines for Kr85 chemistry +! (13) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (14) RnPbBe_mod.f : Module w/ routines for Rn-Pb-Be chemistry +! (15) rpmares_mod.f : Module w/ routines for arsl phase equilib. +! (16) seasalt_mod.f : Module w/ routines for seasalt chemistry +! (17) sulfate_mod.f : Module w/ routines for sulfate chemistry +! (18) tagged_co_mod.f : Module w/ routines for Tagged CO chemistry +! (19) tagged_ox_mod.f : Module w/ routines for Tagged Ox chemistry +! (20) time_mod.f : Module w/ routines to compute time & date +! (21) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc. +! (22) tracerid_mod.f : Module w/ pointers to tracers & emissions +! (23) isoropiaii_mod.f : Module w/ routines for arsl equlib w/NaCl. +! +! NOTES: +! (1 ) Bug fix in DO_CHEMISTRY (bnd, bmy, 4/14/03) +! (2 ) Now references DEBUG_MSG from "error_mod.f" (bmy, 8/7/03) +! (3 ) Now references "tagged_ox_mod.f"(bmy, 8/18/03) +! (4 ) Now references "Kr85_mod.f" (jsw, bmy, 8/20/03) +! (5 ) Bug fix: Now also call OPTDEPTH for GEOS-4 (bmy, 1/27/04) +! (6 ) Now references "carbon_mod.f" and "dust_mod.f" (rjp, tdf, bmy, 4/5/04) +! (7 ) Now references "seasalt_mod.f" (rjp, bec, bmy, 4/20/04) +! (8 ) Now references "logical_mod.f", "tracer_mod.f", "diag20_mod.f", and +! "diag65_mod.f", and "aerosol_mod." (bmy, 7/20/04) +! (9 ) Now references "mercury_mod.f" (bmy, 12/7/04) +! (10) Updated for SO4s, NITs chemistry (bec, bmy, 4/13/05) +! (11) Now call CHEM_HCN_CH3CN from "hcn_ch3cn_mod.f". Also remove all +! references to the obsolete CO-OH param simulation. (xyp, bmy, 6/24/05) +! (12) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (13) Now call MAKE_RH from "main.f" (bmy, 3/16/06) +! (14) Updated for SOA from isoprene (dkh, bmy, 6/1/06) +! (15) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +! (16) For now, replace use RPMARES instead of ISORROPIA. (bmy, 4/2/08) +! (17) Modified for ISORROPIA II (slc, 3/9/13, ***) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_CHEMISTRY_ADJ +! +!****************************************************************************** +! Subroutine DO_CHEMISTRY is the driver routine which calls the appropriate +! chemistry subroutine for the various GEOS-CHEM simulations. +! (bmy, 2/11/03, 9/18/07) +! +! NOTES: +! (1 ) Now reference DELP, T from "dao_mod.f" since we need to pass this +! to OPTDEPTH for GEOS-1 or GEOS-STRAT met fields (bnd, bmy, 4/14/03) +! (2 ) Now references DEBUG_MSG from "error_mod.f" (bmy, 8/7/03) +! (3 ) Removed call to CHEMO3, it's obsolete. Now calls CHEM_TAGGED_OX ! +! from "tagged_ox_mod.f" when NSRCX==6. Now calls Kr85 chemistry if +! NSRCX == 12 (jsw, bmy, 8/20/03) +! (4 ) Bug fix: added GEOS-4 to the #if block in the call to OPTDEPTH. +! (bmy, 1/27/04) +! (5 ) Now calls CHEMCARBON and CHEMDUST to do carbon aerosol & dust +! aerosol chemistry (rjp, tdf, bmy, 4/2/04) +! (6 ) Now calls CHEMSEASALT to do seasalt aerosol chemistry +! (rjp, bec, bmy, 4/20/04) +! (7 ) Now references "logical_mod.f" & "tracer_mod.f". Now references +! AEROSOL_CONC, AEROSOL_RURALBOX, and RDAER from "aerosol_mod.f". +! Now includes "CMN_DIAG" and "comode.h". Also call READER, READCHEM, +! and INPHOT to initialize the FAST-J arrays so that we can save out ! +! AOD's to the ND21 diagnostic for offline runs. (bmy, 7/20/04) +! (8 ) Now call routine CHEMMERCURY from "mercury_mod.f" for an offline +! Hg0/Hg2/HgP simulation. (eck, bmy, 12/7/04) +! (9 ) Now do not call DO_RPMARES if we are doing an offline aerosol run +! with crystalline sulfur & aqueous tracers (cas, bmy, 1/7/05) +! (10) Now use ISOROPIA for aer thermodyn equilibrium if we have seasalt +! tracers defined, or RPMARES if not. Now call CHEMSEASALT before +! CHEMSULFATE. Now do aerosol thermodynamic equilibrium before +! aerosol chemistry for offline aerosol runs. Now also reference +! CLDF from "dao_mod.f" (bec, bmy, 4/20/05) +! (11) Now modified for GCAP met fields. Now call CHEM_HCN_CH3CN from +! "hcn_ch3cn_mod.f". Also remove allreferences to the obsolete +! CO-OH param simulation. (xyp, bmy, 6/23/05) +! (12) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (13) Now call MAKE_RH from "main.f" (bmy, 3/16/06) +! (14) Removed ISOP_PRIOR as a local variable (dkh, bmy, 6/1/06) +! (15) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +! (16) Now use DRYFLXH2HD and CHEM_H2_HD for H2/HD sim (lyj, phs, 9/18/07) +! (17) Bug fix: now hardwired to use RPMARES since ISORROPIA can return very +! unphysical values at low RH. Wait for ISORROPIA II. (bmy, 4/2/08) +! (18) Updated to support offline BC aerosol (yhmao, dkh, 01/13/12, adj32_013) +! (19) Add support for CH4 (kjw, dkh, 02/12/12, adj32_023) +! (20) Modified for ISORROPIA II (slc, 3/9/13, ***) +!****************************************************************************** +! + ! References to F90 modules + USE ACETONE_MOD, ONLY : OCEAN_SINK_ACET + USE AEROSOL_MOD, ONLY : AEROSOL_CONC, AEROSOL_RURALBOX + USE AEROSOL_MOD, ONLY : RDAER, SOILDUST + USE CARBON_MOD, ONLY : CHEMCARBON + USE C2H6_MOD, ONLY : CHEMC2H6 + USE CH3I_MOD, ONLY : CHEMCH3I + USE DAO_MOD, ONLY : CLDF, DELP + USE DAO_MOD, ONLY : OPTDEP, OPTD, T + USE DRYDEP_MOD, ONLY : DRYFLX, DRYFLXRnPbBe, DRYFLXH2HD + USE DUST_MOD, ONLY : CHEMDUST, RDUST_ONLINE + USE DUST_ADJ_MOD, ONLY : CHEMDUST_ADJ + USE ERROR_MOD, ONLY : DEBUG_MSG + USE ERROR_MOD, ONLY : ERROR_STOP + USE GLOBAL_CH4_MOD, ONLY : CHEMCH4 + USE H2_HD_MOD, ONLY : CHEM_H2_HD + USE HCN_CH3CN_MOD, ONLY : CHEM_HCN_CH3CN + USE ISOROPIAII_ADJ_MOD, ONLY : DO_ISOROPIAII + USE Kr85_MOD, ONLY : CHEMKr85 + USE LOGICAL_MOD, ONLY : LCARB, LCHEM, LCRYST, LDUST + USE LOGICAL_MOD, ONLY : LPRT, LSSALT, LSULF, LSOA + USE MERCURY_MOD, ONLY : CHEMMERCURY + USE OPTDEPTH_MOD, ONLY : OPTDEPTH + USE RnPbBe_MOD, ONLY : CHEMRnPbBe + USE RPMARES_MOD, ONLY : DO_RPMARES + USE SEASALT_MOD, ONLY : CHEMSEASALT + USE SULFATE_MOD, ONLY : CHEMSULFATE + USE TAGGED_OX_MOD, ONLY : CHEM_TAGGED_OX + USE TIME_MOD, ONLY : GET_ELAPSED_MIN, GET_TS_CHEM + USE TIME_MOD, ONLY : ITS_TIME_FOR_CHEM + USE TRACER_MOD, ONLY : N_TRACERS, STT + USE TRACER_MOD, ONLY : ITS_A_C2H6_SIM + USE TRACER_MOD, ONLY : ITS_A_CH3I_SIM + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_A_H2HD_SIM + USE TRACER_MOD, ONLY : ITS_A_HCN_SIM + USE TRACER_MOD, ONLY : ITS_A_MERCURY_SIM + USE TRACER_MOD, ONLY : ITS_A_RnPbBe_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGOX_SIM + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : ITS_NOT_COPARAM_OR_CH4 + USE TRACERID_MOD, ONLY : IDTACET, IDTISOP + + ! adjoint modules: + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE CARBON_ADJ_MOD, ONLY : CHEMCARBON_ADJ + USE ISOROPIAII_ADJ_MOD,ONLY : DO_ISOROPIAII_ADJ + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CHEM + USE LOGICAL_ADJ_MOD, ONLY : LAERO_THERM + USE LOGICAL_ADJ_MOD, ONLY : LISO + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE RPMARES_ADJ_MOD, ONLY : DO_RPMARES_ADJ + USE RPMARES_MOD, ONLY : RECOMP_RPMARES + USE SULFATE_ADJ_MOD, ONLY : CHEMSULFATE_ADJ + USE TAGGED_CO_ADJ_MOD, ONLY : CHEM_TAGGED_CO_ADJ + ! lzh 12/08/2009 add adjoint for tagged ox simulation + USE TAGGED_OX_ADJ_MOD, ONLY : CHEM_TAGGED_OX_ADJ + USE GLOBAL_CH4_ADJ_MOD,ONLY : CHEMCH4_ADJ + + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! NDxx flags +# include "comode.h" ! NPHOT + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: N_TROP + + !================================================================= + ! DO_CHEMISTRY_ADJ begins here! + !================================================================= + + ! Compute optical depths (except for CH4 simulation) + IF ( .not. ITS_A_CH4_SIM() ) THEN + CALL OPTDEPTH( LLPAR, CLDF, OPTDEP, OPTD ) + ENDIF + + !================================================================= + ! If LADJ_CHEM=T then call the adjoint chemistry subroutines + !================================================================= + IF ( LADJ_CHEM ) THEN + + !--------------------------------- + ! NOx-Ox-HC (w/ or w/o aerosols) + !--------------------------------- + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + ! Adjoint of remove acetone ocean sink (it is self-adjoint) + IF ( IDTACET /= 0 ) THEN + CALL OCEAN_SINK_ACET( STT_ADJ(:,:,1,IDTACET) ) + ENDIF + + ! Do carbonaceous aerosol chemistry + IF ( LCARB ) CALL CHEMCARBON_ADJ + + ! Also do sulfate chemistry + IF ( LSULF ) THEN + + ! Do aerosol thermodynamic equilibrium + !------------------------------------------------------------ + ! Prior to 4/2/08: + ! Bug fix: ISORROPIA can return very unphysical values when + ! RH is very low. We will replace the current version of + ! ISORROPIA with ISORROPIA II. In the meantime, we shall + ! use RPMARES to do the ATE computations. (bmy, 4/2/08) + IF ( LAERO_THERM ) THEN + IF ( LISO ) THEN + + IF ( LPRINTFD ) THEN + WRITE(6,*) 'Before ISO_ADJ: STT_ADJ(FD) = ', + & STT_ADJ(IFD,JFD,LFD,NFD) + ENDIF + + ! ISOROPIA takes Na+, Cl- into account + CALL DO_ISOROPIAII_ADJ + + IF ( LPRINTFD ) THEN + WRITE(6,*) 'After ISO_ADJ: STT_ADJ(FD) = ', + & STT_ADJ(IFD,JFD,LFD,NFD) + ENDIF + + ELSE + + ! RPMARES does not take Na+, Cl- into account + ! Recalculate intermediate values + CALL RECOMP_RPMARES + + ! Diagnostic + IF ( LPRINTFD ) THEN + WRITE(6,*) 'Before RPMARES_ADJ: STT_ADJ(FD) = ', + & STT_ADJ(IFD,JFD,LFD,NFD) + ENDIF + + ! Call adjoint aerosol thermodynamics routine + CALL DO_RPMARES_ADJ + + ENDIF + + ENDIF + !------------------------------------------------------------ + + ! Do sulfate chemistry + CALL CHEMSULFATE_ADJ + + ENDIF + + ! Call SMVGEAR routines + CALL CHEMDR_ADJ + + ! Do seasalt aerosol chemistry + IF ( LSSALT ) print*, ' ADJ of CHEMSEASALT not supported' +! IF ( LSSALT ) CALL CHEMSEASALT + + ! Do dust aerosol chemistry + IF ( LDUST ) CALL CHEMDUST_ADJ + + ! ND44 drydep fluxes +! CALL DRYFLX + + ! ND43 chemical production +! CALL DIAGOH + + !--------------------------------- + ! Offline aerosol simulation + !--------------------------------- + ELSE IF ( ITS_AN_AEROSOL_SIM() ) THEN + + ! turn off for BC only aerosol sim (yhmao, dkh, 01/13/12, adj32_013) + ! Define loop index and other SMVGEAR arrays + ! N_TROP, the # of trop boxes, is returned + !CALL AEROSOL_RURALBOX( N_TROP ) + + + ! Initialize FAST-J quantities for computing AOD's + IF ( FIRST ) THEN + CALL READER( FIRST ) + + ! turn off for BC only aerosol sim (yhmao, dkh, 01/13/12, adj32_013) + !CALL READCHEM + !CALL INPHOT( LLTROP, NPHOT ) + + ! Reset NCS with NCSURBAN + NCS = NCSURBAN + + ! Reset NTLOOP and NTTLOOP after call to READER + ! with the actual # of boxes w/in the ann mean trop + NTLOOP = N_TROP + NTTLOOP = N_TROP + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + ! turn off for BC only aerosol sim (yhmao, dkh, 01/13/12, adj32_013) + ! Compute aerosol & dust concentrations [kg/m3] + ! (NOTE: SOILDUST in "aerosol_mod.f" is computed here) + !CALL AEROSOL_CONC + + ! turn off for BC only aerosol sim (yhmao, dkh, 01/13/12, adj32_013) + ! Compute AOD's and surface areas + !CALL RDAER + + !*** AEROSOL THERMODYNAMIC EQUILIBRIUM *** + !------------------------------------------------------------- + ! Prior to 4/2/08: + ! Bug fix: ISORROPIA can return very unphysical values when + ! RH is very low. We will replace the current version of + ! ISORROPIA with ISORROPIA II. In the meantime, we shall + ! use RPMARES to do the ATE computations. (bmy, 4/2/08) + IF ( LSSALT ) THEN + ! + ! ! ISOROPIA takes Na+, Cl- into account + ! CALL DO_ISOROPIA + ! + CALL ERROR_STOP( ' need DO_ISOROPIA_ADJ ', + & ' chemistry_adj_mod.f' ) + ELSE + + ! turn off for BC only aerosol sim (yhmao, dkh, 01/13/12, adj32_013) + ! RPMARES does not take Na+, Cl- into account + ! (skip for crystalline & aqueous offline run) + !IF ( .not. LCRYST ) CALL DO_RPMARES + + ENDIF + !------------------------------------------------------------- + + !*** SEASALT AEROSOLS *** + !IF ( LSSALT ) CALL CHEMSEASALT + IF ( LSSALT ) + & CALL ERROR_STOP( ' need CHEMSEASALT_ADJ ', + & ' chemistry_adj_mod.f' ) + + !*** SULFATE AEROSOLS *** + IF ( LSULF .or. LCRYST ) THEN + + ! Do sulfate chemistry + !CALL CHEMSULFATE + CALL ERROR_STOP( ' need CHEMSULFATE_ADJ ', + & ' chemistry_adj_mod.f' ) + + ENDIF + + !*** CARBON AND 2NDARY ORGANIC AEROSOLS *** + ! (yhmao, dkh, 01/13/12, adj32_013) + IF ( LCARB ) CALL CHEMCARBON_ADJ + + !*** MINERAL DUST AEROSOLS *** + IF ( LDUST ) THEN + + ! Do dust aerosol chemsitry + ! Adjoint now supported (dkh, 01/13/12, adj32_011) + CALL CHEMDUST_ADJ + + ! Compute dust OD's & surface areas + !CALL RDUST_ONLINE( SOILDUST ) + ENDIF + + !--------------------------------- + ! Rn-Pb-Be + !--------------------------------- + ELSE IF ( ITS_A_RnPbBe_SIM() ) THEN + CALL ERROR_STOP('Simulation not supported: 2 ', + & 'chemistry_adj_mod.f') + + CALL CHEMRnPbBe + CALL DRYFLXRnPbBe + + !--------------------------------- + ! CH3I + !--------------------------------- + ELSE IF ( ITS_A_CH3I_SIM() ) THEN + CALL ERROR_STOP('Simulation not supported: 3 ', + & 'chemistry_adj_mod.f') + + CALL CHEMCH3I + + !--------------------------------- + ! HCN + !--------------------------------- + ELSE IF ( ITS_A_HCN_SIM() ) THEN + CALL ERROR_STOP('Simulation not supported: 4 ', + & 'chemistry_adj_mod.f') + CALL CHEM_HCN_CH3CN( N_TRACERS, STT ) + + !--------------------------------- + ! Tagged O3 + !--------------------------------- + ELSE IF ( ITS_A_TAGOX_SIM() ) THEN + + ! lzh 12/08/2009 add tagged ox adjoint + CALL CHEM_TAGGED_OX_ADJ + + !--------------------------------- + ! Tagged CO + !--------------------------------- + ELSE IF ( ITS_A_TAGCO_SIM() ) THEN + !mak debug + print*, 'its tag CO chemistry adj' + + CALL CHEM_TAGGED_CO_ADJ + + !--------------------------------- + ! C2H6 + !--------------------------------- + ELSE IF ( ITS_A_C2H6_SIM() ) THEN + CALL ERROR_STOP('Simulation not supported: 6 ', + & 'chemistry_adj_mod.f') + CALL CHEMC2H6 + + !--------------------------------- + ! CH4 now supported (adj32_023) + !--------------------------------- + ELSE IF ( ITS_A_CH4_SIM() ) THEN + + CALL CHEMCH4_ADJ + + !--------------------------------- + ! Mercury + !--------------------------------- + ELSE IF ( ITS_A_MERCURY_SIM() ) THEN + CALL ERROR_STOP('Simulation not supported: 8 ', + & 'chemistry_adj_mod.f') + + ! Do Hg chemistry + CALL CHEMMERCURY + + !--------------------------------- + ! Offline H2/HD + !--------------------------------- + ELSE IF ( ITS_A_H2HD_SIM() ) THEN + CALL ERROR_STOP('Simulation not supported: 9 ', + & 'chemistry_adj_mod.f') + CALL CHEM_H2_HD + CALL DRYFLXH2HD + +!----------------------------------------------------------------------------- +! Prior to 7/19/04: +! Fully install Kr85 run later (bmy, 7/19/04) +! !--------------------------------- +! ! Kr85 +! !--------------------------------- +! CASE ( 12 ) +! CALL CHEMKr85 +!----------------------------------------------------------------------------- + ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a CHEMISTRY_ADJ' ) + ENDIF + + ! Return to calling program + END SUBROUTINE DO_CHEMISTRY_ADJ + +!------------------------------------------------------------------------------ +! Use GCKPP_ADJ_DRIVER for solving chemistry in both directions (dkh, 07/31/09) +! mak, comment out for now, while testing tagged CO (mak, 6/20/09) +! SUBROUTINE GCKPP_DRIVER_ADJ( ) +! +!****************************************************************************** +! Driver routine to perform adjoint integration of the full KPP chemistry +! mechanism. Based on Daven Henze's GCKPP_DRIVER. (Kumaresh, 01/24/2008) +!****************************************************************************** +! + ! Reference to f90 modules +c$$$ USE COMODE_MOD, ONLY : JLOP, CSPEC, IXSAVE, CSPEC_FOR_KPP, +c$$$ & IYSAVE, IZSAVE, R_KPP, HSAVE_KPP, +c$$$ & CSPEC_ADJ, CSPEC_ADJ_FOR_KPP, +c$$$ & EMIS_RATE +c$$$ USE TRACER_MOD, ONLY : DDEP_ADJ, EMIS_ADJ, EMIS_I_ADJ +c$$$ USE TIME_MOD, ONLY : GET_TS_CHEM, GET_LOCALTIME +c$$$ USE GCKPP_UTIL, ONLY : Shuffle_kpp2user,INIT_KPP +c$$$ USE GCKPP_Initialize, ONLY : Initialize +c$$$ USE GCKPP_Rates, ONLY : UPDATE_RCONST +c$$$ USE GCKPP_Monitor, ONLY : SPC_NAMES +c$$$ USE ERROR_MOD, ONLY : ERROR_STOP +c$$$ USE LOGICAL_MOD, ONLY : LEMIS, LDRYD +c$$$ USE GCKPP_Global, ONLY : SMAL2, VAR, VAR_ADJ, V_CSPEC, +c$$$ & V_CSPEC_ADJ, VAR_R_ADJ, RCONST +c$$$ USE gckpp_Function +c$$$ USE gckpp_Model +c$$$ +c$$$ USE GCKPP_adj_Initialize, ONLY : Initialize_adj +c$$$ USE GCKPP_adj_Integrator_em, ONLY : INTEGRATE_em_adj, NIERR, +c$$$ & Nhnew, Nhexit +c$$$ USE GCKPP_adj_Integrator, ONLY : INTEGRATE_adj +c$$$ +c$$$ ! Local variables +c$$$ REAL*8 :: T, TIN, TOUT +c$$$ INTEGER :: ICNTRL(20) +c$$$ REAL(kind=dp) :: RCNTRL(20) +c$$$ INTEGER :: ISTATUS(20) +c$$$ INTEGER :: I, J, L, N, JJLOOP +c$$$ INTEGER :: IH, JH, LH +c$$$ INTEGER :: TID, OMP_GET_THREAD_NUM +c$$$ REAL(kind=dp) :: RSTATE(20) +c$$$ LOGICAL, SAVE :: FIRST = .TRUE. +c$$$ +c$$$ INTEGER, PARAMETER :: NADJ = NVAR +c$$$ REAL(kind=dp), DIMENSION(NVAR,NADJ) :: ATOL_adj, RTOL_adj +c$$$ +c$$$!~~~> Tests +c$$$ REAL(kind=dp) :: VAR0(NVAR), VAR1(NVAR), VAR2(NVAR),fd,ad +c$$$ +c$$$!~~~ > Output variables +c$$$ REAL(kind=dp) :: Vdot(NVAR) +c$$$ +c$$$ !================================================================= +c$$$ +c$$$ STEPMIN = 0.0d0 +c$$$ STEPMAX = 0.0d0 +c$$$ +c$$$ DO i=1,NVAR +c$$$ RTOL(i) = 1.0d-3 +c$$$ ATOL(i) = 1.0d-2 +c$$$ END DO +c$$$ +c$$$ DO j=1,NADJ +c$$$ DO i=1,NVAR +c$$$ RTOL_adj(i,j) = 0!1.0d-4 +c$$$ ATOL_adj(i,j) = 0!1.0d-10 +c$$$ END DO +c$$$ END DO +c$$$ +c$$$! ------------- +c$$$ CALL INIT_KPP +c$$$! ------------- +c$$$ +c$$$ ! Set parameters to default. See comments in RosenbrockADJ for +c$$$ ! a list of the defaults. +c$$$ ICNTRL(:) = 0 +c$$$ RCNTRL(:) = 0.d0 +c$$$ +c$$$ ! Change some parameters from the default to new values +c$$$ ICNTRL(1) = 1 ! Autonomous +c$$$ ICNTRL(2) = 0 ! Nonautonomous +c$$$ +c$$$ ! Select Integrator +c$$$ ! ICNTRL(3) -> selection of a particular Rosenbrock method +c$$$ ! = 0 : default method is Rodas3 +c$$$ ! = 1 : method is Ros2 +c$$$ ! = 2 : method is Ros3 +c$$$ ! = 3 : method is Ros4 +c$$$ ! = 4 : method is Rodas3 +c$$$ ! = 5: method is Rodas4 +c$$$ ICNTRL(3) = 4 +c$$$ +c$$$ ICNTRL(7) = 2 ! 1 = No adjoint, 2 = discrete adjoint +c$$$ +c$$$ IF(FIRST)THEN +c$$$ +c$$$ +c$$$ RSTATE(2) = 0d0 +c$$$ ! reset FIRST flag +c$$$ FIRST = .FALSE. +c$$$ +c$$$ ENDIF +c$$$ +c$$$ ! GET TS_CHEM and convert it to seconds. +c$$$ DT = GET_TS_CHEM() * 60d0 +c$$$ +c$$$ ! Set time parameters. +c$$$ T = 0d0 +c$$$ TIN = T +c$$$ TOUT = T + DT +c$$$ +c$$$ !================================================================= +c$$$ ! Solve Chemistry +c$$$ !================================================================= +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( JJLOOP, I, J, L, N, RSTATE, ISTATUS ) +c$$$!$OMP+FIRSTPRIVATE( RCNTRL, ICNTRL ) +c$$$!$OMP+COPYIN( TIME ) +c$$$!$OMP+SCHEDULE( DYNAMIC ) +c$$$ DO JJLOOP = 1,NTT +c$$$ +c$$$ JLOOP = JJLOOP +c$$$ ! Get 3D coords from SMVGEAR's 1D coords +c$$$ I = IXSAVE(JJLOOP) +c$$$ J = IYSAVE(JJLOOP) +c$$$ L = IZSAVE(JJLOOP) +c$$$ +c$$$ DO N =1, NVAR +c$$$ V_CSPEC(N) = CSPEC_FOR_KPP(JLOOP,N) +c$$$ !V_CSPEC_ADJ(N) = CSPEC_ADJ_FOR_KPP(JLOOP,N) +c$$$ V_CSPEC_ADJ(N) = CSPEC_ADJ_(JLOOP,N) +c$$$ END DO +c$$$ +c$$$ ! Pass tracer concentrations from CSPEC_FOR_KPP to KPP working vectors VAR, FIX. +c$$$ ! This also initializes the constant rate constants. +c$$$ CALL Initialize() +c$$$ +c$$$ CALL Initialize_adj() +c$$$ +c$$$ RCNTRL(3) = HSAVE_KPP(I,J,L) +c$$$ +c$$$ ! Recalculate rate constants +c$$$ CALL Update_RCONST() !*******************! +c$$$ +c$$$ !------switch--------- +c$$$ IF(LEMIS.or.LDRYD)THEN +c$$$ CALL INTEGRATE_EM_ADJ(1, VAR, VAR_ADJ, VAR_R_ADJ, TIN, TOUT, +c$$$ & ATOL_adj, RTOL_adj, ICNTRL, RCNTRL, ISTATUS, RSTATE) +c$$$ ELSE +c$$$ CALL INTEGRATE_ADJ(1, VAR, VAR_ADJ, TIN, TOUT,ATOL_adj, +c$$$ & RTOL_adj, ICNTRL, RCNTRL, ISTATUS, RSTATE) +c$$$ ENDIF +c$$$ !-------------------- +c$$$ +c$$$ IF ( ISTATUS(20) < 0 ) THEN !**************! +c$$$ rcntrl(3) = 0d0 +c$$$ CALL Initialize( ) ! v2.1 +c$$$ CALL Initialize_adj( ) +c$$$ CALL Update_RCONST() +c$$$ !------switch--------- +c$$$ IF(LEMIS.or.LDRYD)THEN +c$$$ CALL INTEGRATE_EM_ADJ(1, VAR, VAR_ADJ, VAR_R_ADJ, TIN, +c$$$ & TOUT, ATOL_adj, RTOL_adj, ICNTRL, RCNTRL, ISTATUS, +c$$$ & RSTATE) +c$$$ ELSE +c$$$ CALL INTEGRATE_ADJ(1, VAR, VAR_ADJ, TIN, TOUT,ATOL_adj, +c$$$ & RTOL_adj, ICNTRL, RCNTRL, ISTATUS, RSTATE) +c$$$ ENDIF +c$$$ !--------------------- +c$$$ IF ( ISTATUS(20) < 0 ) THEN +c$$$ print*, 'failed twice !!! ' +c$$$ CALL ERROR_STOP('IERR < 0 ', 'INTEGRATE_ADJ') +c$$$ ENDIF +c$$$ ENDIF +c$$$ +c$$$ ! Set negative values to SMAL2 +c$$$ DO N = 1, NVAR +c$$$ VAR(N) = MAX(VAR(N),SMAL2) +c$$$ ENDDO +c$$$ +c$$$ CALL Shuffle_kpp2user(VAR_ADJ,V_CSPEC_ADJ) +c$$$ CALL Shuffle_kpp2user(VAR,V_CSPEC) +c$$$ +c$$$ DO N =1, NVAR +c$$$ CSPEC(JLOOP,N) = V_CSPEC(N) +c$$$ CSPEC_ADJ(JLOOP,N) = V_CSPEC_ADJ(N) +c$$$ END DO +c$$$ +c$$$ !------switch--------- +c$$$ IF(LEMIS.or.LDRYD)THEN +c$$$ !================================== +c$$$ ! Scaled Emission Adjoints for NO, NO2, CO, ALK4 +c$$$ ! ISOP, ACET, PRPE, C3H8, C2H6, MEK, ALD2, CH2O +c$$$ !---------------------------------- +c$$$ DO N =1, 12 !232-243 emission variables +c$$$ EMIS_ADJ(I,J,L,N) = EMIS_ADJ(I,J,L,N) +c$$$ & + VAR_R_ADJ(N)*RCONST(N+231) +c$$$ END DO +c$$$ !---------------------------------- +c$$$ +c$$$ !================================== +c$$$ ! Drydeposition Rate Adjoints +c$$$ !---------------------------------- +c$$$ DO N =13, NCOEFF !244-253 drydep variables +c$$$ DDEP_ADJ(I,J,L,N) = DDEP_ADJ(I,J,L,N) +c$$$ & + VAR_R_ADJ(N)*RCONST(N+231) +c$$$ END DO +c$$$ !---------------------------------- +c$$$ +c$$$ !================================== +c$$$ ! Scaled Individual Source Emissions +c$$$ !---------------------------------- +c$$$ DO N =1, 3 !1-3 NOx (1-Anthro, 2-Soil, 3-Aircraft/Lightning) +c$$$ EMIS_I_ADJ(I,J,L,N) = EMIS_I_ADJ(I,J,L,N) +c$$$ & + VAR_R_ADJ(1)*EMIS_RATE(JLOOP,N) +c$$$ END DO +c$$$ DO N=4, 13 !4-13 Anthropogenic (except NOx) +c$$$ EMIS_I_ADJ(I,J,L,N) = EMIS_I_ADJ(I,J,L,N) +c$$$ & + VAR_R_ADJ(N-2)*EMIS_RATE(JLOOP,N) +c$$$ END DO +c$$$ DO N=14, 24 !14-24 Biomass Burning +c$$$ EMIS_I_ADJ(I,J,L,N) = EMIS_I_ADJ(I,J,L,N) +c$$$ & + VAR_R_ADJ(N-13)*EMIS_RATE(JLOOP,N) +c$$$ END DO +c$$$ DO N=25, 35 !25-35 Biofuel Burning +c$$$ EMIS_I_ADJ(I,J,L,N) = EMIS_I_ADJ(I,J,L,N) +c$$$ & + VAR_R_ADJ(N-24)*EMIS_RATE(JLOOP,N) +c$$$ END DO +c$$$ !---------------------------------- +c$$$ ENDIF +c$$$ +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +! +! ! Return to calling program +! END SUBROUTINE GCKPP_DRIVER_ADJ +!------------------------------------------------------------------------------ + ! End of module + END MODULE CHEMISTRY_ADJ_MOD diff --git a/code/adjoint/cleanup_adj.f b/code/adjoint/cleanup_adj.f new file mode 100644 index 0000000..f379853 --- /dev/null +++ b/code/adjoint/cleanup_adj.f @@ -0,0 +1,42 @@ +! $Id: cleanup_adj.f,v 1.3 2012/03/01 22:00:26 daven Exp $ + SUBROUTINE CLEANUP_ADJ +! +!****************************************************************************** +! Subroutine CLEANUP_ADJ deallocates the memory assigned to dynamic allocatable +! arrays in adjoint model routines (dkh, 06/12/09) +! +! NOTES: +! (1 ) Based on CLEANUP +! (2 ) Add support for CH4 (kjw, dkh, 02/12/12, adj32_023) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : CLEANUP_ADJ_ARRAYS + USE GLOBAL_CH4_ADJ_MOD, ONLY : CLEANUP_GLOBAL_CH4_ADJ + USE POPULATION_MOD, ONLY : CLEANUP_POPULATION_MOD + +#if defined(EANET_OBS) || defined(EMEP_OBS) || defined(NADP_OBS) + USE N_DEPOSITION_OBS_MOD, ONLY : CLEANUP_NDEP +#endif + + IMPLICIT NONE + + !================================================================= + ! CLEANUP_ADJ begins here! + !================================================================= + + ! Echo info + WRITE( 6, 100 ) + 100 FORMAT( ' - CLEANUP_ADJ: deallocating arrays now...' ) + + ! Call cleanup routines from individual F90 modules + CALL CLEANUP_ADJ_ARRAYS + CALL CLEANUP_GLOBAL_CH4_ADJ + CALL CLEANUP_POPULATION_MOD +#if defined(EANET_OBS) || defined(EMEP_OBS) || defined(NADP_OBS) + CALL CLEANUP_NDEP +#endif + + + ! Return to calling program + END SUBROUTINE CLEANUP_ADJ diff --git a/code/adjoint/co2_adj_mod.f b/code/adjoint/co2_adj_mod.f new file mode 100644 index 0000000..6b0c9a6 --- /dev/null +++ b/code/adjoint/co2_adj_mod.f @@ -0,0 +1,638 @@ +! $Id: co2_adj_mod.f,v 1.3 2012/03/01 22:00:26 daven Exp $ + MODULE CO2_ADJ_MOD +! +!****************************************************************************** +! Module CO2_ADJ_MOD contains variables and routines used for the CO2 +! adjoint simulation. (dkh, 04/25/10) +! +! Based on the forward module (pns, bmy, 8/16/05, 9/27/06) +! +! Module Variables: +! ============================================================================ +! +! Module Procedures: +! ============================================================================ +! (1 ) EMISSCO2_ADJ : Adjoint of emits CO2 into individual tracers +! +! GEOS-CHEM modules referenced by "co2_mod.f" +! ============================================================================ +! (1 ) biomass_mod.f : Module w/ routines for biomass burning +! (2 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (3 ) diag04_mod.f : Module w/ routines for CO2 diagnostics +! (4 ) directory_mod.f : Module w/ GEOS-CHEM data & met field dirs +! (5 ) error_mod.f : Module w/ I/O error and NaN check routines +! (6 ) file_mod.f : Module w/ file unit numbers and error checks +! (7 ) grid_mod.f : Module w/ horizontal grid information +! (8 ) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (9 ) time_mod.f : Module w/ routines for computing time & date +! (10) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc. +! (11) transfer_mod.f : Module w/ routines to cast & resize arrays +! (12) dao_mod.f : Module w/ routines for working with DAO met fields +! (13) regrid_1x1_mod.f : Modele w/ routines for regridding to and from 1x1 +! +! NOTES: +! (1 ) See forward model module for complete documentation +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "co2_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: EMISSCO2_ADJ + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!----------------------------------------------------------------------------- + + SUBROUTINE EMISSCO2_ADJ +! +!****************************************************************************** +! Subroutine EMISSCO2_ADJ is the adjoint routine for CO2 emissions. (dkh, 04/25/10) +! +! Based on forward model code. (pns, bmy, 8/16/05, 9/27/06) +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE BIOMASS_MOD, ONLY : BIOMASS, IDBCO2 + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TIME_MOD, ONLY : GET_DAY, GET_DAY_OF_YEAR + USE TIME_MOD, ONLY : GET_HOUR, GET_MONTH + USE TIME_MOD, ONLY : GET_YEAR, GET_TS_CHEM, GET_TS_EMIS + USE TIME_MOD, ONLY : ITS_A_NEW_DAY, ITS_A_NEW_MONTH + USE TRACER_MOD, ONLY : N_TRACERS, STT + + USE LOGICAL_MOD, ONLY : LGENFF, LANNFF, LMONFF, LSTREETS + USE LOGICAL_MOD, ONLY : LSEASBB, LGFED2BB, L8DAYBB, LBIOFUEL + USE LOGICAL_MOD, ONLY : LBIODAILY, LBIODIURNAL + USE LOGICAL_MOD, ONLY : LBIONETORIG, LBIONETCLIM + USE LOGICAL_MOD, ONLY : LOCN1997, LOCN2009ANN, LOCN2009MON + USE LOGICAL_MOD, ONLY : LSHIPEDG, LSHIPICO, LPLANE + USE LOGICAL_MOD, ONLY : LBIOSPHTAG, LFOSSILTAG, LFFBKGRD + USE LOGICAL_MOD, ONLY : LSHIPTAG, LPLANETAG + USE LOGICAL_MOD, ONLY : LSHIPSCALE, LPLANESCALE + USE LOGICAL_MOD, ONLY : LCHEMCO2 + + ! adj_group + USE CO2_MOD, ONLY : READ_BBIO_DIURNALCYCLE + USE CO2_MOD, ONLY : READ_BBIO_DAILYAVERAGE + USE CO2_MOD, ONLY : READ_FOSSILCO2 + USE CO2_MOD, ONLY : READ_OCEANCO2 + USE CO2_MOD, ONLY : READ_SHIPCO2_EDGAR + USE CO2_MOD, ONLY : READ_SHIPCO2_ICOADS + USE CO2_MOD, ONLY : READ_AVIATION_CO2 + USE CO2_MOD, ONLY : READ_CHEMCO2 + USE CO2_MOD, ONLY : CHEM_SURF + USE CO2_MOD, ONLY : CHEMCO2 + USE CO2_MOD, ONLY : EMFOSSCO2 + USE CO2_MOD, ONLY : EMOCCO2 + USE CO2_MOD, ONLY : EMBIOCO2 + USE CO2_MOD, ONLY : EMBIOFUELCO2 + USE CO2_MOD, ONLY : EMBIONETCO2 + USE CO2_MOD, ONLY : EMSHIPCO2 + USE CO2_MOD, ONLY : EMPLANECO2 + USE CO2_MOD, ONLY : EMIS_SUB + USE CO2_MOD, ONLY : XNUMOL_CO2 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ECO2ff, IDADJ_ECO2ocn + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ECO2bal, IDADJ_ECO2bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ECO2bf, IDADJ_ECO2nte + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ECO2shp, IDADJ_ECO2pln + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ECO2che, IDADJ_ECO2sur + USE ADJ_ARRAYS_MOD, ONLY : GET_SCALE_GROUP + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE LOGICAL_ADJ_MOD, ONLY : LADJ + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE TIME_MOD, ONLY : ITS_A_NEW_DAY_ADJ + USE TIME_MOD, ONLY : GET_NHMSe + + ! dkh debug + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + LOGICAL, SAVE :: FIRST = .TRUE. + + ! Local variables + INTEGER :: I, IJLOOP, J, L, N, NN + INTEGER :: M + INTEGER :: DAY, DOY, HOUR, MONTH, YEAR + REAL*8 :: A_CM2, DTSRCE, E_CO2 + REAL*8 :: E_CO2_ADJ + REAL*8 :: biomass_sum, bionet_sum + REAL*8, SAVE :: CHEMSRC(IIPAR,JJPAR,LLPAR) ! dbj + + ! External functions + REAL*8, EXTERNAL :: BOXVL ! dbj + + !================================================================= + ! EMISSCO2_ADJ begins here! + !================================================================= + IF ( FIRST ) THEN + CHEMSRC = CHEMCO2 + FIRST = .FALSE. + ENDIF + + !================================================================= + ! Read in monthly, daily or variable emissions fields + !================================================================= + + ! Emission timestep +! DTSRCE = 60d0 * GET_TS_CHEM() !Line from the orginal code + DTSRCE = 60d0 * GET_TS_EMIS() + + ! Time variables + DAY = GET_DAY() + DOY = GET_DAY_OF_YEAR() + HOUR = GET_HOUR() + MONTH = GET_MONTH() + YEAR = GET_YEAR() + + M = GET_SCALE_GROUP() + + ! adjust HOUR for adjoint + IF ( MOD(GET_NHMSe(),3) == 0 ) THEN + HOUR = HOUR - 2 + IF ( HOUR < 0 ) HOUR = HOUR + 24 + ELSEIF ( MOD(GET_NHMSe(),2) == 0 ) THEN + HOUR = HOUR - 1 + IF ( HOUR < 0 ) HOUR = HOUR + 24 + ELSEIF ( MOD(GET_NHMSe(),1) == 0 ) THEN + HOUR = HOUR + IF ( HOUR < 0 ) HOUR = HOUR + 24 + ENDIF + +!-------------------------------------------------------------------------------------- +! ! Read monthly-mean biomass burning emissions +! IF ( LBIOBRNCO2 .and. ITS_A_NEW_MONTH() ) THEN +! CALL READ_MONTH_BIOBRN_CO2( MONTH, YEAR ) +! ENDIF +! This requires a subroutine called READ_MONTH_BIOBRN_CO2 +! GFEDv2 biomass burning emissions are a better choice !Ray Nassar +! +!-------------------------------------------------------------------------------------- +! At present, biomass burning emissions are dealt with in the following way: +! +! 1) main.f calls do_emissions in emissions.f +! 2) do_emissions calls compute_biomass_emissions in biomass_mod.f +! 3a) compute_biomass_emissions calls gfed2_compute_biomass in gfed2_biomass_mod.f +! ** OR ** +! 3b) compute_biomass_emissions calls gc_read_biomass_co2 in gc_biomass_mod.f +!-------------------------------------------------------------------------------------- + +! ! Check if Balanced Biosphere emissions are required +! IF ( LBIOCO2 ) THEN +! ! If LUSECASANEP is TRUE ... +! IF ( LUSECASANEP ) THEN + + IF ( LBIODIURNAL ) THEN + + write(*,*) '*** USING DIURNAL CASA NEP ***' + + ! ... then use 3-hourly NEP emissions for Bal Bio ... + IF ( MOD( HOUR, 3 ) == 0 ) THEN + CALL READ_BBIO_DIURNALCYCLE( MONTH, DAY, HOUR, DOY ) + ENDIF + + ! dkh debug + !print*, 'CO2dbg adj HOUR ', HOUR, MOD( HOUR, 3 ) + + ELSEIF ( LBIODAILY ) THEN + + ! ... otherwise use constant daily emissions of NEP for Bal Bio + IF ( ITS_A_NEW_DAY_ADJ() ) THEN + CALL READ_BBIO_DAILYAVERAGE( MONTH, DAY, DOY ) + ENDIF + + ENDIF + +!----------------------------------------------------------------------- +! Fluxes with "possible" monthly variability are called below +! In some cases the annual file is just called at the start of the month +!----------------------------------------------------------------------- + + IF (ITS_A_NEW_MONTH() ) THEN + + ! Fossil fuel emissions + IF (LMONFF .OR. LANNFF .OR. LGENFF) CALL READ_FOSSILCO2 + + ! Oceanic exchange + IF (LOCN1997 .OR. LOCN2009ANN .OR. LOCN2009MON) THEN + CALL READ_OCEANCO2 + ENDIF + + ! Ship emissions from EDGAR + IF (LSHIPEDG) CALL READ_SHIPCO2_EDGAR + + ! Ship emissions from ICOADS + IF (LSHIPICO) CALL READ_SHIPCO2_ICOADS + + ! Aircraft CO2 emissions + IF (LPLANE) CALL READ_AVIATION_CO2 + + ! Get chemical source ! dbj + IF (LCHEMCO2) THEN + CALL READ_CHEMCO2 + CALL CHEM_SURF + CHEMSRC = CHEMCO2 + ENDIF + ENDIF + + !================================================================= + ! Process emissions and save diagnostics + !================================================================= + + ! Loop over latitudes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, A_CM2, E_CO2 ) ! dbj +!$OMP+PRIVATE( E_CO2_ADJ ) + DO J = 1, JJPAR + + ! Grid box surface area [cm2] + A_CM2 = GET_AREA_CM2( J ) + + ! Loop over longitudes + DO I = 1, IIPAR + + !------------------------------------------- + ! #1: Total CO2 + ! #2: CO2 from fossil fuel emissions + !------------------------------------------- + IF ( LGENFF .OR. LANNFF .OR. LMONFF) THEN + + ! fwd code: + !STT(I,J,1,1) = STT(I,J,1,1) + E_CO2 + ! adj code: + E_CO2_ADJ = STT_ADJ(I,J,1,1) + + ! fwd code: + !E_CO2 = E_CO2 * A_CM2 * DTSRCE / XNUMOL_CO2 + ! adj code: + E_CO2_ADJ = E_CO2_ADJ * A_CM2 * DTSRCE / XNUMOL_CO2 + + ! Fossil fuel emissions of CO2 [molec/cm2/s] + E_CO2 = EMFOSSCO2(I,J) + + ! adj_group: apply scaling factors (dkh, 04/25/10) + IF ( IDADJ_ECO2ff > 0 ) THEN + ! fwd code: + !E_CO2 = E_CO2 * EMS_SF(I,J,M,IDADJ_ECO2ff) + ! adj code: + EMS_SF_ADJ(I,J,M,IDADJ_ECO2ff) = + & EMS_SF_ADJ(I,J,M,IDADJ_ECO2ff) + E_CO2_ADJ * E_CO2 + ENDIF + + ENDIF + + !------------------------------------------- + ! #3: CO2 from ocean exchange + !------------------------------------------- + IF (LOCN1997 .OR. LOCN2009ANN .OR. LOCN2009MON) THEN + + ! fwd code: + !STT(I,J,1,1) = STT(I,J,1,1) + E_CO2 + ! adj code: + E_CO2_ADJ = STT_ADJ(I,J,1,1) + + ! fwd code: + !E_CO2 = E_CO2 * A_CM2 * DTSRCE / XNUMOL_CO2 + ! adj code: + E_CO2_ADJ = E_CO2_ADJ * A_CM2 * DTSRCE / XNUMOL_CO2 + + ! Ocean CO2 emissions in [molec/cm2/s] + E_CO2 = EMOCCO2(I,J) + + ! dkh debug + IF ( I == IFD .and. J == JFD ) THEN + print*, ' ECO2onc adj = ', E_CO2 + print*, ' E_CO2_ADJ = ', E_CO2_ADJ + print*, ' STT_ADJ(CO2)= ', STT_ADJ(I,J,1,1) + ENDIF + + ! adj_group: apply scaling factors (dkh, 04/25/10) + IF ( IDADJ_ECO2ocn > 0 ) THEN + ! fwd code: + !E_CO2 = E_CO2 * EMS_SF(I,J,M,IDADJ_ECO2ocn) + ! adj code: + EMS_SF_ADJ(I,J,M,IDADJ_ECO2ocn) = + & EMS_SF_ADJ(I,J,M,IDADJ_ECO2ocn) + E_CO2_ADJ * E_CO2 + ENDIF + + ENDIF + + !------------------------------------------- + ! #4: CO2 from balanced biosphere emissions + !------------------------------------------- + IF ( LBIODAILY .OR. LBIODIURNAL ) THEN + + ! fwd code: + !STT(I,J,1,1) = STT(I,J,1,1) + E_CO2 + ! adj code: + E_CO2_ADJ = STT_ADJ(I,J,1,1) + + ! fwd code: + !E_CO2 = E_CO2 * A_CM2 * DTSRCE / XNUMOL_CO2 + ! adj code: + E_CO2_ADJ = E_CO2_ADJ * A_CM2 * DTSRCE / XNUMOL_CO2 + + ! Balanced biosphere CO2 [molec/cm2/s] + E_CO2 = EMBIOCO2(I,J) + + ! adj_group: apply scaling factors (dkh, 04/25/10) + IF ( IDADJ_ECO2bal > 0 ) THEN + ! fwd code: + !E_CO2 = E_CO2 * EMS_SF(I,J,M,IDADJ_ECO2bal) + ! adj code: + EMS_SF_ADJ(I,J,M,IDADJ_ECO2bal) = + & EMS_SF_ADJ(I,J,M,IDADJ_ECO2bal) + E_CO2_ADJ * E_CO2 + ENDIF + + ENDIF + + !------------------------------------------- + ! #5: CO2 from biomass burning emissions + !------------------------------------------- + IF ( LSEASBB .OR. LGFED2BB .OR. L8DAYBB ) THEN + + ! fwd code: + !STT(I,J,1,1) = STT(I,J,1,1) + E_CO2 + ! adj code: + E_CO2_ADJ = STT_ADJ(I,J,1,1) + + ! fwd code: + !E_CO2 = E_CO2 * A_CM2 * DTSRCE / XNUMOL_CO2 + ! adj code: + E_CO2_ADJ = E_CO2_ADJ * A_CM2 * DTSRCE / XNUMOL_CO2 + + ! Biomass burning emissions [molec/cm2/s] + E_CO2 = BIOMASS(I,J,IDBCO2) + !E_CO2 = EMBIOBRNCO2(I,J) !This was from older versions, see note above + + ! adj_group: apply scaling factors (dkh, 04/25/10) + IF ( IDADJ_ECO2bb > 0 ) THEN + ! fwd code: + !E_CO2 = E_CO2 * EMS_SF(I,J,M,IDADJ_ECO2bb) + ! adj code: + EMS_SF_ADJ(I,J,M,IDADJ_ECO2bb) = + & EMS_SF_ADJ(I,J,M,IDADJ_ECO2bb) + E_CO2_ADJ * E_CO2 + ENDIF + + ENDIF + + !------------------------------------------- + ! #6: CO2 from biofuel emissions + !------------------------------------------- + IF ( LBIOFUEL ) THEN + + ! fwd code: + !STT(I,J,1,1) = STT(I,J,1,1) + E_CO2 + ! adj code: + E_CO2_ADJ = STT_ADJ(I,J,1,1) + + ! fwd code: + !E_CO2 = E_CO2 * A_CM2 * DTSRCE / XNUMOL_CO2 + ! adj code: + E_CO2_ADJ = E_CO2_ADJ * A_CM2 * DTSRCE / XNUMOL_CO2 + + ! Biofuel CO2 emissions [molec/cm2/s] + E_CO2 = EMBIOFUELCO2(I,J) + + ! adj_group: apply scaling factors (dkh, 04/25/10) + IF ( IDADJ_ECO2bf > 0 ) THEN + ! fwd code: + !E_CO2 = E_CO2 * EMS_SF(I,J,M,IDADJ_ECO2bf) + ! adj code: + EMS_SF_ADJ(I,J,M,IDADJ_ECO2bf) = + & EMS_SF_ADJ(I,J,M,IDADJ_ECO2bf) + E_CO2_ADJ * E_CO2 + ENDIF + + ENDIF + + !------------------------------------------- + ! #7: CO2 from net terrestrial exchange + !------------------------------------------- + IF ( LBIONETORIG .OR. LBIONETCLIM ) THEN + + ! fwd code: + !STT(I,J,1,1) = STT(I,J,1,1) + E_CO2 + ! adj code: + E_CO2_ADJ = STT_ADJ(I,J,1,1) + + ! fwd code: + !E_CO2 = E_CO2 * A_CM2 * DTSRCE / XNUMOL_CO2 + ! adj code: + E_CO2_ADJ = E_CO2_ADJ * A_CM2 * DTSRCE / XNUMOL_CO2 + + ! CO2 from net terrestrial exchange [molec/cm2/s] + E_CO2 = EMBIONETCO2(I,J) + + ! adj_group: apply scaling factors (dkh, 04/25/10) + IF ( LADJ .and. IDADJ_ECO2nte > 0 ) THEN + ! fwd code: + !E_CO2 = E_CO2 * EMS_SF(I,J,M,IDADJ_ECO2nte) + ! adj code: + EMS_SF_ADJ(I,J,M,IDADJ_ECO2nte) = + & EMS_SF_ADJ(I,J,M,IDADJ_ECO2nte) + E_CO2_ADJ * E_CO2 + ENDIF + + ENDIF + + !------------------------------------------- + ! #8: CO2 from ship emissions + !------------------------------------------- + IF ( LSHIPEDG .OR. LSHIPICO ) THEN + + ! fwd code: + !STT(I,J,1,1) = STT(I,J,1,1) + E_CO2 + ! adj code: + E_CO2_ADJ = STT_ADJ(I,J,1,1) + + ! fwd code: + !E_CO2 = E_CO2 * A_CM2 * DTSRCE / XNUMOL_CO2 + ! adj code: + E_CO2_ADJ = E_CO2_ADJ * A_CM2 * DTSRCE / XNUMOL_CO2 + + ! Ship CO2 emissions [molec/cm2/s] + E_CO2 = EMSHIPCO2(I,J) + + ! adj_group: apply scaling factors (dkh, 04/25/10) + IF ( LADJ .and. IDADJ_ECO2shp > 0 ) THEN + ! fwd code: + !E_CO2 = E_CO2 * EMS_SF(I,J,M,IDADJ_ECO2shp) + ! adj code: + EMS_SF_ADJ(I,J,M,IDADJ_ECO2shp) = + & EMS_SF_ADJ(I,J,M,IDADJ_ECO2shp) + E_CO2_ADJ * E_CO2 + ENDIF + + ENDIF + + !------------------------------------------- + ! #9: CO2 from aircraft emissions + !------------------------------------------- + IF ( LPLANE ) THEN + DO L = 1, LLPAR + + ! fwd code: + !STT(I,J,L,1) = STT(I,J,L,1) + E_CO2 + ! adj code: + E_CO2_ADJ = STT_ADJ(I,J,L,1) + + !-------------------------------------------------------- + ! BUG FIX: unit conversion (dkh, 02/08/12, adj32_018) + ! OLD CODE: + !! fwd code: + !!E_CO2 = E_CO2 * A_CM2 * DTSRCE / XNUMOL_CO2 + !! adj code: + !!E_CO2_ADJ = E_CO2_ADJ * A_CM2 * DTSRCE / XNUMOL_CO2 + ! NEW CODE: + ! fwd code: + !E_CO2 = E_CO2 * BOXVL(I,J,L) * DTSRCE / XNUMOL_CO2 + ! adj code: + E_CO2_ADJ = E_CO2_ADJ * BOXVL(I,J,L) + & * DTSRCE / XNUMOL_CO2 + !-------------------------------------------------------- + + + + ! Aircraft CO2 emissions (3-D) [molec/cm3/s] + E_CO2 = EMPLANECO2(I,J,L) + + ! adj_group: apply scaling factors (dkh, 04/25/10) + IF ( IDADJ_ECO2pln > 0 ) THEN + ! fwd code: + !E_CO2 = E_CO2 * EMS_SF(I,J,M,IDADJ_ECO2pln) + ! adj code: + EMS_SF_ADJ(I,J,M,IDADJ_ECO2pln) = + & EMS_SF_ADJ(I,J,M,IDADJ_ECO2pln) + E_CO2_ADJ * E_CO2 + ENDIF + + ENDDO + ENDIF + + !------------------------------------------- + ! #10 CO2 production from CO oxidation + !------------------------------------------- + IF ( LCHEMCO2 ) THEN + DO L = 1, LLPAR + + ! fwd code: + !STT(I,J,L,1) = STT(I,J,L,1) + E_CO2 + ! adj code: + E_CO2_ADJ = STT_ADJ(I,J,L,1) + + !-------------------------------------------------------- + ! BUG FIX: unit conversion (dkh, 02/08/12, adj32_018) + ! OLD CODE: + !! fwd code: + !!E_CO2 = E_CO2 * A_CM2 * DTSRCE / XNUMOL_CO2 + !! adj code: + !E_CO2_ADJ = E_CO2_ADJ * A_CM2 * DTSRCE / XNUMOL_CO2 + ! NEW CODE: + ! fwd code: + !E_CO2 = E_CO2 * BOXVL(I,J,L) * DTSRCE / XNUMOL_CO2 + ! adj code: + E_CO2_ADJ = E_CO2_ADJ * BOXVL(I,J,L) + & * DTSRCE / XNUMOL_CO2 + !-------------------------------------------------------- + + + E_CO2 = CHEMSRC(I,J,L) + + ! adj_group: apply scaling factors (dkh, 04/25/10) + IF ( LADJ .and. IDADJ_ECO2che > 0 ) THEN + ! fwd code: + !E_CO2 = E_CO2 * EMS_SF(I,J,M,IDADJ_ECO2che) + ! adj code: + EMS_SF_ADJ(I,J,M,IDADJ_ECO2che) = + & EMS_SF_ADJ(I,J,M,IDADJ_ECO2che) + E_CO2_ADJ * E_CO2 + ENDIF + ENDDO + ENDIF + + !------------------------------------------- + ! #11 CO2 surface correction for CO oxidation + !------------------------------------------- + IF ( LCHEMCO2 ) THEN + + ! fwd code: + !STT(I,J,1,1) = STT(I,J,1,1) - E_CO2 + ! adj code: + !E_CO2_ADJ = STT_ADJ(I,J,1,1) + E_CO2_ADJ = - STT_ADJ(I,J,1,1) + + ! fwd code: + !E_CO2 = E_CO2 * A_CM2 * DTSRCE / XNUMOL_CO2 + ! adj code: + E_CO2_ADJ = E_CO2_ADJ * A_CM2 * DTSRCE / XNUMOL_CO2 + + E_CO2 = EMIS_SUB(I,J) ! EMIS_SUB is positive, but is subtracted + + ! adj_group: apply scaling factors (dkh, 04/25/10) + IF ( IDADJ_ECO2sur > 0 ) THEN + ! fwd code: + !E_CO2 = E_CO2 * EMS_SF(I,J,M,IDADJ_ECO2sur) + ! adj code: + EMS_SF_ADJ(I,J,M,IDADJ_ECO2sur) = + & EMS_SF_ADJ(I,J,M,IDADJ_ECO2sur) + E_CO2_ADJ * E_CO2 + ENDIF + + + ENDIF + + ! dkh debug + IF ( I == IFD .and. J == JFD .and. LPRINTFD ) THEN + print*, 'CO2dbg adj E_CO2 ff ', EMFOSSCO2(I,J) + print*, 'CO2dbg adj E_CO2 ocn', EMOCCO2(I,J) + print*, 'CO2dbg adj E_CO2 bal', EMBIOCO2(I,J) + print*, 'CO2dbg adj E_CO2 bb ', BIOMASS(I,J,IDBCO2) + print*, 'CO2dbg adj E_CO2 bf ', EMBIOFUELCO2(I,J) + print*, 'CO2dbg adj E_CO2 nte', EMBIONETCO2(I,J) + print*, 'CO2dbg adj E_CO2 shp', EMSHIPCO2(I,J) + print*, 'CO2dbg adj E_CO2 pln', EMPLANECO2(I,J,LFD) + print*, 'CO2dbg adj E_CO2 che', CHEMSRC(I,J,LFD) + print*, 'CO2dbg adj E_CO2 sur', EMIS_SUB(I,J) + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! dkh debug + print*, 'CO2dbg adj E_CO2 ff ', SUM(EMFOSSCO2(:,:)) + print*, 'CO2dbg adj E_CO2 ocn', SUM(EMOCCO2(:,:)) + print*, 'CO2dbg adj E_CO2 bal', SUM(EMBIOCO2(:,:)) + print*, 'CO2dbg adj E_CO2 bb ', SUM(BIOMASS(:,:,IDBCO2)) + print*, 'CO2dbg adj E_CO2 bf ', SUM(EMBIOFUELCO2(:,:)) + print*, 'CO2dbg adj E_CO2 nte', SUM(EMBIONETCO2(:,:)) + print*, 'CO2dbg adj E_CO2 shp', SUM(EMSHIPCO2(:,:)) + print*, 'CO2dbg adj E_CO2 pln', SUM(EMPLANECO2(:,:,:)) + print*, 'CO2dbg adj E_CO2 che', SUM(CHEMSRC(:,:,:)) + print*, 'CO2dbg adj E_CO2 sur', SUM(EMIS_SUB(:,:)) + + + ! Return to calling program + END SUBROUTINE EMISSCO2_ADJ + +!----------------------------------------------------------------------------- + + + ! End of module + END MODULE CO2_ADJ_MOD diff --git a/code/adjoint/convection_adj_mod.f b/code/adjoint/convection_adj_mod.f new file mode 100644 index 0000000..6687d82 --- /dev/null +++ b/code/adjoint/convection_adj_mod.f @@ -0,0 +1,994 @@ +! $Id: convection_adj_mod.f,v 1.5 2010/04/25 17:18:58 daven Exp $ + MODULE CONVECTION_ADJ_MOD +! +!****************************************************************************** +! Module CONVECTION_MOD contains routines which select the proper convection +! code for GEOS-3, GEOS-4, GEOS-5, or GCAP met field data sets. +! (bmy, 6/28/03, 1/31/08) +! +! Module Routines: +! ============================================================================ +! (1 ) DO_CONVECTION : Wrapper routine, chooses correct convection code +! (2 ) DO_GEOS4_CONVECT : Calls GEOS-4 convection routines +! (3 ) DO_GCAP_CONVECT : Calls GCAP convection routines +! (4 ) NFCLDMX : Convection routine for GEOS-3 and GEOS-5 met +! +! GEOS-CHEM modules referenced by convection_mod.f +! ============================================================================ +! (1 ) dao_mod.f : Module w/ containing arrays for DAO met fields +! (2 ) diag_mod.f : Module w/ GEOS-Chem diagnostic arrays +! (3 ) fvdas_convect_mod.f : Module w/ convection code for fvDAS met fields +! (4 ) grid_mod.f : Module w/ horizontal grid information +! (5 ) logical_mod.f : Module w/ GEOS-Chem logical switches +! (6 ) ocean_mercury_mod.f : Module w/ routines for Hg(0) ocean flux +! (7 ) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (8 ) time_mod.f : Module w/ routines for computing time +! (9 ) tracer_mod.f : Module w/ GEOS-Chem tracer array STT etc +! (10) tracerid_mod.f : Module w/ GEOS-Chem tracer ID flags etc +! (11) wetscav_mod.f : Module w/ routines for wetdep/scavenging +! +! NOTES: +! (1 ) Contains new updates for GEOS-4/fvDAS convection. Also now references +! "error_mod.f". Now make F in routine NFCLDMX a 4-D array to avoid +! memory problems on the Altix. (bmy, 1/27/04) +! (2 ) Bug fix: Now pass NTRACE elements of TCVV to FVDAS_CONVECT in routine +! DO_CONVECTION (bmy, 2/23/04) +! (3 ) Now references "logical_mod.f" and "tracer_mod.f" (bmy, 7/20/04) +! (4 ) Now also references "ocean_mercury_mod.f" and "tracerid_mod.f" +! (sas, bmy, 1/19/05) +! (5 ) Now added routines DO_GEOS4_CONVECT and DO_GCAP_CONVECT by breaking +! off code from DO_CONVECTION, in order to implement GCAP convection +! in a much cleaner way. (swu, bmy, 5/25/05) +! (6 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (7 ) Shut off scavenging in shallow convection for GCAP (swu, bmy, 11/1/05) +! (8 ) Modified for tagged Hg simulation (cdh, bmy, 1/6/06) +! (9 ) Bug fix: now only call ADD_Hg2_WD if LDYNOCEAN=T (phs, 2/8/07) +! (10) Fix for GEOS-5 met fields in routine NFCLDMX (swu, 8/15/07) +! (11) Resize DTCSUM array in NFCLDMX to save memory (bmy, 1/31/08) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "convection_mod.f" + !================================================================= + +# include "define_adj.h" ! Obs operators (fp) + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: DO_CONVECTION_ADJ + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_CONVECTION_ADJ +! +!****************************************************************************** +! Subroutine DO_CONVECTION_ADJ calls the adjoint of the appropriate +! convection driver program for different met field data sets. +! Based on forward code (swu, bmy, 5/25/05, 2/8/07). (ks,mak,dkh, 08/25/09) +! +! NOTES: +! (1 ) Updated for GCv8 adjoint (dkh, 08/25/09) +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE DAO_MOD, ONLY : CLDMAS, CMFMC, DTRAIN + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE TRACER_MOD, ONLY : N_TRACERS, TCVV, STT + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE WETSCAV_MOD, ONLY : H2O2s, SO2s + USE WETSCAV_MOD, ONLY : RESTORE_CONV + + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, N + + +#if defined( GCAP ) + + !------------------------- + ! GCAP met fields + !------------------------- + + ! Call GEOS-4 driver routine + !CALL DO_GCAP_CONVECT + CALL ERROR_STOP( 'GCAP not supported for adjoint', + & 'convection_adj_mod.f' ) + +#elif defined( GEOS_4 ) + + !------------------------- + ! GEOS-4 met fields + !------------------------- + + ! Call GEOS-4 driver routine + CALL DO_GEOS4_CONVECT_ADJ + +#elif defined( GEOS_5 ) || defined( GEOS_FP ) + + !------------------------- + ! GEOS-5 met fields + !------------------------- + + ! Restore checkpted values of H2O2s and SO2s (dkh, 11/22/05) + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + CALL RESTORE_CONV + + IF ( LPRINTFD ) THEN + WRITE(6,*) ' H2O2s before conv adj = ', H2O2s(IFD,JFD,LFD) + WRITE(6,*) ' SO2s before conv adj = ', SO2s(IFD,JFD,LFD) + ENDIF + + ENDIF + + ! Call the S-J Lin convection routine for GEOS-1, GEOS-S, GEOS-3 + CALL NFCLDMX_ADJ( N_TRACERS, TCVV, CMFMC(:,:,2:LLPAR+1), DTRAIN, + & STT _ADJ) + +#elif defined( GEOS_3 ) + + ! Restore checkpted values of H2O2s and SO2s (dkh, 11/22/05) + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + CALL RESTORE_CONV + + IF ( LPRINTFD ) THEN + WRITE(6,*) ' H2O2s before convection = ', H2O2s(IFD,JFD,LFD) + WRITE(6,*) ' SO2s before convection = ', SO2s(IFD,JFD,LFD) + ENDIF + + ENDIF + + !------------------------- + ! GEOS-3 met fields + !------------------------- + + ! Call the S-J Lin convection routine for GEOS-1, GEOS-S, GEOS-3 + CALL NFCLDMX_ADJ( N_TRACERS, TCVV, CLDMAS, DTRAIN, STT_ADJ ) + +#endif + + ! Return to calling program + END SUBROUTINE DO_CONVECTION_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_GEOS4_CONVECT_ADJ +! +!****************************************************************************** +! Subroutine DO_GEOS4_CONVECT_ADJ is the adjooint of the GEOS4 convection. +! Based on DO_GEOS4_CONVECT (swu, bmy, 5/25/05, 10/3/05) with adjoint +! updated to GCv8 (ks, mak, dkh, 08/25/09) +! +! NOTES: +! (1 ) Updated to GCv8 +! +!***************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE CHECKPT_MOD, ONLY : CHK_STT_CON + USE DAO_MOD, ONLY : HKETA, HKBETA, ZMEU, ZMMU, ZMMD + USE DIAG_MOD, ONLY : AD37 + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FVDAS_CONVECT_ADJ_MOD, ONLY : FVDAS_CONVECT_ADJ + USE LOGICAL_MOD, ONLY : LPRT + USE PRESSURE_MOD, ONLY : GET_PEDGE + USE TIME_MOD, ONLY : GET_TS_CONV + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : N_TRACERS, TCVV + USE WETSCAV_MOD, ONLY : COMPUTE_F + USE WETSCAV_MOD, ONLY : RESTORE_CONV + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND37, LD37 + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, ISOL, J, L, L2, N, NSTEP + INTEGER :: INDEXSOL(N_TRACERS) + INTEGER :: CONVDT + REAL*8 :: F(IIPAR,JJPAR,LLPAR,N_TRACERS) + REAL*8 :: RPDEL(IIPAR,JJPAR,LLPAR) + REAL*8 :: DP(IIPAR,JJPAR,LLPAR) + REAL*8 :: P1, P2, TDT + + !================================================================= + ! DO_GEOS4_CONVECT_ADJ begins here! + !================================================================= + + ! Convection timestep [s] + CONVDT = GET_TS_CONV() * 60d0 + + ! NSTEP is the # of internal convection timesteps. According to + ! notes in the old convection code, 300s works well. (swu, 12/12/03) + NSTEP = CONVDT / 300 + NSTEP = MAX( NSTEP, 1 ) + + ! TIMESTEP*2; will be divided by 2 before passing to CONVTRAN + TDT = DBLE( CONVDT ) * 2.0D0 / DBLE( NSTEP ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### DO_G4_CONV_ADJ: a INIT_FV' ) + + !================================================================= + ! Before calling convection, compute the fraction of insoluble + ! tracer (Finsoluble) lost in updrafts. Finsoluble = 1-Fsoluble. + !================================================================= + ! Need this too for full chemistry. (dkh, 10/01/08) + IF ( ITS_A_FULLCHEM_SIM() ) THEN + CALL RESTORE_CONV + ENDIF + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, ISOL ) +!$OMP+SCHEDULE( DYNAMIC ) + DO N = 1, N_TRACERS + + ! Get fraction of tracer scavenged and the soluble tracer + ! index (ISOL). For non-soluble tracers, F=0 and ISOL=0. + CALL COMPUTE_F( N, F(:,:,:,N), ISOL ) + + ! Store ISOL in an array for later use + INDEXSOL(N) = ISOL + + ! Loop over grid boxes + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ! GEOS-4 convection routines need the insoluble fraction + F(I,J,L,N) = 1d0 - F(I,J,L,N) + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### DO_G4_CONV_ADJ: a COMPUTE_F' ) + + !================================================================= + ! Compute pressure thickness arrays DP and RPDEL + ! These arrays are indexed from atm top --> surface + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, L2, P1, P2 ) + DO L = 1, LLPAR + + ! L2 runs from the atm top down to the surface + L2 = LLPAR - L + 1 + + ! Loop over surface grid boxes + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Pressure at bottom and top edges of grid box [hPa] + P1 = GET_PEDGE(I,J,L) + P2 = GET_PEDGE(I,J,L+1) + + ! DP = Pressure difference between top & bottom edges [Pa] + DP(I,J,L2) = ( P1 - P2 ) * 100.0d0 + + ! RPDEL = reciprocal of DP [1/hPa] + RPDEL(I,J,L2) = 100.0d0 / DP(I,J,L2) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### DO_G4_CONV_ADJ: a DP, RPDEL' ) + + !================================================================= + ! Flip arrays in the vertical and call FVDAS_CONVECT + !================================================================= + + ! Call the fvDAS convection routines (originally from NCAR!) + CALL FVDAS_CONVECT_ADJ( TDT, + & N_TRACERS, + & CHK_STT_CON(:,:,LLPAR:1:-1,:), + & RPDEL, + & HKETA (:,:,LLPAR:1:-1 ), + & HKBETA(:,:,LLPAR:1:-1 ), + & ZMMU (:,:,LLPAR:1:-1 ), + & ZMMD (:,:,LLPAR:1:-1 ), + & ZMEU (:,:,LLPAR:1:-1 ), + & DP, + & NSTEP, + & F (:,:,LLPAR:1:-1,:), + & TCVV, + & INDEXSOL,STT_ADJ(:,:,LLPAR:1:-1,:) ) + + + !### Debug! + IF ( LPRT ) CALL DEBUG_MSG( '### DO_G4_CONV_ADJ: a FVDAS_CONVECT') + + ! Return to calling program + END SUBROUTINE DO_GEOS4_CONVECT_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE NFCLDMX_ADJ( NC, TCVV, CLDMAS, DTRN, Q ) +! +!****************************************************************************** +! Subroutine ADJ_NFDCLDMX is based on the original NFCLDMX code, where the +! loop over the tracers has been extracted, sent to TAMC, and reinserted. +! (dkh, 02/22/05) +! +! Arguments as input: +! ========================================================================== +! (1 ) NC : TOTAL number of tracers (soluble + insoluble) [unitless] +! (2 ) TCVV : MW air (g/mol) / MW of tracer (g/mol) [unitless] +! (3 ) CLDMAS : Cloud mass flux (at upper edges of each level) [kg/m2/s] +! (4 ) DTRN : Detrainment mass flux [kg/m2/s] +! +! Arguments as Input/Output: +! ============================================================================ +! (5 ) Q : Tracer concentration [v/v] +! +! NOTES: +! (1 ) See orignial NFCLDMX for references,descriptions and notes. +! (2 ) TAMC code and varialbes are lowercase. +! (3 ) Use COMPUTE_ADJ_F from WETSCAV_ADJ_MOD rather than COMPUTE_F from +! WETSCAV_MOD +! (4 ) Get rid of excess array element copying (dkh, 03/01/05) +! (5 ) Leave out ( Q + DELQ > 0 ) condition, as we don't need to force +! the adjoints to be positive definite. +! (6 ) Add support for carbon, dust, ss. (dkh, 03/05/05) +! (7 ) Now include CMN_ADJ to allow for printout. (dkh, 03/14/05) +! (8 ) Rebuild adjoing so that can loop easily over I,J (dkh, 03/22/05) +! (9 ) Now reference WETSCAV_MOD instead of WETSCAV_ADJ_MOD. (dkh, 10/24/05) +! (10) Updated to GCv8 (dkh, 08/25/09) +! (11) BUG FIX: Now correctly reset adjoints for GEOS_5 (dkh, 04/21/10) +! (12) Now support deposition cost function (fp, dkh, 03/04/13) +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NHX_ADJ_FORCE + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION, ADJOINT_AREA_M2 + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : TRACER_IND, NOBS, DEP_UNIT + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE DAO_MOD, ONLY : AD !, CLDMAS, DTRN=>DTRAIN + USE DIAG_MOD, ONLY : AD37, AD38, CONVFLUP + USE GRID_MOD, ONLY : GET_AREA_M2 + USE LOGICAL_MOD, ONLY : LDYNOCEAN + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS + USE LOGICAL_ADJ_MOD, ONLY : LKGNHAYR + USE OCEAN_MERCURY_MOD, ONLY : ADD_Hg2_WD + USE PRESSURE_MOD, ONLY : GET_BP, GET_PEDGE + USE TIME_MOD, ONLY : GET_TS_CONV + USE TIME_MOD, ONLY : GET_TS_DYN + USE TIME_MOD, ONLY : GET_TAU + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : ITS_A_MERCURY_SIM + USE TRACER_MOD, ONLY : TRACER_NAME + + USE TRACERID_MOD, ONLY : IS_Hg2 + USE WETSCAV_MOD, ONLY : COMPUTE_F + +! DISABLE this for now. It needs to be further validated. (dkh, 10/12/08) +! !>>> +! ! Now include adjoint of F (dkh, 10/03/08) +! USE WETSCAV_MOD, ONLY : QC_SO2 +! USE WETSCAV_MOD, ONLY : ADJ_COMPUTE_F +! USE WETSCAV_MOD, ONLY : ADJ_F +! USE WETSCAV_MOD, ONLY : RESTORE_CONV +! USE TRACERID_MOD, ONLY : IDTSO2 +! !<<< + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ADJ_ARRAYS_MOD, ONLY : TR_WDEP_CONV + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic switches & arrays + + ! Arguments + INTEGER, INTENT(IN) :: NC + REAL*8, INTENT(IN) :: CLDMAS(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: DTRN(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(INOUT) :: Q(IIPAR,JJPAR,LLPAR,NC) + REAL*8, INTENT(IN) :: TCVV(NC) + + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: IS_Hg = .TRUE. + INTEGER :: I, J, K, KTOP, L, N, NDT + INTEGER :: IC, ISTEP, JUMP, JS, JN, NS + INTEGER :: IMR, JNP, NLAY + REAL*8, SAVE :: DSIG(LLPAR) + REAL*8 :: SDT, CMOUT, ENTRN, DQ, AREA_M2 + REAL*8 :: T0, T1, T2, T3, T4, TSUM, DELQ + REAL*8 :: DTCSUM(IIPAR,JJPAR,LLPAR,NC) + + ! F is the fraction of tracer lost to wet scavenging in updrafts + REAL*8 :: F(IIPAR,JJPAR,LLPAR,NC) + + ! Local Work arrays (Comment out those that are superfluous for adj) + REAL*8 :: BMASS(IIPAR,JJPAR,LLPAR) + !REAL*8 :: QB(IIPAR,JJPAR) + !REAL*8 :: MB(IIPAR,JJPAR) + !REAL*8 :: QC(IIPAR,JJPAR) + + ! TINY = a very small number + REAL*8, PARAMETER :: TINY = 1d-14 + + ! ISOL is an index for the diagnostic arrays + INTEGER :: ISOL + + ! QC_PRES and QC_SCAV are the amounts of tracer + ! preserved against and lost to wet scavenging + ! Not needed for adjoint + !REAL*8 :: QC_PRES, QC_SCAV + + ! DNS is the double precision value for NS + REAL*8 :: DNS + + ! Amt of Hg2 scavenged out of the column (sas, bmy, 1/19/05) + REAL*8 :: WET_Hg2 + + !>>> + ! Now include adjoint of F (dkh, 10/03/08) + REAL*8 :: F_SO2(IIPAR,JJPAR,LLPAR) + !<<< + + REAL*8, SAVE :: OBS_COUNT = 0 + + +C============================================== +C define arguments (comment out those already defined) +C============================================== + real*8 adq_in(llpar) + real*8 adq_out(llpar) + real*8 vbmass(llpar) + real*8 vcldmas(llpar) + !real*8 dsig(llpar) + real*8 vdtrn(llpar) + real*8 vf(llpar) + !integer ktop + !integer ns + !real*8 sdt + +C============================================== +C define local variables (comment out those already defined) +C============================================== + real*8 addelq + real*8 adq(llpar) + real*8 adqb + real*8 adqc + real*8 adqc_pres + real*8 adt1 + real*8 adt2 + real*8 adt3 + real*8 adt4 + real*8 adtsum + !real*8 cmout + !real*8 entrn + integer ip1 + !integer istep + !integer k + real*8 mb + + + !fp + real*8 ea(llpar) + real*8 aa(llpar) + real*8 adq_force + real*8 qc_contrib + integer kk, temp_id + real*8 ntsdyn + real*8 conv_c(NC) +C real*8 conv_area + real*8 conv_time + logical force + !================================================================= + ! ADJ_NFCLDMX begins here! + !================================================================= + + + + ! First-time initialization + IF ( FIRST ) THEN + + ! Echo info + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'N F C L D M X -- by S-J Lin' + WRITE( 6, '(a)' ) 'Modified for GEOS-CHEM by Bob Yantosca' + WRITE( 6, '(a)' ) 'Last Modification Date: 1/27/04' + WRITE( 6, '(a)' ) 'Adjoint constucted with TAMC: dkh, 03/01/05' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + +#if !defined( GEOS_5 ) && !defined( GEOS_FP ) + ! NOTE: We don't need to do this for GEOS-5 (bmy, 6/27/07) + ! DSIG is the sigma-level thickness (NOTE: this assumes that + ! we are using a pure-sigma grid. Use new routine for fvDAS.) + DO L = 1, LLPAR + DSIG(L) = GET_BP(L) - GET_BP(L+1) + ENDDO +#endif + + + ! Reset first time flag + FIRST = .FALSE. + ENDIF + + ! Define dimensions + IMR = IIPAR + JNP = JJPAR + NLAY = LLPAR + + ! Convection timestep [s] + NDT = GET_TS_CONV() * 60d0 + + !================================================================= + ! Define active convective region, from J = JS(outh) to + ! J = JN(orth), and to level K = KTOP. + ! + ! Polar regions are too cold to have moist convection. + ! (Dry convection should be done elsewhere.) + ! + ! We initialize the ND14 diagnostic each time we start a new + ! time step loop. Only initialize DTCSUM array if the ND14 + ! diagnostic is turned on. This saves a quite a bit of time. + ! (bmy, 12/15/99) + !================================================================= + IF ( ND14 > 0 ) DTCSUM = 0d0 + + KTOP = NLAY - 1 + JUMP = (JNP-1) / 20 + JS = 1 + JUMP + JN = JNP - JS + 1 + + !================================================================= + ! Internal time step for convective mixing is 300 sec. + ! Doug Rotman (LLNL) says that 450 sec works just as well. + !================================================================= + NS = NDT / 300 + NS = MAX(NS,1) + SDT = FLOAT(NDT) / FLOAT(NS) + DNS = DBLE( NS ) + + FORCE = .FALSE. + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + & + REAL(GET_TS_DYN(),8) / REAL(GET_TS_CHEM(),8) + + IF ( OBS_COUNT <= NSPAN ) THEN + + ! force for sensitivity + IF ( LADJ_WDEP_CV ) FORCE = .TRUE. + + ENDIF + ELSEIF ( LADJ_WDEP_CV ) THEN + FORCE = .TRUE. + ENDIF + + IF ( FORCE ) THEN + + NTSDYN = NSPAN / ( GET_TS_CONV() / 60D0 ) + +C IF ( LKGNHAYR ) THEN +C CONV_TIME = 1d0 / DNS * 1d0 / NTSDYN +C CONV_C(:) = 14D0 / 28.97D0 + + ! sensitivitity study (divide by total area of the region) +C CONV_AREA = 1D4 / ADJOINT_AREA_M2 +C CONV_TIME = CONV_TIME * 86400D0 * 365D0 +C ELSE + + DO N = 1, NOBS + DO IC = 1, NC + IF ( TRACER_IND(N) == IC ) THEN + CONV_C(IC) = 1d0 / TCVV(TRACER_IND(N)) + ENDIF + ENDDO + ENDDO + CONV_TIME = 1d0 / DNS * 1d0 / NTSDYN + +C ENDIF + + DO N = 1, NOBS + WRITE(6,100) ,TRIM( TRACER_NAME(TRACER_IND(N)) ), + & TRIM( DEP_UNIT ) + ENDDO + + 100 FORMAT('Forcing ',a,' in cv wetdep (', a,')') + + ENDIF + +!============================================================================= +! BMASS has units of kg/m^2 and is equivalent to AD(I,J,L) / AREA_M2 +! +! Ps - Pt (mb)| P2 - P1 | 100 Pa | s^2 | 1 | 1 kg kg +! -------------+---------+--------+-------+----+-------- = ----- +! | Ps - Pt | mb | 9.8 m | Pa | m^2 s^2 m^2 +! +! This is done to keep BMASS in the same units as CLDMAS * SDT +! +! We can parallelize over levels here. The only quantities that need to +! be held local are the loop counters (I, IC, J, JREF, K). (bmy, 5/2/00) +! +! Now use routine GET_AREA_M2 from "grid_mod.f" to get surface area of +! grid boxes in m2. (bmy, 2/4/03) +!============================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, AREA_M2, K ) +!$OMP+SCHEDULE( DYNAMIC ) + DO K = 1, NLAY + DO J = 1, JJPAR + AREA_M2 = GET_AREA_M2( J ) + DO I = 1, IMR + BMASS(I,J,K) = AD(I,J,K) / AREA_M2 + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! (1) T r a c e r L o o p + ! + ! We now parallelize over tracers, since tracers are independent + ! of each other. The parallel loop only takes effect if you + ! compile with the f90 "-mp" switch. Otherwise the compiler will + ! interpret the parallel-processing directives as comments, and + ! the loop will execute on a single thread. + ! + ! The following types of quantities must be held local for + ! parallelization: + ! (1) Loop counters ( I, IC, ISTEP, J, K ) + ! (2) Scalars that are assigned values inside the tracer loop: + ! ( CMOUT, DELQ, ENTRN, ISOL, QC_PRES, etc. ) + ! (3) Arrays independent of tracer ( F, MB, QB, QC ) + !================================================================= + !>>> + ! Now include adjoint of F (dkh, 10/03/08) + ! OLD: + !DO IC = 1, NC + ! CALL COMPUTE_ADJ_F( IC, F(:,:,:,IC), ISOL ) + !ENDDO + ! NEW: + DO IC = 1, NC + CALL COMPUTE_F( IC, F(:,:,:,IC), ISOL ) + ENDDO +! +! DISABLE this for now. It needs to be further validated. (dkh, 10/12/08) +! F_SO2(:,:,:) = F(:,:,:,IDTSO2) +! +! !<<< + + IF ( LPRINTFD ) THEN + WRITE(165,*) ' Convection variables ', + & ' AD(FD) = ', AD(IFD,JFD,LFD), + & ' CLDMAS = ', CLDMAS(IFD,JFD,LFD), + & ' DTRN = ', DTRN(IFD,JFD,LFD), + & ' GET_BP = ', GET_BP(LFD), + & ' GET_AREA_M2 = ', GET_AREA_M2(JFD), + & ' F = ', F(IFD,JFD,LFD,NFD) + ENDIF + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( CMOUT, DELQ, ENTRN, I, IC, ISOL, ISTEP, J, K ) +!$OMP+PRIVATE( MB, T0, T1, T2, T3, T4, TSUM ) +!$OMP+PRIVATE( WET_Hg2 ) +!$OMP+PRIVATE( addelq, adqb, adqc, adqc_pres, adt1, adt2, adt3, adt4 ) +!$OMP+PRIVATE( adtsum, ip1, adq_out, vdtrn, vbmass, vcldmas, vf ) +!$OMP+PRIVATE( adq_in, adq ) +!$OMP+PRIVATE( ea, aa, qc_contrib, adq_force, n, kk ) +!$OMP+SCHEDULE( DYNAMIC ) + DO IC = 1, NC + DO J = JS, JN + DO I = 1, IMR + + adq_out(:) = Q (I,J,:,IC) + vdtrn (:) = DTRN (I,J,:) + vbmass (:) = BMASS (I,J,:) + vcldmas(:) = CLDMAS(I,J,:) + vf (:) = F (I,J,:,IC) + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + addelq = 0. + do ip1 = 1, llpar + adq(ip1) = 0. + end do + adqb = 0. + adqc = 0. + adqc_pres = 0. + adt1 = 0. + adt2 = 0. + adt3 = 0. + adt4 = 0. + adtsum = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + adq(:) = adq(:)+adq_out(:) + adq_in(:) = 0d0 + + adq_out(:) = 0. + + ! IF ( LPRINTFD .and. i == IFD .and. j == JFD .and. + !& ic == STT2ADJ(NFD) ) THEN + ! print*, 'adq = ', adq + ! ENDIF + + do istep = ns, 1, -1 + do k = ktop, 3, -1 + if (vcldmas(k-1) .gt. tiny) then + cmout = vcldmas(k)+vdtrn(k) + entrn = cmout-vcldmas(k-1) + addelq = addelq+adq(k) + + ! note: need to implement CONVECTION_FLOW_CHK + ! fwd code: + !IF ( Q(I,J,K,IC) + DELQ < 0.0d0 ) THEN + ! DELQ = -Q(I,J,K,IC) + !ENDIF + ! adj code: + !IF ( CONVECTION_FLOW_CHK(I,J,ISTEP,1) ) THEN + ! ADQ(K) = -ADDELQ + !ENDIF + + adtsum = adtsum+addelq*(sdt/vbmass(k)) + addelq = 0. + adt1 = adt1+adtsum + adt2 = adt2+adtsum + adt3 = adt3+adtsum + adt4 = adt4+adtsum + adtsum = 0. + adq(k) = adq(k)-adt4*vcldmas(k-1) + adt4 = 0. + adq(k+1) = adq(k+1)+adt3*vcldmas(k) + adt3 = 0. + adqc = adqc-adt2*vcldmas(k) + adt2 = 0. + adqc_pres = adqc_pres+adt1*vcldmas(k-1) + adt1 = 0. + if (entrn .ge. 0) then + adq(k) = adq(k)+adqc*(entrn/cmout) + adqc_pres = adqc_pres+adqc*(vcldmas(k-1)/cmout) + adqc = 0. + endif + IF ( FORCE ) THEN + if (entrn .ge. 0) then + ea(k)=entrn/cmout + aa(k)=vcldmas(k-1)/cmout*(1d0-vf(k)) + else + ea(k)=0d0 + aa(k)=1d0 + endif + ENDIF + adqc = adqc+adqc_pres*(1.d0-vf(k)) +! DISABLE this for now. It needs to be further validated. (dkh, 10/12/08) +! !>>> +! ! Now include adjoint of F(SO2) (dkh, 10/03/08) +! ! fwd code: +! !QC_PRES = QC(I,J) * ( 1d0 - F(I,J,K,IC) ) +! ! adj code: +! IF ( IC == IDTSO2 ) THEN +! ADJ_F(I,J,K) = ADJ_F(I,J,K) +! & - QC_SO2(I,J,K,ISTEP) * ADQC_PRES +! ENDIF +! !<<< + adqc_pres = 0. + else + +#if defined( GEOS_5 ) || defined( GEOS_FP ) + IF ( CLDMAS(I,J,K) > TINY ) THEN + + ! fwd code: + !Q(I,J,K,IC) = Q(I,J,K,IC) + DELQ + ! adj code: + ADDELQ = ADQ(K) + + ! note: need to implement CONVECTION_FLOW_CHK + ! fwd code: + !IF ( Q(I,J,K,IC) + DELQ < 0.0d0 ) THEN + ! DELQ = -Q(I,J,K,IC) + !ENDIF + ! adj code: + !IF ( CONVECTION_FLOW_CHK(I,J,ISTEP,2) ) THEN + ! ADQ(K) = -ADDELQ + !ENDIF + + ! fwd code: + !DELQ = ( SDT / BMASS(I,J,K) ) * (T2 + T3) + ! adj code: + ADT2 = ( SDT / VBMASS(K) ) * ADDELQ + ADT3 = ( SDT / VBMASS(K) ) * ADDELQ + ! BUG FIX: make sure to reset ADDELQ (dkh, 04/21/10) + ADDELQ = 0d0 + + ! fwd code: + !T3 = CLDMAS(I,J,K ) * Q (I,J,K+1,IC) + ! adj code: + ADQ(K+1) = ADQ(K+1) + VCLDMAS(K) * ADT3 + ! BUG FIX: make sure to reset ADT3 (dkh, 04/21/10) + ADT3 = 0d0 + + ! fwd code: + !T2 = -CLDMAS(I,J,K ) * QC(I,J) + ! adj code: + ADQC = ADQC - VCLDMAS(K) * ADT2 + ! BUG FIX: make sure to reset ADT2 (dkh, 04/21/10) + ADT2 = 0d0 + + + ENDIF +#endif + + adq(k) = adq(k)+adqc + adqc = 0. + + IF ( FORCE ) THEN + ea(k)=1d0 + aa(k)=0d0 + ENDIF + + endif + end do + + ! IF ( LPRINTFD .and. i == IFD .and. j == JFD .and. + !& ic == STT2ADJ(NFD) ) THEN + ! print*, 'adq = ', adq + ! ENDIF + + if (vcldmas(2) .gt. tiny) then + mb = vbmass(1)+vbmass(2) + adqc = adqc+adq(1) + adq(1) = 0. + adqc = adqc+adq(2) + adq(2) = 0. + adq(3) = adq(3)+adqc*(vcldmas(2)*sdt/(mb+vcldmas(2)*sdt)) + adqb = adqb+adqc*(mb/(mb+vcldmas(2)*sdt)) + adqc = 0. +#if defined ( GEOS_5 ) || defined( GEOS_FP ) + ! for GEOS-5 (dkh, 08/25/09) + adq(2) = adq(2)+adqb*(( GET_PEDGE(I,J,2) - GET_PEDGE(I,J,3) ) + & /( GET_PEDGE(I,J,1) - GET_PEDGE(I,J,3) ) ) + adq(1) = adq(1)+adqb*(( GET_PEDGE(I,J,1) - GET_PEDGE(I,J,2) ) + & /( GET_PEDGE(I,J,1) - GET_PEDGE(I,J,3) ) ) + IF ( FORCE ) THEN + ea(1) = ( GET_PEDGE(I,J,1) - GET_PEDGE(I,J,3) ) + & /( GET_PEDGE(I,J,1) - GET_PEDGE(I,J,3) ) + & * mb/(mb+vcldmas(2)*sdt) + + ea(2) = ( GET_PEDGE(I,J,2) - GET_PEDGE(I,J,3) ) + & /( GET_PEDGE(I,J,1) - GET_PEDGE(I,J,3) ) + & * mb/(mb+vcldmas(2)*sdt) + + ea(3) = vcldmas(2)*sdt/(mb+vcldmas(2)*sdt) + ENDIF + +#else + ! for GEOS-3 + adq(2) = adq(2)+adqb*(dsig(2)/(dsig(1)+dsig(2))) + adq(1) = adq(1)+adqb*(dsig(1)/(dsig(1)+dsig(2))) +#endif + adqb = 0. + else + adq(3) = adq(3)+adqc + adqc = 0. + IF ( FORCE ) THEN + ea(1) = 0D0 + ea(2) = 0D0 + ea(3) = 1D0 + ENDIF + endif + + IF ( FORCE ) THEN + + + IF ( OBS_THIS_TRACER( IC ) ) THEN + + DO K = 1, KTOP + + QC_CONTRIB = 0D0 + ADQ_FORCE = 0D0 + + IF ( K .le. 3 ) THEN + QC_CONTRIB = EA(K) + ENDIF + + DO KK = MAX(K,3), KTOP + +!to get sensitivity to specific level(s) (uncomment) +! if (kk .eq. 5) then +! + IF ( VCLDMAS(KK-1) .gt. TINY ) THEN + + ADQ_FORCE = ADQ_FORCE + & + QC_CONTRIB + & * VF(KK) + & * VCLDMAS(KK-1) + ENDIF + +! +! endif +! + IF ( KK == K ) THEN + + QC_CONTRIB = EA(KK) + QC_CONTRIB * AA(KK) + + ELSE + + QC_CONTRIB = QC_CONTRIB * AA(KK) + + ENDIF + + ENDDO + +!convert the forcing from kg/s to kgN/ha/year + ADQ_FORCE = ADQ_FORCE + & * GET_CF_REGION(I,J,K) + & * CONV_C(IC) + & * CONV_TIME + & * GET_AREA_M2(J) + & * TR_WDEP_CONV(J,IC) + + ADQ(K) = ADQ(K) + ADQ_FORCE + ENDDO + + ENDIF + + ENDIF + + end do + adq_in(:) = adq_in(:)+adq(:) + adq(:) = 0. + + Q(I,J,:,IC) = adq_in(:) + + + ENDDO !I + ENDDO !J + ENDDO !IC +!$OMP END PARALLEL DO + + ! dkh debug + !print*, ' after convect Q = ', SUM(Q(:,:,:,30)) + +! DISABLE this for now. It needs to be further validated. (dkh, 10/12/08) +! !>>> +! ! Now include adjoint of F(SO2) (dkh, 10/03/08) +! ! Restore H2O2s and SO2s to their pre-convection values +! CALL RESTORE_CONV +! +! ! fwd code: +! !CALL COMPUTE_F( IC, F(:,:,:,IC), ISOL ) +! ! adj code: +! CALL ADJ_COMPUTE_F( F_SO2(:,:,:) ) +! !<<< + + ! Return to calling program + END SUBROUTINE NFCLDMX_ADJ +!------------------------------------------------------------------------------ + + END MODULE CONVECTION_ADJ_MOD diff --git a/code/adjoint/covariance_mod.f b/code/adjoint/covariance_mod.f new file mode 100644 index 0000000..0c5357d --- /dev/null +++ b/code/adjoint/covariance_mod.f @@ -0,0 +1,455 @@ + + MODULE COVARIANCE_MOD + +!======================================================================= +! Module COVARIANCE_MOD contains routines to perform calculations +! involving non-diagonal error covariance matrices. (nb,yd,dkh, 02/11/13) +! +! Based on Singh et al. (2011): +! Construction of non-diagonal background error covariance matrices +! for global chemical data assimilation, Geophysical Model Development 4,299-316 +! +! +! +! Module Routines +! ============================================================================ +! (1 ) CALC_COV_ERROR : Computes prior term in cost function (x-xb)^TB^-1(x-xb) +! for non-diagonal covariance matrices +! (2 ) BVECT : Performs covariance matrix-vector operations +! +!======================================================================= + + IMPLICIT NONE + + ! Header files +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic switches, NJDAY +# include "CMN_GCTM" ! Physical constants +# include "define_adj.h" ! Obs operators + + CONTAINS + + +!----------------------------------------------------------------------- + + SUBROUTINE CALC_COV_ERROR ( APCOST ) + +!*********************************************************************** +! Subroutine CALC_COV_ERROR calculates the prior term of the +! cost function when the covariance matrix of prior errors +! contains off-diagonal terms (nb,yd, dkh, 02/11/13) +! +! Module Variables as inputs: +! ==================================================================== +! (1 ) EMS_ERROR (REAL*8) : Diag error in scaling factor [none] +! (2 ) COV_ERROR_LX (REAL*8) : Correlation length in x [km] +! (3 ) COV_ERROR_LY (REAL*8) : Correlation length in y [km] +! +! Module Variables as output: +! ==================================================================== +! (1 ) EMS_SF_ADJ (REAL*8) : Emissions scaling factor adjoint [J] +! (2 ) TEMP2 (REAL*8) : Temp array for adjoint forcing +! +! Notes: +! +!*********************************************************************** + + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : COST_ARRAY, COST_FUNC, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR,COV_ERROR_LX,COV_ERROR_LY + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_EMS + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ, TEMP2 + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS, LBKCOV + USE GRID_MOD , ONLY : GET_XMID, GET_YMID + + USE netcdf + +# include "CMN_SIZE" + + REAL*8 :: S2_INV_2D(IIPAR,JJPAR) + REAL*8 :: REG_4D(IIPAR, JJPAR,MMSCL, NNEMS) + REAL*8 :: S2_INV + REAL*8 :: REG + REAL*8, ALLOCATABLE :: APCOST(:,:,:,:) + REAL :: TEMP(IIPAR,JJPAR) + INTEGER :: I, J, M, N, STATUS, NCID, VARID + CHARACTER(255) :: SCALEFN + + ! Off-diagonal terms of B + + REAL*8 :: SIGMAX, SIGMAY,CORR_LX, CORR_LY + REAL*8 :: MATINVX(JJPAR,IIPAR,IIPAR) + REAL*8 :: MATY(JJPAR,JJPAR),MATXX(IIPAR,IIPAR) + REAL*8 :: B(IIPAR),C(JJPAR),UIN(IIPAR,JJPAR) + REAL*8 :: UOUT(IIPAR,JJPAR) + INTEGER :: ISTATUS, LFLAG, INFO + + + WRITE(*,*) 'Starting Off-Diagonal Term Calculation' +!!!$OMP PARALLEL DO +!!!$OMP+DEFAULT( SHARED ) +!!!$OMP+PRIVATE( I, J, M, N, REG_4D, S2_INV_2D ) + DO N = 1, NNEMS + + ! Put CALL BVECT here since correlations are different for each NNEMS + + !IF ( N .EQ. 1 ) THEN + + CORR_LX = COV_ERROR_LX(N) + CORR_LY = COV_ERROR_LY(N) + SIGMAX = 1d0 + SIGMAY = 1d0 + + CALL BVECT(IIPAR, JJPAR, GET_XMID(IIPAR), GET_YMID(JJPAR), + & SIGMAX, SIGMAY, CORR_LX, CORR_LY, + & -1, MATINVX, MATY ) + + !ENDIF + + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR +#if defined ( LOG_OPT ) + ! inverse of error covariance (assume diagonal) + S2_INV_2D(I,J) = 1d0 / ( EMS_ERROR(N)/EMS_SF0(I,J,M,N) ) + & ** 2 +#else + S2_INV_2D(I,J) = 1d0 / ( EMS_ERROR(N) ) ! 100% error +#endif + + REG_4D(I,J,M,N) = ( EMS_SF(I,J,M,N) - EMS_SF0(I,J,M,N) ) + & * S2_INV_2D(I,J) + + IF ( REG_4D(I,J,M,N) .NE. 0.d0 ) THEN + WRITE(*,*) 'REG_4DULAR=', REG_4D(I,J,M,N) + ENDIF + + ENDDO + ENDDO + + ! Couple in x + DO J = 1 , JJPAR + MATXX(1:IIPAR,1:IIPAR) = MATINVX(J,1:IIPAR,1:IIPAR) + + B(1:IIPAR) = REG_4D(1:IIPAR,J, M, N) + + CALL DPOTRS( 'L', IIPAR, 1, MATXX, IIPAR, B, IIPAR, INFO) + + UOUT(1:IIPAR,J) = B(1:IIPAR) + ENDDO + + ! COUPLE IN Y + DO I = 1, IIPAR + C(1:JJPAR) = UOUT(I,1:JJPAR) + + CALL DPOTRS( 'L', JJPAR, 1, MATY, JJPAR, C, JJPAR, INFO ) + + UOUT(I,1:JJPAR) = C(1:JJPAR) + + ENDDO + + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! IF(J.GE.16.AND.J.LE.60)THEN + TEMP2(I, J, M, N) = REG_4D(I,J,M,N)*UOUT(I,J) / 2d0 + EMS_SF_ADJ(I,J,M,N) = EMS_SF_ADJ(I, J, M,N) + UOUT(I,J) + & * S2_INV_2D(I,J) + + APCOST(I,J,M,N) = 0.5d0 * (EMS_SF(I,J,M,N) - + & EMS_SF0(I,J,M,N)) * + & UOUT(I,J) * S2_INV_2D(I,J) + ENDDO + ENDDO + + ENDDO + ! add regularization parameter from input.gcadj + APCOST(:,:,:,N) = APCOST(:,:,:,N) * REG_PARAM_EMS(N) + WRITE(*,*) 'SUM of UOUT =', SUM ( UOUT(:,:) ) , N + ENDDO +!!!$OMP END PARALLEL DO + + + + END SUBROUTINE CALC_COV_ERROR + +!------------------------------------------------------------------------------ + + SUBROUTINE BVECT(N,M,X,Y,SIGMAX,SIGMAY,LX,LY,DIRECTION, + & MATINVX,MATY) + +!******************************************************************************* +! +! C O V A R I A N C E M A T R I X - V E C T O R O P E R A T I O N S +! ( with periodicity ) +! +! INPUTS: +! N - size of x vector ( dimension in x direction ) +! M - size of y vector ( dimension in y direction ) +! x - longitude coordinates of length N, degrees +! y - latitude coordinates of length M, degrees +! sigmax - Background standard deviation in x direction +! sigmay - Background standard deviation in y direction +! lx - Correlation Lenghts in x direction (scalar) +! ly - Correlation Lenghts in y direction (scalar) +! direction - Correlation Lenghts in x direction (scalar) +! uin - Vector to be multiplied by matrix, dimension 1 x NM +! +! OUTPUT: +! if (direction == 1) +! uout = Covariance Matrix multiplied by uin +! else if(direction == -1) +! uout = Inverse Covariance Matrix multiplied by uin +! else if(direction == 2) +! uout = SQRT(Covariance Matrix) multiplied by uin +! else if(direction == -2) +! uout = Inverse SQRT(Covariance Matrix) multiplied by uin +! +! DESCRIPTION: +! Calculates the covariance matrix and it's inverse times a vector +! without +! explicitly contructing the covariance matrix +! +! AUTHORS: +! Mjardak, Kumaresh Singh +! DATE: +! 03/03/2009 +!******************************************************************************* + + ! References to F90 modules + USE GRID_MOD, ONLY : DX_COV, DY_COV + + IMPLICIT NONE + + ! Global variables + INTEGER,INTENT(IN) :: N,M + DOUBLE PRECISION,INTENT(IN) :: SIGMAX,SIGMAY,LX,LY + DOUBLE PRECISION,INTENT(IN) :: X(N),Y(M) + INTEGER, INTENT(IN) :: DIRECTION + DOUBLE PRECISION, INTENT(INOUT) :: MATINVX(M,N,N) + DOUBLE PRECISION, INTENT(INOUT) :: MATY(M,M) + + ! Local variables + INTEGER :: I,J,K,L,INFO,II + DOUBLE PRECISION :: TMP, SUM + DOUBLE PRECISION :: ALPHA,BETA,DGRIDPTS,DKM + DOUBLE PRECISION :: TESTVEC(N*M) + DOUBLE PRECISION :: MATX(M,N,N),MATXX(N,N) + + ALPHA = 0.2 !PERTURBATION ON DIAGONAL + BETA = 0.2 !PERTURBATION ON DIAGONAL + +!------------------------------------------------ +! One dimensional Covariance Matices +!------------------------------------------------ +! X Direction +!------------------------------------------------ + + MATX(:,:,:) = 0D0 + DO K = 1 , M + DO I = 1 , N + MATX(K,I,I) = SIGMAX * 1.0D0 + DO J = 1 , I-1 + DGRIDPTS = MIN( ABS( I - J ), N - ABS( I - J ) ) ! DISTANCE IN GRIDPOINTS BETWEEN (I,J) + DKM = DGRIDPTS * DX_COV(K) ! DISTANCE IN KM BETWEEN (I,J) + IF ( DKM <= 3 * LX ) THEN ! + + MATX(K,I,J) = + & EXP( -( DKM / LX )**2 )/( 1.D0 + ALPHA ) + ELSE + + MATX(K,I,J) = 0.D0 + + ENDIF + MATX(K,I,J) = SIGMAX * MATX(K,I,J) + MATX(K,J,I) = MATX(K,I,J) + ENDDO + + ENDDO + ENDDO + +!------------------------------------------------ +! Y Direction +!------------------------------------------------ + MATY = 0D0 + DO I = 1 , M + + MATY(I,I) = SIGMAY * 1D0 + + DO J = 1 , I - 1 + + DKM = ABS(I-J) * DY_COV(M/2) + IF ( DKM <= 3 * LY ) THEN + + MATY(I,J) = EXP( -( DKM/LY )**2 ) / ( 1.D0 + BETA ) + + ELSE + + MATY(I,J) = 0.D0 + + ENDIF + + MATY(I,J) = SIGMAY * MATY(I,J) + MATY(J,I) = MATY(I,J) + + ENDDO + ENDDO + +!------------------------------------------------------- +! IF DIRECTION IS -1, GET INVERSE OF MATX AND MATY +!------------------------------------------------------- + +C$$$ IF(DIRECTION == 1)THEN +C$$$ +C$$$ ! COUPLE IN Y +C$$$ DO K = 1,N +C$$$ DO L = 1,M +C$$$ UOUT(K,L) = 0D0 +C$$$ DO I = 1,M +C$$$ UOUT(K,L) = UOUT(K,L) + MATY(L,I)*UIN(K,I) +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ +C$$$ UMID(:,:) = UOUT(:,:) +C$$$ ! COUPLE IN X +C$$$ DO K = 1,N +C$$$ DO L = 1,M +C$$$ UOUT(K,L) = 0D0 +C$$$ DO I = 1,N +C$$$ UOUT(K,L) = UOUT(K,L) + MATX(L,K,I)*UMID(I,L) +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ +C$$$ ELSE IF(DIRECTION == 2)THEN +C$$$ +C$$$ CALL DSYEVD( 'V', 'L', M, MATY, M, SY, WORKY, 3*M*M, IWORKY, +C$$$ $ 6*M, INFO ) +C$$$ +C$$$ DO L = 1 , M +C$$$ MATXX(:,:) = MATX(L,:,:) +C$$$ +C$$$ CALL DSYEVD( 'V', 'L', N, MATXX, N, SX, WORKX, 3*N*N, IWORKX, +C$$$ $ 6*N, INFO ) +C$$$ +C$$$ DO I = 1,N +C$$$ DO J = 1,N +C$$$ UX(L,I,J) = 0D0 +C$$$ DO K = 1,N +C$$$ UX(L,I,J) = UX(L,I,J)+(MATXX(I,K)*SQRT(SX(K))* +C$$$ $ MATXX(J,K)) +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$! +C$$$ DO I = 1,M +C$$$ DO J = 1,M +C$$$ UY(I,J) = 0D0 +C$$$ DO K = 1,M +C$$$ UY(I,J) = UY(I,J) + (MATY(I,K)*SQRT(SY(K))*MATY(J,K)) +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ +C$$$ ! COUPLE IN Y +C$$$ DO K = 1,N +C$$$ DO L = 1,M +C$$$ UOUT(K,L) = 0D0 +C$$$ DO I = 1,M +C$$$ UOUT(K,L) = UOUT(K,L) + UY(L,I)*UIN(K,I) +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ +C$$$ UMID(:,:) = UOUT(:,:) +C$$$ ! COUPLE IN X +C$$$ DO K = 1,N +C$$$ DO L = 1,M +C$$$ UOUT(K,L) = 0D0 +C$$$ DO I = 1,N +C$$$ UOUT(K,L) = UOUT(K,L) + UX(L,K,I)*UMID(I,L) +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ +C$$$ ELSE IF (DIRECTION == -1) THEN + + DO L = 1 , M + MATXX(:,:) = MATX(L,:,:) + ! Cholesky decomposition of x-corr + CALL DPOTRF( 'L', N, MATXX, N, INFO ) + MATINVX(L,:,:) = MATXX(:,:) + ENDDO + + ! Cholesky decomposition of y-corr + CALL DPOTRF( 'L', M, MATY, M, INFO ) + +C$$$ ELSE IF(DIRECTION == -2)THEN +C$$$ +C$$$ CALL DSYEVD( 'V', 'L', M, MATY, M, SY, WORKY, 3*M*M, IWORKY, +C$$$ $ 6*M, INFO ) +C$$$ +C$$$ +C$$$ DO L = 1 , M +C$$$ MATXX(:,:) = MATX(L,:,:) +C$$$ CALL DSYEVD('V','L',N,MATXX,N,SX,WORKX,3*N*N,IWORKX, +C$$$ $ 6*N, INFO ) +C$$$ +C$$$ DO I = 1,N +C$$$ DO J = 1,N +C$$$ UX(L,I,J) = 0D0 +C$$$ DO K = 1,N +C$$$ UX(L,I,J) = UX(L,I,J)+(MATXX(I,K)*MATXX(J,K)) +C$$$ $ /SQRT(SX(K)) +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ +C$$$ DO I = 1,M +C$$$ DO J = 1,M +C$$$ UY(I,J) = 0D0 +C$$$ DO K = 1,M +C$$$ UY(I,J) = UY(I,J) + (MATY(I,K)*MATY(J,K)) +C$$$ $ /SQRT(SY(K)) +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ +C$$$ ! COUPLE IN X +C$$$ DO K = 1,N +C$$$ DO L = 1,M +C$$$ UOUT(K,L) = 0D0 +C$$$ DO I = 1,N +C$$$ UOUT(K,L) = UOUT(K,L) + UX(L,K,I)*UIN(I,L) +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ +C$$$ UMID(:,:) = UOUT(:,:) +C$$$ ! COUPLE IN Y +C$$$ DO K = 1,N +C$$$ DO L = 1,M +C$$$ UOUT(K,L) = 0D0 +C$$$ DO I = 1,M +C$$$ UOUT(K,L) = UOUT(K,L) + UY(L,I)*UMID(K,I) +C$$$ END DO +C$$$ END DO +C$$$ END DO +C$$$ +C$$$ ENDIF + +!-------------------------------------------------------- + RETURN + + END SUBROUTINE BVECT + +!======================================================================== + + ! End of program + END MODULE COVARIANCE_MOD + diff --git a/code/adjoint/define_adj.h b/code/adjoint/define_adj.h new file mode 100644 index 0000000..c61d93b --- /dev/null +++ b/code/adjoint/define_adj.h @@ -0,0 +1,183 @@ +!$Id: define_adj.h,v 1.12 2012/08/10 22:08:22 nicolas Exp $ +!****************************************************************************** +! Include file "define_adj.h" specifies C-preprocessor "switches" that are +! used to include or exclude certain sections of ADJOINT code, mostly for +! controlling observation datasets used. The reason they are pre-processor +! switches instead of logical flags is so that we can omit the code which +! requires installation of hdf libaries and such. All are independent of +! each other, but not of simulation and tracer type +! (adj_group, 6/08/09) +! +! List of "Switches" +! =========================================================================== +! (1 ) TES_NH3_OBS : Use NH3 data from TES +! (2 ) PM_ATTAINMENT : Compute PM attainment +! (3 ) SOMO35_ATTAINMENT : Compute ozone attainment +! (4 ) SCIA_KNMI_NO2_OBS : Use NO2 obs from SCIA KNMI retrieval +! (5 ) IMPROVE_SO4_NIT_OBS : Use sulfate-nitrate from IMPROVE network +! (6 ) CASTNET_NH4_OBS : Use amonia from CASTNET network +! (7 ) TES_O3_OBS : Use O3 obs from TES +! (8 ) SCIA_DAL_NO2_OBS : Use NO2 obs from SCIA Dalhousie retrieval +! (9 ) SCIA_DAL_SO2_OBS : Use SO2 obs from SCIA Dalhousie retrieval +! (10) MOPITT_V3_CO_OBS : Use v3 CO obs from MOPITT +! (11) MOPITT_V4_CO_OBS : Use v4 CO obs from MOPITT +! (12) SCIA_BRE_CO_OBS : Use CO obs from SCIA Bremen retrieval +! (13) AIRS_CO_OBS : Use CO obs from AIRS (UMBC) retrieval +! (14) PSEUDO_OBS : Generate pseudo obs if no data selected +! (15) LOG_OPT : Optimized log of scaling factors +! (16) SOMO35_ATTAINMENT : Ozone attainment +! (17) PM_ATTAINMENT : PM attainment +! (18) LIDORT : Online radiative forcing calculations +! (19) GOSAT_CO2_OBS : Use CO2 obs from GOSAT retrieval +! (20) MODIS_AOD_OBS : Use AOD obs from MODIS +! (21) IMPROVE_BC_OC_OBS : Use BC and OC aerosol obs from IMPROVE +! (22) MOPITT_V5_CO_OBS : Use v5 CO obs form MOPITT +! (23) MOPITT_V6_CO_OBS : Use v6 CO obs form MOPITT +! (24) MOPITT_V7_CO_OBS : Use v7 CO obs form MOPITT +! (25) TES_O3_IRK : Use radiative kernels for TES O3 +! (26) OMI_SO2_OBS : Use OMI L3 SO2 +! +! NOTES: +! (1 ) Replace MOPITT_IR_CO_OBS with MOPITT_V3_CO_OBS and MOPITT_V4_CO_OBS +! (zhe, dkh, 02/04/11) +! (2 ) Add MODIS_AOD_OBS (xxu, dkh, 01/09/12, adj32_011) +! (3 ) Addd IMPROVE_BC_OC_OBS (yhmao, dkh/ 01/16/12, adj32_013) +! (4 ) Add MOPITT_V5_CO_OBS (zhej, dkh, 01/16/12, adj32_016) +! (5 ) Add CH4 obs operators (kjw, dkh, 02/12/12, adj32_023) +! (6 ) Add MOPIT_V6_CO_OBS and drop support for MOPITT v3 and v4 (zhe, dkh 06/2015) +!****************************************************************************** +! +!============================================================================== +! Undefine all "switches" so that they cannot be accidentally reset +!============================================================================== + +#undef TES_NH3_OBS +#undef PM_ATTAINMENT +#undef SOMO35_ATTAINMENT +#undef SCIA_KNMI_NO2_OBS +#undef IMPROVE_SO4_NIT_OBS +#undef CASTNET_NH4_OBS +#undef TES_O3_OBS +#undef TES_O3_IRK +#undef SCIA_DAL_NO2_OBS +#undef SCIA_DAL_SO2_OBS +#undef SCIA_BRE_CO_OBS +#undef AIRS_CO_OBS +#undef GOSAT_CO2_OBS +#undef PM_ATTAINMENT +#undef SOMO35_ATTAINMNET +#undef PSEUDO_OBS +#undef LOG_OPT +#undef LIDORT +#undef LBKCOV_ERR +! (xxu, dkh, 01/09/12, adj32_011) +#undef MODIS_AOD_OBS +! (yhmao, dkh, 01/13/12, adj32_013) +#undef IMPROVE_BC_OC_OBS +! (zhej, dkh, 01/16/12, adj32_016) +#undef MOPITT_V5_CO_OBS +#undef MOPITT_V6_CO_OBS +! (kjw, dkh, 02/12/12, adj32_023) +#undef TES_CH4_OBS +#undef SCIA_CH4_OBS +#undef MEM_CH4_OBS +#undef LEO_CH4_OBS +#undef GEOCAPE_CH4_OBS +#undef OSIRIS_OBS +!mkeller +#undef OMI_NO2_OBS +! ( ywang, 04/21/15) +#undef OMI_SO2_OBS + !xzhang: +#undef OMI_CH2O_OBS +#undef MLS_O3_OBS +#undef MLS_HNO3_OBS +#undef OSIRIS_NO2_OBS +#undef IASI_CO_OBS +#undef IASI_O3_OBS + +!----------CO observations------ +! pick any combination +! => MOPITT CO +! => MOPITT v5 +! => MOPITT v6 +! => MOPITT v7 +! => AIRS CO +! => SCIA Bremen CO +!#define MOPITT_V5_CO_OBS 'MOPITT_V5_CO_OBS' +!#define MOPITT_V6_CO_OBS 'MOPITT_V6_CO_OBS' +!#define MOPITT_V7_CO_OBS 'MOPITT_V7_CO_OBS' +!#define IASI_CO_OBS 'IASI_CO_OBS' +!#define AIRS_CO_OBS 'AIRS_CO_OBS' +!#define SCIA_BRE_CO_OBS 'SCIA_BRE_CO_OBS' + +!---------aerosol-related---------- +!NH3 observations +! = > TES_NH3_OBS +!SO2 observations +! => SCIA_DAL_SO2_OBS +!Aerosol observations +! => PM_ATTAINMENT +! => IMPROVE_SO4_NIT_OBS +! => IMPROVE_BC_OC_OBS +! => CASTNET_NH4_OBS +!#define TES_NH3_OBS 'TES_NH3_OBS' +!#define SCIA_DAL_SO2_OBS 'SCIA_DAL_SO2_OBS' +!#define PM_ATTAINMENT 'PM_ATTAINMENT' +!#define IMPROVE_SO4_NIT_OBS 'IMPROVE_SO4_NIT_OBS' +!#define IMPROVE_BC_OC_OBS 'IMPROVE_BC_OC_OBS' +!#define CASTNET_NH4_OBS 'CASTNET_NH4_OBS' +!#define MODIS_AOD_OBS 'MODIS_AOD_OBS' + +!--------ozone-related-------------- +! => SOMO35_ATTAINMENT +! => TES O3 +! => TES O3 IRKs +!#define SOMO35_ATTAINMENT 'SOMO35_ATTAINMENT' +#define TES_O3_OBS 'TES_O3_OBS' +!#define TES_O3_IRK 'TES_O3_IRK' +!#define OSIRIS_OBS 'OSIRIS_OBS' +!#define IASI_O3_OBS 'IASI_O3_OBS' + + +!-------CH4 Observations------------ +! => TES CH4 +! => SCIA CH4 +! => MEM CH4 +! => Generic LEO instrument CH4 +! => GEOCAPE CH4 +!#define TES_CH4_OBS 'TES_CH4_OBS' +!#define SCIA_CH4_OBS 'SCIA_CH4_OBS' +!#define MEM_CH4_OBS 'MEM_CH4_OBS' +!#define LEO_CH4_OBS 'LEO_CH4_OBS' +!#define GEOCAPE_CH4_OBS 'GEOCAPE_CH4_OBS' + +!-------NO2 observations------------ +! => SCIA_KNMI_NO2_OBS +! => SCIA_DAL_NO2_OBS +!#define SCIA_KNMI_NO2_OBS 'SCIA_KNMI_NO2_OBS' +!#define SCIA_DAL_NO2_OBS 'SCIA_DAL_NO2_OBS' + +!-------OMI NO2 tropospheric columns +!#define OMI_NO2_OBS 'OMI_NO2_OBS' + +!-------CO2 observations------------ +! => GOSAT_CO2_OBS +!#define GOSAT_CO2_OBS + +!-------SO2 observations------------ +! => OMI_SO2_OBS +!#define OMI_SO2_OBS 'OMI_SO2_OBS' + +!------other options----------------- +!#define PSEUDO_OBS 'PSEUDO_OBS' +!#define LOG_OPT 'LOG_OPT' +!#define LIDORT 'LIDORT' +!#define LBFGS_INV 'LBFGS_INV' +!#define LBKCOV_ERR 'LBKCOV_ERR' + +!xzhang: +!#define OMI_CH2O_OBS 'OMI_CH2O_OBS' +#define MLS_O3_OBS 'MLS_O3_OBS' +!#define MLS_HNO3_OBS 'MLS_HNO3_OBS' +!#define OSIRIS_NO2_OBS 'OSIRIS_NO2_OBS' diff --git a/code/adjoint/define_adj.h~ b/code/adjoint/define_adj.h~ new file mode 100644 index 0000000..d5b7390 --- /dev/null +++ b/code/adjoint/define_adj.h~ @@ -0,0 +1,183 @@ +!$Id: define_adj.h,v 1.12 2012/08/10 22:08:22 nicolas Exp $ +!****************************************************************************** +! Include file "define_adj.h" specifies C-preprocessor "switches" that are +! used to include or exclude certain sections of ADJOINT code, mostly for +! controlling observation datasets used. The reason they are pre-processor +! switches instead of logical flags is so that we can omit the code which +! requires installation of hdf libaries and such. All are independent of +! each other, but not of simulation and tracer type +! (adj_group, 6/08/09) +! +! List of "Switches" +! =========================================================================== +! (1 ) TES_NH3_OBS : Use NH3 data from TES +! (2 ) PM_ATTAINMENT : Compute PM attainment +! (3 ) SOMO35_ATTAINMENT : Compute ozone attainment +! (4 ) SCIA_KNMI_NO2_OBS : Use NO2 obs from SCIA KNMI retrieval +! (5 ) IMPROVE_SO4_NIT_OBS : Use sulfate-nitrate from IMPROVE network +! (6 ) CASTNET_NH4_OBS : Use amonia from CASTNET network +! (7 ) TES_O3_OBS : Use O3 obs from TES +! (8 ) SCIA_DAL_NO2_OBS : Use NO2 obs from SCIA Dalhousie retrieval +! (9 ) SCIA_DAL_SO2_OBS : Use SO2 obs from SCIA Dalhousie retrieval +! (10) MOPITT_V3_CO_OBS : Use v3 CO obs from MOPITT +! (11) MOPITT_V4_CO_OBS : Use v4 CO obs from MOPITT +! (12) SCIA_BRE_CO_OBS : Use CO obs from SCIA Bremen retrieval +! (13) AIRS_CO_OBS : Use CO obs from AIRS (UMBC) retrieval +! (14) PSEUDO_OBS : Generate pseudo obs if no data selected +! (15) LOG_OPT : Optimized log of scaling factors +! (16) SOMO35_ATTAINMENT : Ozone attainment +! (17) PM_ATTAINMENT : PM attainment +! (18) LIDORT : Online radiative forcing calculations +! (19) GOSAT_CO2_OBS : Use CO2 obs from GOSAT retrieval +! (20) MODIS_AOD_OBS : Use AOD obs from MODIS +! (21) IMPROVE_BC_OC_OBS : Use BC and OC aerosol obs from IMPROVE +! (22) MOPITT_V5_CO_OBS : Use v5 CO obs form MOPITT +! (23) MOPITT_V6_CO_OBS : Use v6 CO obs form MOPITT +! (24) MOPITT_V7_CO_OBS : Use v7 CO obs form MOPITT +! (25) TES_O3_IRK : Use radiative kernels for TES O3 +! (26) OMI_SO2_OBS : Use OMI L3 SO2 +! +! NOTES: +! (1 ) Replace MOPITT_IR_CO_OBS with MOPITT_V3_CO_OBS and MOPITT_V4_CO_OBS +! (zhe, dkh, 02/04/11) +! (2 ) Add MODIS_AOD_OBS (xxu, dkh, 01/09/12, adj32_011) +! (3 ) Addd IMPROVE_BC_OC_OBS (yhmao, dkh/ 01/16/12, adj32_013) +! (4 ) Add MOPITT_V5_CO_OBS (zhej, dkh, 01/16/12, adj32_016) +! (5 ) Add CH4 obs operators (kjw, dkh, 02/12/12, adj32_023) +! (6 ) Add MOPIT_V6_CO_OBS and drop support for MOPITT v3 and v4 (zhe, dkh 06/2015) +!****************************************************************************** +! +!============================================================================== +! Undefine all "switches" so that they cannot be accidentally reset +!============================================================================== + +#undef TES_NH3_OBS +#undef PM_ATTAINMENT +#undef SOMO35_ATTAINMENT +#undef SCIA_KNMI_NO2_OBS +#undef IMPROVE_SO4_NIT_OBS +#undef CASTNET_NH4_OBS +#undef TES_O3_OBS +#undef TES_O3_IRK +#undef SCIA_DAL_NO2_OBS +#undef SCIA_DAL_SO2_OBS +#undef SCIA_BRE_CO_OBS +#undef AIRS_CO_OBS +#undef GOSAT_CO2_OBS +#undef PM_ATTAINMENT +#undef SOMO35_ATTAINMNET +#undef PSEUDO_OBS +#undef LOG_OPT +#undef LIDORT +#undef LBKCOV_ERR +! (xxu, dkh, 01/09/12, adj32_011) +#undef MODIS_AOD_OBS +! (yhmao, dkh, 01/13/12, adj32_013) +#undef IMPROVE_BC_OC_OBS +! (zhej, dkh, 01/16/12, adj32_016) +#undef MOPITT_V5_CO_OBS +#undef MOPITT_V6_CO_OBS +! (kjw, dkh, 02/12/12, adj32_023) +#undef TES_CH4_OBS +#undef SCIA_CH4_OBS +#undef MEM_CH4_OBS +#undef LEO_CH4_OBS +#undef GEOCAPE_CH4_OBS +#undef OSIRIS_OBS +!mkeller +#undef OMI_NO2_OBS +! ( ywang, 04/21/15) +#undef OMI_SO2_OBS + !xzhang: +#undef OMI_CH2O_OBS +#undef MLS_O3_OBS +#undef MLS_HNO3_OBS +#undef OSIRIS_NO2_OBS +#undef IASI_CO_OBS +#undef IASI_O3_OBS + +!----------CO observations------ +! pick any combination +! => MOPITT CO +! => MOPITT v5 +! => MOPITT v6 +! => MOPITT v7 +! => AIRS CO +! => SCIA Bremen CO +!#define MOPITT_V5_CO_OBS 'MOPITT_V5_CO_OBS' +!#define MOPITT_V6_CO_OBS 'MOPITT_V6_CO_OBS' +!#define MOPITT_V7_CO_OBS 'MOPITT_V7_CO_OBS' +!#define IASI_CO_OBS 'IASI_CO_OBS' +!#define AIRS_CO_OBS 'AIRS_CO_OBS' +!#define SCIA_BRE_CO_OBS 'SCIA_BRE_CO_OBS' + +!---------aerosol-related---------- +!NH3 observations +! = > TES_NH3_OBS +!SO2 observations +! => SCIA_DAL_SO2_OBS +!Aerosol observations +! => PM_ATTAINMENT +! => IMPROVE_SO4_NIT_OBS +! => IMPROVE_BC_OC_OBS +! => CASTNET_NH4_OBS +!#define TES_NH3_OBS 'TES_NH3_OBS' +!#define SCIA_DAL_SO2_OBS 'SCIA_DAL_SO2_OBS' +!#define PM_ATTAINMENT 'PM_ATTAINMENT' +!#define IMPROVE_SO4_NIT_OBS 'IMPROVE_SO4_NIT_OBS' +!#define IMPROVE_BC_OC_OBS 'IMPROVE_BC_OC_OBS' +!#define CASTNET_NH4_OBS 'CASTNET_NH4_OBS' +!#define MODIS_AOD_OBS 'MODIS_AOD_OBS' + +!--------ozone-related-------------- +! => SOMO35_ATTAINMENT +! => TES O3 +! => TES O3 IRKs +!#define SOMO35_ATTAINMENT 'SOMO35_ATTAINMENT' +!#define TES_O3_OBS 'TES_O3_OBS' +!#define TES_O3_IRK 'TES_O3_IRK' +!#define OSIRIS_OBS 'OSIRIS_OBS' +#define IASI_O3_OBS 'IASI_O3_OBS' + + +!-------CH4 Observations------------ +! => TES CH4 +! => SCIA CH4 +! => MEM CH4 +! => Generic LEO instrument CH4 +! => GEOCAPE CH4 +!#define TES_CH4_OBS 'TES_CH4_OBS' +!#define SCIA_CH4_OBS 'SCIA_CH4_OBS' +!#define MEM_CH4_OBS 'MEM_CH4_OBS' +!#define LEO_CH4_OBS 'LEO_CH4_OBS' +!#define GEOCAPE_CH4_OBS 'GEOCAPE_CH4_OBS' + +!-------NO2 observations------------ +! => SCIA_KNMI_NO2_OBS +! => SCIA_DAL_NO2_OBS +!#define SCIA_KNMI_NO2_OBS 'SCIA_KNMI_NO2_OBS' +!#define SCIA_DAL_NO2_OBS 'SCIA_DAL_NO2_OBS' + +!-------OMI NO2 tropospheric columns +!#define OMI_NO2_OBS 'OMI_NO2_OBS' + +!-------CO2 observations------------ +! => GOSAT_CO2_OBS +!#define GOSAT_CO2_OBS + +!-------SO2 observations------------ +! => OMI_SO2_OBS +!#define OMI_SO2_OBS 'OMI_SO2_OBS' + +!------other options----------------- +!#define PSEUDO_OBS 'PSEUDO_OBS' +!#define LOG_OPT 'LOG_OPT' +!#define LIDORT 'LIDORT' +!#define LBFGS_INV 'LBFGS_INV' +!#define LBKCOV_ERR 'LBKCOV_ERR' + +!xzhang: +!#define OMI_CH2O_OBS 'OMI_CH2O_OBS' +!#define MLS_O3_OBS 'MLS_O3_OBS' +!#define MLS_HNO3_OBS 'MLS_HNO3_OBS' +!#define OSIRIS_NO2_OBS 'OSIRIS_NO2_OBS' diff --git a/code/adjoint/directory_adj_mod.f b/code/adjoint/directory_adj_mod.f new file mode 100644 index 0000000..1dd4f6a --- /dev/null +++ b/code/adjoint/directory_adj_mod.f @@ -0,0 +1,27 @@ +!$Id: directory_adj_mod.f,v 1.2 2009/06/12 01:44:48 daven Exp $ + MODULE DIRECTORY_ADJ_MOD +! +!****************************************************************************** +! Module DIRECTORY_ADJ_MOD contains the directory path variables used by +! GEOS-CHEM adjoint code. (adj_group, 6/07/09) +! +! Module Variables: +! ============================================================================ +! (1 ) OPTDATA_DIR (CHAR*255) : Directory with necessary adj output +! (2 ) ADJTMP_DIR (CHAR*255) : Directory with temp/intermediate adj output +! (3 ) DIAGADJ_DIR (CHAR*255) : Directory with adj diagnostics +! +! NOTES: +!***************************************************************************** + + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + CHARACTER(LEN=255) :: OPTDATA_DIR + CHARACTER(LEN=255) :: ADJTMP_DIR + CHARACTER(LEN=255) :: DIAGADJ_DIR + + ! End of module + END MODULE DIRECTORY_ADJ_MOD diff --git a/code/adjoint/dust_adj_mod.f b/code/adjoint/dust_adj_mod.f new file mode 100644 index 0000000..74ab8f3 --- /dev/null +++ b/code/adjoint/dust_adj_mod.f @@ -0,0 +1,687 @@ +! $Id: dust_adj_mod.f,v 1.1 2012/03/01 22:00:26 daven Exp $ + MODULE DUST_ADJ_MOD +! +!****************************************************************************** +! Module DUST_ADJ_MOD contains arrays and routines for performing mineral +! dust adjoint simulation. Original code taken from forward model routines +! in DUST_MOD and modified accordingly. (xxu, 5/20/11) +! Added to adjoint standard code (xxu, dkh, 01/09/12, adj32_011) +! +! Module Variables: +! ============================================================================ +! +! Module Routines: +! ============================================================================ +! (1 ) EMISSDUST_ADJ : Driver routine for adjoint dust +! (2 ) SRC_DUST_DEAD_ADJ : Adjoint of DEAD dust emits +! (3 ) CHEMDUST_ADJ : Adjoint of DEAD dust emits +! (4 ) DRY_SETTLING_ADJ : Adjoint of dust settling +! (5 ) DRY_DEPOSITION_ADJ : Adjoint of dust dry deposition +! +! GEOS-CHEM modules referenced by "dust_mod.f" +! ============================================================================ +! (1 ) dao_mod.f : Module containing arrays for DAO met fields +! (2 ) diag_mod.f : Module containing GEOS-CHEM diagnostic arrays +! (3 ) directory_mod.f : Module containing GEOS-CHEM data & met field dirs +! (4 ) drydep_mod.f : Module containing GEOS-CHEM drydep routines +! (5 ) dust_dead_mod.f : Module containing Zender's DEAD dust routines +! (6 ) error_mod.f : Module containing I/O error and NaN check routines +! (7 ) file_mod.f : Contains file unit numbers and error checks +! (8 ) grid_mod.f : Module containing horizontal grid information +! (9 ) logical_mod.f : Module containing GEOS-CHEM logical switches +! (10) pressure_mod.f : Module containing routines to compute P(I,J,L) +! (11) time_mod.f : Module containing routines for computing time/date +! (12) tracer_mod.f : Module containing GEOS-CHEM tracer array STT etc. +! (13) tracerid_mod.f : Module containing pointers to tracers & emissions +! +! NOTES: +! (1 ) See forward model module for complete documentation. (xxu, 5/20/11) +! (2 ) Implemented the CHEMDUST_ADJ for adjoint change of dry deposition & +! settling. (dkh, 1/10/12) +! +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "dust_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: EMISSDUST_ADJ + PUBLIC :: CHEMDUST_ADJ + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE EMISSDUST_ADJ +! +!****************************************************************************** +! Subroutine EMISSDUST_ADJ is the driver routine for the adjoint of +! the mineral dust emission. (xxu, 5/20/11) +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LDEAD + USE TRACERID_MOD, ONLY : IDTDST1, IDTDST4 + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + + !================================================================ + ! EMISSDUST_ADJ begins here! + !================================================================ + + ! Check the selected dust scheme + IF ( LDEAD ) THEN + + ! Adjoint of Zender's DEAD dust source + CALL SRC_DUST_DEAD_ADJ( STT_ADJ(:,:,:,IDTDST1:IDTDST4) ) + + ELSE + + ! Adjoint of Ginoux dust source not yet supported + CALL ERROR_STOP(' Adjoint of Ginoux dust not yet supported', + & 'dust_adj_mod.f') + + ENDIF + + ! Return to calling program + END SUBROUTINE EMISSDUST_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE SRC_DUST_DEAD_ADJ( TC ) +! +!****************************************************************************** +! Subroutine SRC_DUST_DEAD_ADJ is the adjoint routine for DEAD dust +! emissions. (xxu, 5/20/11) +! Based on forward model code. (tdf, bmy, 4/8/04, 1/23/07) +! +! NOTES +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : BXHEIGHT, GWETTOP, LWI + USE DAO_MOD, ONLY : SNOW, SPHU, T + USE DAO_MOD, ONLY : TS, UWND, VWND + USE DAO_MOD, ONLY : SNOMAS + USE DUST_DEAD_MOD, ONLY : GET_TIME_INVARIANT_DATA, GET_ORO + USE DUST_DEAD_MOD, ONLY : GET_MONTHLY_DATA, DST_MBL + USE DIAG_MOD, ONLY : AD06 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE FILE_MOD, ONLY : IOERROR + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE GRID_MOD, ONLY : GET_YMID_R + USE PRESSURE_MOD, ONLY : GET_PEDGE, GET_PCENTER + USE TIME_MOD, ONLY : GET_TS_EMIS, GET_MONTH + USE TIME_MOD, ONLY : GET_DAY_OF_YEAR, ITS_A_NEW_MONTH + USE TRANSFER_MOD, ONLY : TRANSFER_2D + + ! adj_group: add for emissions scale factors (xxu, 11/02/10) + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EDST1, IDADJ_EDST2 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EDST3, IDADJ_EDST4 + USE ADJ_ARRAYS_MOD, ONLY : IS_DUST_EMS_ADJ + USE DUST_MOD, ONLY : GET_SCALE_GROUP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND06 +# include "CMN_GCTM" ! g0 + + !---------------- + ! Arguments + !---------------- + REAL*8, INTENT(INOUT) :: TC(IIPAR,JJPAR,LLPAR,NDSTBIN) + + !----------------- + ! Local variables + !----------------- + + ! Scalars + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, L, N + INTEGER :: M, IOS, INC, LAT_IDX + INTEGER :: NDB, NSTEP, MM + REAL*8 :: W10M, DEN, DIAM, U_TS0 + REAL*8 :: U_TS, SRCE_P, Reynol, YMID_R + REAL*8 :: ALPHA, BETA, GAMMA, CW + REAL*8 :: DTSRCE, XTAU, P1, P2 + REAL*8 :: DOY + CHARACTER(LEN=255) :: FILENAME + + ! Arrays + INTEGER :: OROGRAPHY(IIPAR,JJPAR) + REAL*8 :: PSLON(IIPAR) ! surface pressure + REAL*8 :: PTHICK(IIPAR) ! delta P (L=1) + REAL*8 :: PMID(IIPAR) ! mid layer P (L=1) + REAL*8 :: TLON(IIPAR) ! temperature (L=1) + REAL*8 :: THLON(IIPAR) ! pot. temp. (L=1) + REAL*8 :: ULON(IIPAR) ! U-wind (L=1) + REAL*8 :: VLON(IIPAR) ! V-wind (L=1) + REAL*8 :: BHT2(IIPAR) ! half box height (L=1) + REAL*8 :: Q_H2O(IIPAR) ! specific humidity (L=1) + REAL*8 :: ORO(IIPAR) ! "orography" + REAL*8 :: SNW_HGT_LQD(IIPAR) ! equivalent snow ht. + REAL*8 :: DSRC(IIPAR,NDSTBIN) ! dust mixing ratio incr. + + !---------------- + ! Parameters + !---------------- + REAL*8, PARAMETER :: Ch_dust = 9.375d-10 + REAL*8, PARAMETER :: G = g0 * 1.D2 + REAL*8, PARAMETER :: RHOA = 1.25D-3 + REAL*8, PARAMETER :: CP = 1004.16d0 + REAL*8, PARAMETER :: RGAS = 8314.3d0 / 28.97d0 + REAL*8, PARAMETER :: AKAP = RGAS / CP + REAL*8, PARAMETER :: P1000 = 1000d0 + + ! External functions + REAL*8, EXTERNAL :: SFCWINDSQR + + !================================================================= + ! SRC_DUST_DEAD begins here! + !================================================================= + + ! DTSRCE is the emission timestep in seconds + DTSRCE = GET_TS_EMIS() * 60d0 + + ! DOY is the day of year (0-365 or 0-366) + DOY = DBLE( GET_DAY_OF_YEAR() ) + +! fwd cide: +! we don't need to read in the time invariant data again +! !================================================================= +! ! Read data fields for the DEAD model from disk +! !================================================================= +! IF ( FIRST ) THEN +! +! ! Echo info +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! WRITE( 6, 100 ) +! WRITE( 6, 110 ) +! WRITE( 6, 120 ) +! WRITE( 6, 130 ) +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! +! ! FORMAT strings +! 100 FORMAT( 'D E A D D U S T M O B I L I Z A T I O N' ) +! 110 FORMAT( 'Routines from DEAD model by Charlie Zender et al' ) +! 120 FORMAT( 'Modified for GEOS-CHEM by D. Fairlie and R. Yantosca') +! 130 FORMAT( 'Last Modification Date: 1/23/07' ) +! +! ! Read fields for DEAD that are time-invariant +! CALL GET_TIME_INVARIANT_DATA +! +! ! Reset first-time flag +! FIRST = .FALSE. +! ENDIF + + ! Read monthly data for DEAD + IF ( ITS_A_NEW_MONTH() ) THEN + CALL GET_MONTHLY_DATA + ENDIF + + ! Determine group (temporal) + MM = GET_SCALE_GROUP() + ! Print out scaling info + WRITE(6,*) ' - READ / RESCALE DUST EMISSION: use SCALE_GROUP ', MM + + !================================================================= + ! Call dust mobilization scheme + !================================================================= + + ! Make OROGRAPHY array from GEOS-CHEM LWI + CALL GET_ORO( OROGRAPHY ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, P1, P2, PTHICK, PMID, TLON ) +!$OMP+PRIVATE( THLON, ULON, VLON, BHT2, Q_H2O, ORO, SNW_HGT_LQD ) +!$OMP+PRIVATE( N, YMID_R, DSRC ) + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Loop over longitudes + DO I = 1, IIPAR + + ! Pressure [hPa] at bottom and top edge of level 1 + P1 = GET_PEDGE(I,J,1) + P2 = GET_PEDGE(I,J,2) + + ! Pressure thickness of 1st layer [Pa] + PTHICK(I) = ( P1 - P2 ) * 100d0 + + ! Pressure at midpt of surface layer [Pa] + PMID(I) = GET_PCENTER(I,J,1) * 100d0 + + ! Temperature [K] at surface layer + TLON(I) = T(I,J,1) + + ! Potential temperature [K] at surface layer + THLON(I) = TLON(I) * ( P1000 / PMID(I) )**AKAP + + ! U and V winds at surface [m/s] + ULON(I) = UWND(I,J,1) + VLON(I) = VWND(I,J,1) + + ! Half box height at surface [m] + BHT2(I) = BXHEIGHT(I,J,1) / 2.d0 + + ! Specific humidity at surface [kg H2O/kg air] + Q_H2O(I) = SPHU(I,J,1) / 1000.d0 + + ! Orography at surface + ! Ocean is 0; land is 1; ice is 2 + ORO(I) = OROGRAPHY(I,J) + + ! Snow height [m H2O] +#if defined( GEOS_5 ) || defined( GEOS_FP ) + SNW_HGT_LQD(I) = SNOMAS(I,J) +#else + SNW_HGT_LQD(I) = SNOW(I,J) / 1000d0 +#endif + ! Dust tracer and increments + DO N = 1, NDSTBIN + DSRC(I,N) = 0.0d0 + ENDDO + ENDDO + + !============================================================== + ! Call dust mobilization driver (DST_MBL) for latitude J + !============================================================== + + ! Latitude in RADIANS + YMID_R = GET_YMID_R(J) + + ! Call DEAD dust mobilization + CALL DST_MBL( DOY, BHT2, J, YMID_R, ORO, + & PTHICK, PMID, Q_H2O, DSRC, SNW_HGT_LQD, + & DTSRCE, TLON, THLON, VLON, ULON, + & FIRST, J ) + + ! Update + DO N = 1, NDSTBIN + DO I = 1, IIPAR + + ! fwd code: + !! Include dust adjoint scale factor (xxu, 11/02/10) + !IF ( LADJ_EMS .and. IS_DUST_EMS_ADJ) THEN + ! + ! IF(N==1) DSRC(I,N) = DSRC(I,N)*EMS_SF(I,J,MM,IDADJ_EDST1) + ! IF(N==2) DSRC(I,N) = DSRC(I,N)*EMS_SF(I,J,MM,IDADJ_EDST2) + ! IF(N==3) DSRC(I,N) = DSRC(I,N)*EMS_SF(I,J,MM,IDADJ_EDST3) + ! IF(N==4) DSRC(I,N) = DSRC(I,N)*EMS_SF(I,J,MM,IDADJ_EDST4) + ! + !ENDIF + ! + !! Add dust emissions into tracer array [kg] + !TC(I,J,1,N) = TC(I,J,1,N) + DSRC(I,N) + + ! adj code: + ! Include dust adjoint scale factor (xxu, 5/20/11) + IF ( LADJ_EMS .and. IS_DUST_EMS_ADJ) THEN + + IF (N==1) EMS_SF_ADJ(I,J,MM,IDADJ_EDST1) + & = EMS_SF_ADJ(I,J,MM,IDADJ_EDST1) + & + DSRC(I,N) * TC(I,J,1,N) + IF (N==2) EMS_SF_ADJ(I,J,MM,IDADJ_EDST2) + & = EMS_SF_ADJ(I,J,MM,IDADJ_EDST2) + & + DSRC(I,N) * TC(I,J,1,N) + IF (N==3) EMS_SF_ADJ(I,J,MM,IDADJ_EDST3) + & = EMS_SF_ADJ(I,J,MM,IDADJ_EDST3) + & + DSRC(I,N) * TC(I,J,1,N) + IF (N==4) EMS_SF_ADJ(I,J,MM,IDADJ_EDST4) + & = EMS_SF_ADJ(I,J,MM,IDADJ_EDST4) + & + DSRC(I,N) * TC(I,J,1,N) + + ENDIF + + ! ND19 diagnostics [kg] + IF ( ND06 > 0 ) THEN + AD06(I,J,N) = AD06(I,J,N) + DSRC(I,N) + ENDIF + ENDDO + ENDDO + + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE SRC_DUST_DEAD_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEMDUST_ADJ +! +!****************************************************************************** +! Subroutine CHEMDUST_ADJ is the adjoint of CHEMDUST. Based on the forward +! model routine (tdf, bmy, 3/30/04, 5/23/06). (dkh, 01/10/12, adj32_011) +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LDRYD, LDUST + USE DRYDEP_MOD, ONLY : DEPNAME, NUMDEP + USE TRACERID_MOD, ONLY : IDTDST1, IDTDST2, IDTDST3, IDTDST4 + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: N + + !================================================================= + ! CHEMDUST_ADJ begins here! + !================================================================= + + !================================================================= + ! Do dust settling & deposition adjoints + !================================================================= + + ! Dust deposition. + IF ( LDRYD ) THEN + ! fwd: + !CALL DRY_DEPOSITION( STT(:,:,:,IDTDST1:IDTDST4) ) + ! adj: + CALL DRY_DEPOSITION_ADJ( STT_ADJ(:,:,:,IDTDST1:IDTDST4) ) + ENDIF + + ! Dust settling + ! fwd: + !CALL DRY_SETTLING( STT(:,:,:,IDTDST1:IDTDST4) ) + ! adj: + CALL DRY_SETTLING_ADJ( STT_ADJ(:,:,:,IDTDST1:IDTDST4) ) + + ! Return to calling program + END SUBROUTINE CHEMDUST_ADJ + +!------------------------------------------------------------------------------ + SUBROUTINE DRY_SETTLING_ADJ( TC ) +! +!****************************************************************************** +! Subroutine DRY_SETTLING_ADJ computes the adjoint dry settling of dust tracers. +! +! Based on the forward model routine (tdf, bmy, 3/30/04, 10/25/05), modified +! here to calculate the adjoint (dkh, 01/10/12, adj32_011), and with taking +! out superfluous diagnostic code. +! +! Arguments as Input: +! ============================================================================ +! (1 ) TC (REAL*8) : Dust tracer adjoint array +! +! NOTES +! +!****************************************************************************** +! + USE DAO_MOD, ONLY : T, BXHEIGHT + USE DUST_MOD, ONLY : DUSTREFF, DUSTDEN + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTDST1 + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! g0 + + ! Arguments + REAL*8, INTENT(INOUT) :: TC(IIPAR,JJPAR,LLPAR,NDSTBIN) + + ! Local variables + INTEGER :: I, J, L, N + REAL*8 :: DT_SETTL, DELZ, DELZ1 + REAL*8 :: REFF, DEN, CONST + REAL*8 :: NUM, LAMDA + REAL*8 :: AREA_CM2, TC0(LLPAR) + + ! Pressure in Kpa 1 mb = 100 pa = 0.1 kPa + REAL*8 :: P + + ! Diameter of aerosol [um] + REAL*8 :: Dp + + ! Pressure * DP + REAL*8 :: PDp + + ! Temperature (K) + REAL*8 :: TEMP + + ! Slip correction factor + REAL*8 :: Slip + + ! Viscosity of air (Pa s) + REAL*8 :: Visc + + ! Settling velocity of particle (m/s) + REAL*8 :: VTS(LLPAR) + + ! Parameters + REAL*8, PARAMETER :: C1 = 0.7674D0 + REAL*8, PARAMETER :: C2 = 3.079d0 + REAL*8, PARAMETER :: C3 = 2.573D-11 + REAL*8, PARAMETER :: C4 = -1.424d0 + + !================================================================= + ! DRY_SETTLING_ADJ begins here! + !================================================================= + + ! Dust settling timestep [s] + DT_SETTL = GET_TS_CHEM() * 60d0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, DEN, REFF, DP ) +!$OMP+PRIVATE( CONST, VTS, TEMP, P, PDP, SLIP ) +!$OMP+PRIVATE( VISC, TC0, DELZ, DELZ1 ) + + ! Loop over dust bins + DO N = 1, NDSTBIN + + ! Initialize + DEN = DUSTDEN(N) + REFF = DUSTREFF(N) + DP = 2D0 * REFF * 1.D6 ! Dp [um] = particle diameter + CONST = 2D0 * DEN * REFF**2 * G0 / 9D0 + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Loop over longitudes + DO I = 1, IIPAR + + ! Initialize settling velocity + DO L = 1, LLPAR + VTS(L) = 0d0 + ENDDO + + ! Loop over levels + DO L = 1, LLPAR + + ! Get P [kPa], T [K], and P*DP + P = GET_PCENTER(I,J,L) * 0.1d0 + TEMP = T(I,J,L) + PDP = P * DP + + !===================================================== + ! # air molecule number density + ! num = P * 1d3 * 6.023d23 / (8.314 * Temp) + ! + ! # gas mean free path + ! lamda = 1.d6 / + ! & ( 1.41421 * num * 3.141592 * (3.7d-10)**2 ) + ! + ! # Slip correction + ! Slip = 1. + 2. * lamda * (1.257 + 0.4 * + ! & exp( -1.1 * Dp / (2. * lamda))) / Dp + !===================================================== + ! NOTE, Slip correction factor calculations following + ! Seinfeld, pp464 which is thought to be more + ! accurate but more computation required. + !===================================================== + + ! Slip correction factor as function of (P*dp) + SLIP = 1d0 + + & ( 15.60d0 + 7.0d0 * EXP(-0.059d0*PDP) ) / PDP + + !===================================================== + ! NOTE, Eq) 3.22 pp 50 in Hinds (Aerosol Technology) + ! which produce slip correction factor with small + ! error compared to the above with less computation. + !===================================================== + + ! Viscosity [Pa s] of air as a function of temp (K) + VISC = 1.458d-6 * (TEMP)**(1.5d0) / ( TEMP + 110.4d0 ) + + ! Settling velocity [m/s] + VTS(L) = CONST * SLIP / VISC + + ENDDO + + ! fwd: + !L = LLTROP + !DELZ = BXHEIGHT(I,J,L) + !TC(I,J,L,N) = TC(I,J,L,N) / + ! ( 1.d0 + DT_SETTL * VTS(L) / DELZ ) + ! + !DO L = LLTROP-1, 1, -1 + ! DELZ = BXHEIGHT(I,J,L) + ! DELZ1 = BXHEIGHT(I,J,L+1) + ! TC(I,J,L,N) = 1.d0 / + ! ( 1.d0 + DT_SETTL * VTS(L) / DELZ ) + ! * (TC(I,J,L,N) + DT_SETTL * VTS(L+1) / DELZ1 + ! * TC(I,J,L+1,N) ) + !ENDDO + ! adj: + + ! Save a copy of the input TC as TC0 and + ! intialize the output TC to 0 + TC0(:) = TC(I,J,:,N) + TC(I,J,1:LLTROP,N) = 0d0 + + DO L = 1, LLTROP -1 + + DELZ = BXHEIGHT(I,J,L) + DELZ1 = BXHEIGHT(I,J,L+1) + + TC(I,J,L+1,N) = 1d0 + & / ( 1.d0 + DT_SETTL * VTS(L) / DELZ ) + & * DT_SETTL * VTS(L+1) / DELZ1 + & * TC0(L) + + TC(I,J,L,N) = 1d0 + & / ( 1.d0 + DT_SETTL * VTS(L) / DELZ ) + & * TC0(L) + & + TC(I,J,L,N) + + ENDDO + + L = LLTROP + DELZ = BXHEIGHT(I,J,L) + TC(I,J,L,N) = 1d0 + & / ( 1.d0 + DT_SETTL * VTS(L) / DELZ ) + & * TC0(L) + & + TC(I,J,L,N) + + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE DRY_SETTLING_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE DRY_DEPOSITION_ADJ( TC ) +! +!****************************************************************************** +! Subroutine DRY_DEPOSITION_ADJ computes the adjoint of dust deposition. +! Deposition is linear and thus self adjoint, so we simply use the forward +! model routine (tdf, bmy, 3/30/04, 10/25/05) modified slightly to skip +! the diagnostics for efficiency (dkh, 01/10/12, adj32_011) +! +! Arguments as Input: +! ============================================================================ +! (1 ) TC (REAL*8) : Dust adjoint tracer array +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE DRYDEP_MOD, ONLY : DEPSAV + USE DUST_MOD, ONLY : IDDEP + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTDST1 + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*8, INTENT(INOUT) :: TC(IIPAR,JJPAR,LLPAR,NDSTBIN) + + ! local variables + INTEGER :: I, J, L, N + REAL*8 :: OLD, NEW, DTCHEM + + !================================================================= + ! DRY_DEPOSITION_ADJ begins here! + !================================================================= + + ! DTCHEM is the chemistry timestep in seconds + DTCHEM = GET_TS_CHEM() * 60d0 + + ! Loop over dust bins +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, N, OLD, NEW ) +!$OMP+SCHEDULE( DYNAMIC ) + + ! Loop over dust bins + DO N = 1, NDSTBIN + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Loop over longitudes + DO I = 1, IIPAR + + ! Original dust concentration at surface + OLD = TC(I,J,1,N) + + ! Dust left after dry deposition + NEW = OLD * EXP( -DEPSAV(I,J,IDDEP(N)) * DTCHEM ) + + ! Save back into STT_ADJ + TC(I,J,1,N) = NEW + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE DRY_DEPOSITION_ADJ + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE DUST_ADJ_MOD diff --git a/code/adjoint/emissions_adj_mod.f b/code/adjoint/emissions_adj_mod.f new file mode 100644 index 0000000..5f66c6a --- /dev/null +++ b/code/adjoint/emissions_adj_mod.f @@ -0,0 +1,379 @@ +! $Id: emissions_adj_mod.f,v 1.7 2012/03/04 18:37:57 daven Exp $ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !DESCRIPTION: Module EMISSIONS\_MOD is used to call the proper emissions +! subroutines for the various GEOS-CHEM simulations. (bmy, 2/11/03, 2/14/08) +!\\ +!\\ +! !INTERFACE: +! + MODULE EMISSIONS_ADJ_MOD +! +! !USES: +! + IMPLICIT NONE + PRIVATE +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: DO_EMISSIONS_ADJ +! +! !REVISION HISTORY: +! (1 ) Now references DEBUG_MSG from "error_mod.f" +! (2 ) Now references "Kr85_mod.f" (jsw, bmy, 8/20/03) +! (3 ) Now references "carbon_mod.f" and "dust_mod.f" (rjp, tdf, bmy, 4/2/04) +! (4 ) Now references "seasalt_mod.f" (rjp, bmy, bec, 4/20/04) +! (5 ) Now references "logical_mod" & "tracer_mod.f" (bmy, 7/20/04) +! (6 ) Now references "epa_nei_mod.f" and "time_mod.f" (bmy, 11/5/04) +! (7 ) Now references "emissions_mod.f" (bmy, 12/7/04) +! (8 ) Now calls EMISSSULFATE if LCRYST=T. Also read EPA/NEI emissions for +! the offline aerosol simulation. (bmy, 1/11/05) +! (9 ) Remove code for the obsolete CO-OH param simulation (bmy, 6/24/05) +! (10) Now references "co2_mod.f" (pns, bmy, 7/25/05) +! (11) Now references "emep_mod.f" (bdf, bmy, 10/1/05) +! (12) Now references "gfed2_biomass_mod.f" (bmy, 3/30/06) +! (13) Now references "bravo_mod.f" (rjp, kfb, bmy, 6/26/06) +! (14) Now references "edgar_mod.f" (avd, bmy, 7/6/06) +! (15) Now references "streets_anthro_mod.f" (yxw, bmy, 8/18/06) +! (16) Now references "h2_hd_mod.f" (lyj, phs, 9/18/07) +! (17) Now calls EMISSDR for tagged CO simulation (jaf, mak, bmy, 2/14/08) +! (18) Now references "cac_anthro_mod.f" (amv, phs, 03/11/08) +! (19) Now references "vistas_anthro_mod.f" (amv, 12/02/08) +! (20) Bug fixe : add specific calls for Streets for the grid 0.5x0.666. +! (dan, ccc, 3/11/09) +! (21) Add support for CH4 (kjw, dkh, 02/12/12, adj32_023) +!EOP + + + ! add for adjoint (dkh, 06/02/08) + REAL*8, ALLOCATABLE :: BURNEMIS_orig(:,:,:) + REAL*8, ALLOCATABLE :: BIOFUEL_orig(:,:,:) + REAL*8, ALLOCATABLE :: EMISRR_orig(:,:,:) + REAL*8, ALLOCATABLE :: EMISRRB_orig(:,:,:) + + + CONTAINS + +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ + + + + SUBROUTINE DO_EMISSIONS_ADJ +! +!****************************************************************************** +! Subroutine ADJ_DO_EMISSIONS is the driver routine which calls the appropriate +! adjoint emissions subroutine for the various GEOS-CHEM simulations. +! Currently only supported for NSRCS = 3 +! +! NOTES +! ( 1) Continued updates to v8 and CO simulation (mak, 7/1/09) +! ( 2) The approach here is that we read emissions in the adj the same way +! we do in the forward. I think we plan to replace that with storage +! in EMS_orig, but until then, we'll recompute/reread. (mak,7/1/09) +! (3 ) Now check that adjoint emissions ID #'s defined before calling +! fullchem adjoint emissions routines (dkh, 11/11/09) +! (4 ) Now call EMISSCO2_ADJ. (dkh, 05/06/10) +! (5 ) Now include dust emissions adjoint (xxu, dkh, 01/09/12, adj32_011) +!****************************************************************************** +! + ! References to F90 modules + ! these two not yet ready (mak, 7/1/09) + USE ADJ_ARRAYS_MOD, ONLY : IS_CARB_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IS_SULF_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IS_DUST_EMS_ADJ + USE CARBON_ADJ_MOD, ONLY : EMISSCARBON_ADJ + USE DUST_ADJ_MOD, ONLY : EMISSDUST_ADJ + USE ERROR_MOD, ONLY : ERROR_STOP, DEBUG_MSG + USE SULFATE_ADJ_MOD, ONLY : EMISSSULFATE_ADJ + + ! from EMISSIONS_MOD (mak, 7/1/09) + USE BIOMASS_MOD, ONLY : NBIOMAX + USE BIOMASS_MOD, ONLY : COMPUTE_BIOMASS_EMISSIONS + USE ARCTAS_SHIP_EMISS_MOD, ONLY : EMISS_ARCTAS_SHIP + USE BRAVO_MOD, ONLY : EMISS_BRAVO + USE C2H6_MOD, ONLY : EMISSC2H6 + USE CAC_ANTHRO_MOD, ONLY : EMISS_CAC_ANTHRO + USE CAC_ANTHRO_MOD, ONLY : EMISS_CAC_ANTHRO_05x0666 + USE CARBON_MOD, ONLY : EMISSCARBON + USE CH3I_MOD, ONLY : EMISSCH3I + USE CO2_ADJ_MOD, ONLY : EMISSCO2_ADJ + USE DUST_MOD, ONLY : EMISSDUST + USE EDGAR_MOD, ONLY : EMISS_EDGAR + USE EMEP_MOD, ONLY : EMISS_EMEP + USE EMEP_MOD, ONLY : EMISS_EMEP_05x0666 + USE EPA_NEI_MOD, ONLY : EMISS_EPA_NEI + USE GLOBAL_CH4_MOD, ONLY : EMISSCH4 + USE GLOBAL_CH4_ADJ_MOD, ONLY : EMISSCH4_ADJ + USE H2_HD_MOD, ONLY : EMISS_H2_HD + USE HCN_CH3CN_MOD, ONLY : EMISS_HCN_CH3CN + USE Kr85_MOD, ONLY : EMISSKr85 + USE LOGICAL_MOD + USE RnPbBe_MOD, ONLY : EMISSRnPbBe + USE SEASALT_MOD, ONLY : EMISSSEASALT + USE STREETS_ANTHRO_MOD, ONLY : EMISS_STREETS_ANTHRO + USE STREETS_ANTHRO_MOD, ONLY : EMISS_STREETS_ANTHRO_05x0666 + USE STREETS_ANTHRO_MOD, ONLY : EMISS_STREETS_ANTHRO_025x03125 !(lzh) + USE NEI2005_ANTHRO_MOD, ONLY : EMISS_NEI2005_ANTHRO + USE NEI2005_ANTHRO_MOD, ONLY : EMISS_NEI2005_ANTHRO_05x0666 + USE NEI2008_ANTHRO_MOD, ONLY : EMISS_NEI2008_ANTHRO !(krt, 5/13/13) + USE NEI2008_ANTHRO_MOD, ONLY : EMISS_NEI2008_ANTHRO_NATIVE !krt + USE HTAP_MOD, ONLY : EMISS_HTAP + USE SULFATE_MOD, ONLY : EMISSSULFATE + USE TIME_MOD, ONLY : GET_MONTH, GET_YEAR + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH, ITS_A_NEW_YEAR + USE TRACER_MOD + USE TAGGED_CO_ADJ_MOD, ONLY : EMISS_TAGGED_CO_ADJ + USE VISTAS_ANTHRO_MOD, ONLY : EMISS_VISTAS_ANTHRO + USE ICOADS_SHIP_MOD, ONLY : EMISS_ICOADS_SHIP !(cklee,7/09/09) + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! FSCALYR + + INTEGER :: MONTH, YEAR + + !================================================================= + ! DO_EMISSIONS_ADJ begins here! + !================================================================= + + ! Get year and month + MONTH = GET_MONTH() + + ! check if emissions year differs from met field year + IF ( FSCALYR < 0 ) THEN + YEAR = GET_YEAR() + ELSE + YEAR = FSCALYR + ENDIF + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + ! haven't made these routines yet, but this is where they would go... + !IF ( LSSALT ) CALL ADJ_EMISSSEASALT + + ! Add support for dust adjoint (xxu, dkh, 01/09/12, adj32_011) + IF ( LDUST .and. IS_DUST_EMS_ADJ ) CALL EMISSDUST_ADJ + + ! Adjoint of carbon emissions + IF ( LCARB .and. IS_CARB_EMS_ADJ ) CALL EMISSCARBON_ADJ + + ! Adjoint of sulfate emissions (dkh, 11/04/09) + IF ( LSULF .and. IS_SULF_EMS_ADJ ) CALL EMISSSULFATE_ADJ + + ! Adjoint of gas-phase emissions is in setemis_adj.f + + ! (yhmao, dkh, 01/13/12, adj32_013) + ELSE IF (ITS_AN_AEROSOL_SIM()) THEN + + IF ( LCARB .and. IS_CARB_EMS_ADJ ) CALL EMISSCARBON_ADJ + + IF ( LDUST .and. IS_DUST_EMS_ADJ ) CALL EMISSDUST_ADJ + + ELSE IF ( ITS_A_TAGCO_SIM() ) THEN + + !-------------------- + ! Tagged CO + !-------------------- + + ! Read David Streets' emisisons over China / SE ASia + ! Bug fix: call every month now (pdk, phs, 3/17/09) + IF ( LSTREETS .and. ITS_A_NEW_MONTH() ) THEN +#if defined(GRID05x0666) + CALL EMISS_STREETS_ANTHRO_05x0666 !(dan) +#elif defined(GRID025x03125) + CALL EMISS_STREETS_ANTHRO_025x03125 !(lzh) +#else + CALL EMISS_STREETS_ANTHRO +#endif + ENDIF + + ! Read CAC emissions + ! Now support nested (zhej, dkh, 01/16/12, adj32_015) + IF ( LCAC .and. ITS_A_NEW_MONTH() ) THEN +#if defined( GRID05x0666 ) + CALL EMISS_CAC_ANTHRO_05x0666 +#else + CALL EMISS_CAC_ANTHRO +#endif + ENDIF + + ! Read EDGAR emissions once per month +!---------------- +! prior to 3/11/08 +! IF ( LEDGAR .and. ITS_A_NEW_MONTH() ) THEN +!---------------- + IF ( ITS_A_NEW_MONTH() ) THEN + CALL EMISS_EDGAR( YEAR, MONTH ) + ENDIF + + ! Read EPA (USA) emissions once per month + IF ( LNEI99 .and. ITS_A_NEW_MONTH() ) CALL EMISS_EPA_NEI + + ! Now support nested (zhej, dkh, 01/16/12, adj32_015) + IF ( LNEI05 .and. ITS_A_NEW_MONTH() ) THEN +#if defined( GRID05x0666 ) + CALL EMISS_EPA_NEI ! Use NEI99 biofuel, nested + CALL EMISS_NEI2005_ANTHRO_05x0666 ! Use NEI05 anthro, global +#else + CALL EMISS_EPA_NEI ! Use NEI99 biofuel, nested + CALL EMISS_NEI2005_ANTHRO ! Use NEI05 anthro, global +#endif + ENDIF + + ! Calculate NEI2008 (USA) emissions every day + IF ( LNEI08 .AND. ITS_A_NEW_MONTH() ) THEN +#if defined( GRID05x0666 ) + CALL EMISS_EPA_NEI + CALL EMISS_NEI2008_ANTHRO_NATIVE ! Use NEI08 anthro, nested +#else + CALL EMISS_NEI2008_ANTHRO ! Use NEI08 anthro, global +#endif + ENDIF + + IF (LHTAP .and. ITS_A_NEW_MONTH() ) CALL EMISS_HTAP + + ! Read BRAVO (Mexico) emissions once per year + IF ( LBRAVO .and. ITS_A_NEW_YEAR() ) CALL EMISS_BRAVO + + ! Read EMEP (Europe) emissions once per year (adj32_015) + IF ( LEMEP .and. ITS_A_NEW_MONTH() ) THEN +#if defined(GRID05x0666) + CALL EMISS_EMEP_05x0666 +#else + CALL EMISS_EMEP +#endif + ENDIF + + ! Read ICOADS ship emissions once per month !(cklee, 7/09/09) + IF (LICOADSSHIP .and. ITS_A_NEW_MONTH()) CALL EMISS_ICOADS_SHIP + + ! Now call EMISSDR for Tagged CO fossil fuel emissions, + ! so that we get the same emissions for Tagged CO as + ! we do for the full-chemistry (jaf, mak, bmy, 2/14/08) + CALL EMISSDR + + ! Emit tagged CO + CALL EMISS_TAGGED_CO_ADJ + + + ! Add support for CH4 simulation (dkh, 02/12/12, adj32_023) + ELSE IF ( ITS_A_CH4_SIM() ) THEN + + CALL EMISSCH4_ADJ + + ELSE IF ( ITS_A_TAGOX_SIM() ) THEN + + ! don't have anything for tag OX emissions adjoint yet + print*, ' warning: emissions adj for tagged OX not supported' + + ELSE IF ( ITS_A_CO2_SIM() ) THEN + + ! Emit CO2 + CALL EMISSCO2_ADJ + + ELSE + !============= we could add other simulation mode later !cs + + ! .................... + + CALL ERROR_STOP(' Other values of NSRCX not supported yet', + & ' ADJ_DO_EMISSIONS') + + ENDIF + + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG ( '### ADJ_DO_EMISSIONS: a EMISSIONS' ) + + ! Return to calling program + END SUBROUTINE DO_EMISSIONS_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_EMISSIONS_ADJ +! +!****************************************************************************** +! Subroutine INIT_EMISSIONS initializes all module arrays (dkh, 06/01/06) +! +! NOTES: +! ( 1) Replace NBIOTRCE with NBIOMAX in v8 update (I think that's equivalent) +! (mak, 7/1/09) +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE BIOMASS_MOD, ONLY : NBIOMAX + USE BIOFUEL_MOD, ONLY : NBFTRACE + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! ITLOOP + + + ! Local variables + LOGICAL, SAVE :: IS_INIT = .FALSE. + INTEGER :: AS + + !================================================================= + ! INIT_EMISSIONS begins here! + !================================================================= + + ! Return if we already allocated arrays + IF ( IS_INIT ) RETURN + + ALLOCATE( BIOFUEL_orig( NBFTRACE, IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BIOFUEL_orig' ) + BIOFUEL_orig = 0d0 + + ALLOCATE( BURNEMIS_orig( NBIOMAX, IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BURNEMIS_orig' ) + BURNEMIS_orig = 0d0 + + ! fix (dkh, 05/04/09) + !ALLOCATE( EMISRR_orig( IIPAR, JJPAR, 2:NEMPARA+NEMPARB ), STAT=AS) + ALLOCATE( EMISRR_orig( IIPAR, JJPAR, 1:NEMPARA+NEMPARB ), STAT=AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMISRR_orig' ) + EMISRR_orig = 0d0 + + ! fix (dkh, 05/04/09) + !ALLOCATE(EMISRRB_orig( IIPAR, JJPAR, 2:NEMPARA+NEMPARB ), STAT=AS) + ALLOCATE(EMISRRB_orig( IIPAR, JJPAR, 1:NEMPARA+NEMPARB ), STAT=AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMISRRB_orig' ) + EMISRRB_orig = 0d0 + + ! Reset IS_INIT + IS_INIT = .TRUE. + + ! Return to calling progam + END SUBROUTINE INIT_EMISSIONS_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_EMISSIONS +! +!****************************************************************************** +! Subroutine CLEANUP_EMISSIONS deallocates all module arrays +! (dkh, 06/01/06) +! +! NOTES: +! +!****************************************************************************** +! + !================================================================= + ! CLEANUP_EMISSIONS begins here! + !================================================================= + IF ( ALLOCATED( BIOFUEL_orig ) ) DEALLOCATE( BIOFUEL_orig ) + IF ( ALLOCATED( BURNEMIS_orig ) ) DEALLOCATE( BURNEMIS_orig ) + IF ( ALLOCATED( EMISRR_orig ) ) DEALLOCATE( EMISRR_orig ) + IF ( ALLOCATED( EMISRRB_orig ) ) DEALLOCATE( EMISRRB_orig ) + + ! Return to calling program + END SUBROUTINE CLEANUP_EMISSIONS + + + END MODULE EMISSIONS_ADJ_MOD +!EOC diff --git a/code/adjoint/fvdas_convect_adj_mod.f b/code/adjoint/fvdas_convect_adj_mod.f new file mode 100644 index 0000000..2c20362 --- /dev/null +++ b/code/adjoint/fvdas_convect_adj_mod.f @@ -0,0 +1,1322 @@ +! $Id: fvdas_convect_adj_mod.f,v 1.4 2010/07/30 23:47:04 daven Exp $ + MODULE FVDAS_CONVECT_ADJ_MOD +! +!****************************************************************************** +! Module FVDAS_CONVECT_MOD contains routines (originally from NCAR) which +! perform shallow and deep convection for the GEOS-4/fvDAS met fields. +! These routines account for shallow and deep convection, plus updrafts +! and downdrafts. (pjr, dsa, bmy, 6/26/03, 1/21/04) +! +! Module Variables: +! ============================================================================ +! (1 ) RLXCLM (LOGICAL) : Logical to relax column versus cloud triplet +! (2 ) LIMCNV (INTEGER) : Maximum CTM level for HACK convection +! (3 ) CMFTAU (REAL*8 ) : Characteristic adjustment time scale for HACK [s] +! (4 ) EPS (REAL*8 ) : A very small number [unitless] +! (5 ) GRAV (REAL*8 ) : Gravitational constant [m/s2] +! (6 ) SMALLEST (REAL*8 ) : The smallest double-precision number +! (7 ) TINYNUM (REAL*8 ) : 2 times the machine epsilon for dble-precision +! (8 ) TINYALT (REAL*8 ) : arbitrary small num used in transport estimates +! +! Module Routines: +! ============================================================================ +! (1 ) INIT_FVDAS_CONVECT : Initializes fvDAS convection scheme +! (2 ) FVDAS_CONVECT : fvDAS convection routine, called from MAIN +! (3 ) HACK_CONV : HACK convection scheme routine +! (4 ) ARCCONVTRAN : Sets up fields for ZHANG/MCFARLANE convection +! (5 ) CONVTRAN : ZHANG/MCFARLANE convection scheme routine +! (6 ) WHENFGT : Test function -- not sure what this does? +! +! GEOS-CHEM modules referenced by fvdas_convect_mod.f: +! ============================================================================ +! (1 ) pressure_mod.f : Module containing routines to compute P(I,J,L) +! +! NOTES: +! (1 ) Contains new updates for GEOS-4/fvDAS convection. Also added OpenMP +! parallel loop over latitudes in FVDAS_CONVECT. (swu, bmy, 1/21/04) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "fvdas_convect_mod.f" + !================================================================= + + ! Declare everything PRIVATE ... + PRIVATE + + ! ... except routines INIT_FVDAS_CONVECT and FVDAS_CONVECT + PUBLIC :: FVDAS_CONVECT_ADJ + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Variables + INTEGER :: LIMCNV + + ! Constants + LOGICAL, PARAMETER :: RLXCLM = .TRUE. + REAL*8, PARAMETER :: CMFTAU = 3600.d0 + REAL*8, PARAMETER :: EPS = 1.0d-13 + REAL*8, PARAMETER :: GRAV = 9.8d0 + REAL*8, PARAMETER :: SMALLEST = TINY(1D0) + REAL*8, PARAMETER :: TINYALT = 1.0d-36 + REAL*8, PARAMETER :: TINYNUM = 2*EPSILON(1D0) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE ARCONVTRAN( DP, MU, MD, EU, MUG, + & MDG, DUG, EUG, EDG, DPG, + & DSUBCLD, JTG, JBG, IDEEP, LENGATH ) +! +!****************************************************************************** +! Subroutine ARCONVTRAN sets up the convective transport using archived mass +! fluxes from the ZHANG/MCFARLANE convection scheme. The setup involves: +! (1) Gather mass flux arrays. +! (2) Calc the mass fluxes that are determined by mass balance. +! (3) Determine top and bottom of convection. +! (pjr, dsa, swu, bmy, 6/26/03, 1/21/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) DP (REAL*8 ) : Delta pressure between interfaces [Pa] Pa +! (2 ) MU (REAL*8 ) : Mass flux up [kg/m2/s]Pa/s +! (3 ) MD (REAL*8 ) : Mass flux down [kg/m2/s]Pa/s +! (4 ) EU (REAL*8 ) : Mass entraining from updraft [1/s] Pa/s +! +! Arguments as Output: +! ============================================================================ +! (5 ) MUG (REAL*8 ) : Gathered mu (lon-alt array) +! (6 ) MDG (REAL*8 ) : Gathered md (lon-alt array) +! (7 ) DUG (REAL*8 ) : Mass detraining from updraft (lon-alt array) +! (8 ) EUG (REAL*8 ) : Gathered eu (lon-alt array) +! (9 ) EDG (REAL*8 ) : Mass entraining from downdraft (lon-alt array) +! (10) DPG (REAL*8 ) : Gathered .01*dp (lon-alt array) +! (11) DSUBCLD (REAL*8 ) : Delta pressure from cloud base to sfc (lon-alt arr) +! (12) JTG (INTEGER) : Cloud top layer for columns undergoing conv. +! (13) JBG (INTEGER) : Cloud bottom layer for columns undergoing conv. +! (14) IDEEP (INTEGER) : Index of longitudes where deep conv. happens +! (15) LENGATH (INTEGER) : Length of gathered arrays +! +! NOTES: +! (1 ) Removed NSTEP from arg list; it's not used. Also zero arrays in order +! to prevent them from being filled with compiler junk for latitudes +! where no convection occurs at all. (bmy, 1/21/04) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(OUT) :: JTG(IIPAR) + INTEGER, INTENT(OUT) :: JBG(IIPAR) + INTEGER, INTENT(OUT) :: IDEEP(IIPAR) + INTEGER, INTENT(OUT) :: LENGATH + REAL*8, INTENT(IN) :: DP(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: MU(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: MD(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: EU(IIPAR,LLPAR) + REAL*8, INTENT(OUT) :: MUG(IIPAR,LLPAR) + REAL*8, INTENT(OUT) :: MDG(IIPAR,LLPAR) + REAL*8, INTENT(OUT) :: DUG(IIPAR,LLPAR) + REAL*8, INTENT(OUT) :: EUG(IIPAR,LLPAR) + REAL*8, INTENT(OUT) :: EDG(IIPAR,LLPAR) + REAL*8, INTENT(OUT) :: DPG(IIPAR,LLPAR) + REAL*8, INTENT(OUT) :: DSUBCLD(IIPAR) + + ! Local variables + INTEGER :: I, K, LENPOS + INTEGER :: INDEX(IIPAR) + REAL*8 :: SUM(IIPAR) + REAL*8 :: RDPG(IIPAR,LLPAR) + + !================================================================= + ! ARCONVTRAN begins here! + !================================================================= + + ! Initialize arrays + DPG = 0d0 + DSUBCLD = 0d0 + DUG = 0d0 + EDG = 0d0 + EUG = 0d0 + JTG = LLPAR + JBG = 1 + MDG = 0d0 + MUG = 0d0 + RDPG = 0d0 + SUM = 0d0 + + !================================================================= + ! First test if convection exists in the lon band I=1,IIPAR + !================================================================= + + ! Sum all upward mass fluxes in the longitude band I=1,IIPAR + DO K = 1, LLPAR + DO I = 1, IIPAR + SUM(I) = SUM(I) + MU(I,K) + ENDDO + ENDDO + + ! IDEEP is the index of longitudes where SUM( up mass flux ) > 0 + ! LENGATH is the # of values where SUM( up mass flux ) > 0 + CALL WHENFGT( IIPAR, SUM, 1, 0d0, IDEEP, LENGATH ) + + ! Return if there is no convection the longitude band + IF ( LENGATH == 0 ) RETURN + + !================================================================= + ! Gather input mass fluxes in places where there is convection + !================================================================= + DO K = 1, LLPAR + DO I = 1, LENGATH + DPG(I,K) = 0.01d0 * DP(IDEEP(I),K) !convert Pa->hPa + RDPG(I,K) = 1.d0 / DPG(I,K) + MUG(I,K) = MU(IDEEP(I),K) * 0.01d0 !convert Pa/s->hPa/s + MDG(I,K) = MD(IDEEP(I),K) * 0.01d0 + EUG(I,K) = EU(IDEEP(I),K) * 0.01d0 * RDPG(I,K) !convert Pa/s->1/s + ENDDO + ENDDO + + !================================================================= + ! Calc DU and ED in places where there is convection + !================================================================= + DO K = 1, LLPAR-1 + DO I = 1, LENGATH + DUG(I,K) = EUG(I,K) - ( MUG(I,K) - MUG(I,K+1) ) * RDPG(I,K) + EDG(I,K) = ( MDG(I,K) - MDG(I,K+1) ) * RDPG(I,K) + ENDDO + ENDDO + + DO I = 1, LENGATH + DUG(I,LLPAR) = EUG(I,LLPAR) - MUG(I,LLPAR) * RDPG(I,LLPAR) + EDG(I,LLPAR) = 0.0d0 + ENDDO + + DO K = 1, LLPAR + DO I = 1, LENGATH + IF ( DUG(I,K) < 1.d-7*EUG(I,K) ) DUG(I,K) = 0.0d0 + ENDDO + ENDDO + + !================================================================= + ! Find top and bottom layers with updrafts. + !================================================================= + DO I = 1, LENGATH + JTG(I) = LLPAR + JBG(I) = 1 + ENDDO + + ! Loop over altitudes + DO K = 2, LLPAR + + ! Find places in the gathered array where MUG > 0 + CALL WHENFGT( LENGATH, MUG(:,K), 1, 0D0, INDEX, LENPOS ) + + ! Compute top & bottom layers + DO I = 1, LENPOS + JTG(INDEX(I)) = MIN( K-1, JTG(INDEX(I)) ) + JBG(INDEX(I)) = MAX( K, JBG(INDEX(I)) ) + ENDDO + ENDDO + + !================================================================= + ! Calc delta p between srfc and cloud base. + !================================================================= + DO I = 1, LENGATH + DSUBCLD(I) = DPG(I,LLPAR) + ENDDO + + DO K = LLPAR-1, 2, -1 + DO I = 1, LENGATH + IF ( JBG(I) <= K ) THEN + DSUBCLD(I) = DSUBCLD(I) + DPG(I,K) + ENDIF + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE ARCONVTRAN + +!------------------------------------------------------------------------------ + + SUBROUTINE WHENFGT( N, ARRAY, INC, TARGET, INDEX, NVAL ) +! +!****************************************************************************** +! Subroutine WHENFGT examines a 1-D vector and returns both an index array +! of elements and the number of elements which are greater than a certain +! target value. This routine came with the fvDAS convection code, we just +! cleaned it up and added comments. (swu, bmy, 1/21/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) N (INTEGER) : Number of elements in ARRAY +! (2 ) ARRAY (REAL*8 ) : 1-D vector to be examined +! (3 ) INC (INTEGER) : Increment for stepping thru ARRAY +! (4 ) TARGET (REAL*8 ) : Value that ARRAY will be tested against +! +! Arguments as Output: +! ============================================================================ +! (5 ) INDEX (INTEGER) : Array of places where ARRAY(I) > TARGET +! (6 ) NVAL (INTEGER) : Number of places where ARRAY(I) > TARGET +! +! NOTES: +! (1 ) Updated comments. Now use F90 style declarations. (bmy, 1/21/04) +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: N, INC + REAL*8, INTENT(IN) :: ARRAY(N), TARGET + INTEGER, INTENT(OUT) :: INDEX(N), NVAL + + ! Local variables + INTEGER :: I, INA + + !================================================================= + ! WHENFGT begins here! + !================================================================= + + ! Initialize + INA = 1 + NVAL = 0 + INDEX(:) = 0 + + ! Loop thru the array + DO I = 1, N + + ! If the current element of ARRAY is greater than TARGET, + ! then increment NVAL and save the element # in INDEX + IF ( ARRAY(INA) > TARGET ) THEN + NVAL = NVAL + 1 + INDEX(NVAL) = I + ENDIF + + ! Skip ahead by INC elements + INA = INA + INC + ENDDO + + ! Return to calling program + END SUBROUTINE WHENFGT + +!------------------------------------------------------------------------------ + + SUBROUTINE FVDAS_CONVECT_ADJ( TDT, NTRACE, Q, RPDEL, ETA, + & BETA, MU, MD, EU, DP, + & NSTEP, FRACIS, TCVV, INDEXSOL, ADQ ) +! +!****************************************************************************** + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: NSTEP, NTRACE + INTEGER, INTENT(IN) :: INDEXSOL(NTRACE) + REAL*8, INTENT(IN) :: TDT + ! CHK_STT_CONV is only REAL*4 (dkh, 09/15/08) + !REAL*8, INTENT(INOUT) :: Q(IIPAR,JJPAR,LLPAR,NTRACE) + REAL*4, INTENT(INOUT) :: Q(IIPAR,JJPAR,LLPAR,NTRACE) + REAL*8, INTENT(INOUT) :: ADQ(IIPAR,JJPAR,LLPAR,NTRACE) + REAL*8, INTENT(IN) :: RPDEL(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: ETA(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: BETA(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: MU(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: MD(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: EU(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: DP(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: FRACIS(IIPAR,JJPAR,LLPAR,NTRACE) + REAL*8, INTENT(IN) :: TCVV(NTRACE) + + ! Local variables + INTEGER :: I, J, L, N + INTEGER :: LENGATH, ISTEP + INTEGER :: JT(IIPAR) + INTEGER :: MX(IIPAR) + INTEGER :: IDEEP(IIPAR) + REAL*8 :: DSUBCLD(IIPAR) + REAL*8 :: DPG(IIPAR,LLPAR) + REAL*8 :: DUG(IIPAR,LLPAR) + REAL*8 :: EDG(IIPAR,LLPAR) + REAL*8 :: EUG(IIPAR,LLPAR) + REAL*8 :: MDG(IIPAR,LLPAR) + REAL*8 :: MUG(IIPAR,LLPAR) + REAL*8 :: QTMP(IIPAR,LLPAR,NTRACE) + REAL*8 :: FTMP(IIPAR,LLPAR,NTRACE) + + integer ip1,ip2,ip3 + double precision adqtmp(iipar,llpar,ntrace) + +c!========================================================== + +! mak has reinstated OMP statements here, but still sees big +! differences between parallel and sequential. Need to investigate +! further (dkh, 01/06/10) +! BUG FIX: also declase QTMP and FTMP thread private (dkh, 07/30/10). +! This fixes the discrepancies noted in comment above. +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, ISTEP, ADQTMP, MUG, MDG ) +!$OMP+PRIVATE( DUG, EUG, EDG, DPG, DSUBCLD, JT, MX, IDEEP, LENGATH ) +!$OMP+PRIVATE( QTMP, FTMP ) +!$OMP+SCHEDULE( DYNAMIC ) + + ! Loop over latitudes + DO J = JJPAR,1,-1 + + ! Save lat slices of Q & FRACIS into QTMP & FTMP + DO N = 1, NTRACE + DO L = 1, LLPAR + DO I = 1, IIPAR + ADQTMP(I,L,N) = ADQ(I,J,L,N) + QTMP(I,L,N) = Q(I,J,L,N) + FTMP(I,L,N) = FRACIS(I,J,L,N) + ENDDO + ENDDO + ENDDO + + ! Gather mass flux arrays, compute mass fluxes, and determine top + ! and bottom of Z&M convection. LENGATH = # of longitudes in the + ! band I=1,IIPAR where deep convection happens at latitude J. + CALL ARCONVTRAN( DP(:,J,:), MU(:,J,:), MD(:,J,:), + & EU(:,J,:), MUG, MDG, + & DUG, EUG, EDG, + & DPG, DSUBCLD, JT, + & MX, IDEEP, LENGATH ) + + ! Loop over internal convection timestep + + DO ISTEP = NSTEP, 1, -1 + + CALL HACK_CONV_ADJ( TDT, RPDEL(:,J,:), ETA(:,J,:), + & BETA(:,J,:), NTRACE, QTMP, ADQTMP ) + + + IF ( LENGATH > 0 ) THEN + + ! Only call CONVTRAN where convection happens + ! (i.e. at latitudes where LENGATH > 0) + CALL CONVTRAN_ADJ( NTRACE, QTMP, MUG, MDG, + & DUG, EUG, EDG, DPG, + & DSUBCLD, JT, MX, IDEEP, + & 1, LENGATH, NSTEP, 0.5D0*TDT, + & FTMP, TCVV, INDEXSOL, J, + & ADQTMP ) + ENDIF + + ENDDO + + ! Save latitude slice QTMP back into global Q array + DO N = 1, NTRACE + DO L = 1, LLPAR + DO I = 1, IIPAR + ADQ(I,J,L,N) = ADQTMP(I,L,N) + ENDDO + ENDDO + ENDDO + + ENDDO +!$OMP END PARALLEL DO + +c!========================================================== + + ! Return to calling program + END SUBROUTINE FVDAS_CONVECT_ADJ + +!----------------------------------------------------------------------- +C + subroutine hack_conv_adj( tdt, rpdel, eta, beta, ntrace, q, adq ) +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + implicit none + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: NTRACE + REAL*8, INTENT(IN) :: TDT + REAL*8, INTENT(IN) :: RPDEL(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: ETA(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: BETA(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: Q(IIPAR,LLPAR,NTRACE) + REAL*8, INTENT(INOUT) :: ADQ(IIPAR,LLPAR,NTRACE) + +C============================================== +C define local variables +C============================================== + double precision tmp(iipar,llpar,ntrace) + double precision adbotflx + double precision adcmrc(iipar) + double precision adcmrh(iipar,llpar+1) + double precision addcmr1(iipar) + double precision addcmr2(iipar) + double precision addcmr3(iipar) + double precision adefac1 + double precision adefac2 + double precision adefac3 + double precision adjfac + double precision adt1 + double precision adtopflx + double precision botflx + double precision cmrc(iipar) + double precision cmrh(iipar,llpar+1) + double precision dcmr1(iipar) + double precision dcmr2(iipar) + double precision dcmr3(iipar) + double precision efac1 + double precision efac2 + double precision efac3 + double precision etagdt(iipar) + integer i + integer ii + integer ii2 + integer indx1(iipar) + integer indx1h(iipar) + integer ip1 + integer ip2 + integer k + integer k2 + integer len1 + integer m + double precision t1 + double precision temp + double precision topflx + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adbotflx = 0.d0 + do ip1 = 1, iipar + adcmrc(ip1) = 0.d0 + end do + do ip2 = 1, llpar+1 + do ip1 = 1, iipar + adcmrh(ip1,ip2) = 0.d0 + end do + end do + do ip1 = 1, iipar + addcmr1(ip1) = 0.d0 + end do + do ip1 = 1, iipar + addcmr2(ip1) = 0.d0 + end do + do ip1 = 1, iipar + addcmr3(ip1) = 0.d0 + end do + adefac1 = 0.d0 + adefac2 = 0.d0 + adefac3 = 0.d0 + adt1 = 0.d0 + adtopflx = 0.d0 + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- +C---------------------------------------------- +C FUNCTION AND TAPE COMPUTATIONS +C---------------------------------------------- + if (tdt .gt. cmftau) then + temp = tdt + else + temp = cmftau + endif + if (rlxclm) then + adjfac = tdt/temp + else + adjfac = 1.d0 + endif + +C---------------------------------------------- +C ADJOINT COMPUTATIONS +C---------------------------------------------- + do k = limcnv+1, llpar-1 + len1 = 0 + do i = 1, iipar + if (eta(i,k) .ne. 0.) then + etagdt(i) = eta(i,k)*grav*tdt*0.01d0 + len1 = len1+1 + indx1(len1) = i + else + etagdt(i) = 0.d0 + endif + end do + + if (len1 .le. 0) then + else + do m = ntrace, 1, -1 + do ii = len1, 1, -1 + i = indx1(ii) + if (q(i,k+1,m) .lt. 0. .or. q(i,k,m) .lt. 0. .or. q(i,k-1, + $m) .lt. 0.) then + else + cmrh(i,k) = 0.5d0*(q(i,k-1,m)+q(i,k,m)) + cmrh(i,k+1) = 0.5d0*(q(i,k,m)+q(i,k+1,m)) + cmrc(i) = q(i,k+1,m) + botflx = etagdt(i)*(cmrc(i)-cmrh(i,k+1))*adjfac + topflx = beta(i,k)*etagdt(i)*(cmrc(i)-cmrh(i,k))*adjfac + dcmr1(i) = -(botflx*rpdel(i,k+1)) + efac1 = 1.d0 + efac2 = 1.d0 + efac3 = 1.d0 + if (q(i,k+1,m)+dcmr1(i) .lt. 0.) then + t1 = q(i,k+1,m)/dcmr1(i) + if (t1 .lt. 0.) then + t1 = -t1 + endif + t1 = t1-eps + if (tinyalt .gt. t1) then + efac1 = tinyalt + else + efac1 = t1 + endif + endif + if (efac1 .eq. tinyalt .or. efac1 .gt. 1.) then + efac1 = 0.d0 + endif + dcmr2(i) = (efac1*botflx-topflx)*rpdel(i,k) + if (q(i,k,m)+dcmr2(i) .lt. 0.) then + t1 = q(i,k,m)/dcmr2(i) + if (t1 .lt. 0.) then + t1 = -t1 + endif + t1 = t1-eps + if (tinyalt .gt. t1) then + efac2 = tinyalt + else + efac2 = t1 + endif + endif + if (efac2 .eq. tinyalt .or. efac2 .gt. 1.) then + efac2 = 0.d0 + endif + dcmr3(i) = efac2*topflx*rpdel(i,k-1) + if (q(i,k-1,m)+dcmr3(i) .lt. 0.) then + t1 = q(i,k-1,m)/dcmr3(i) + if (t1 .lt. 0.) then + t1 = -t1 + endif + t1 = t1-eps + if (tinyalt .gt. t1) then + efac3 = tinyalt + else + efac3 = t1 + endif + endif + if (efac3 .eq. tinyalt .or. efac3 .gt. 1.) then + efac3 = 0.d0 + endif + if (efac2 .gt. efac3) then + efac3 = efac2 + endif + addcmr3(i) = addcmr3(i)+adq(i,k-1,m) + addcmr2(i) = addcmr2(i)+adq(i,k,m) + addcmr1(i) = addcmr1(i)+adq(i,k+1,m) + adefac3 = adefac3+addcmr3(i)*topflx*rpdel(i,k-1) + adtopflx = adtopflx+addcmr3(i)*efac3*rpdel(i,k-1) + addcmr3(i) = 0.d0 + adbotflx = adbotflx+addcmr2(i)*efac1*rpdel(i,k) + adefac1 = adefac1+addcmr2(i)*botflx*rpdel(i,k) + adefac3 = adefac3-addcmr2(i)*topflx*rpdel(i,k) + adtopflx = adtopflx-addcmr2(i)*efac3*rpdel(i,k) + addcmr2(i) = 0.d0 + efac3 = 1.d0 + if (q(i,k-1,m)+dcmr3(i) .lt. 0.) then + t1 = q(i,k-1,m)/dcmr3(i) + if (t1 .lt. 0.) then + t1 = -t1 + endif + t1 = t1-eps + if (tinyalt .gt. t1) then + efac3 = tinyalt + else + efac3 = t1 + endif + endif + if (efac3 .eq. tinyalt .or. efac3 .gt. 1.) then + efac3 = 0.d0 + endif + if (efac2 .gt. efac3) then + adefac2 = adefac2+adefac3 + adefac3 = 0.d0 + endif + efac3 = 1.d0 + if (q(i,k-1,m)+dcmr3(i) .lt. 0.) then + t1 = q(i,k-1,m)/dcmr3(i) + if (t1 .lt. 0.) then + t1 = -t1 + endif + t1 = t1-eps + if (tinyalt .gt. t1) then + efac3 = tinyalt + else + efac3 = t1 + endif + endif + if (efac3 .eq. tinyalt .or. efac3 .gt. 1.) then + adefac3 = 0.d0 + endif + if (q(i,k-1,m)+dcmr3(i) .lt. 0.) then + if (tinyalt .gt. t1) then + adefac3 = 0.d0 + else + adt1 = adt1+adefac3 + adefac3 = 0.d0 + endif + t1 = q(i,k-1,m)/dcmr3(i) + if (t1 .lt. 0.) then + adt1 = -adt1 + endif + addcmr3(i) = addcmr3(i)-adt1*(q(i,k-1,m)/(dcmr3(i)* + $dcmr3(i))) + adq(i,k-1,m) = adq(i,k-1,m)+adt1/dcmr3(i) + adt1 = 0.d0 + endif + adefac2 = adefac2+addcmr3(i)*topflx*rpdel(i,k-1) + adtopflx = adtopflx+addcmr3(i)*efac2*rpdel(i,k-1) + addcmr3(i) = 0.d0 + adbotflx = adbotflx+addcmr2(i)*efac1*rpdel(i,k) + adefac1 = adefac1+addcmr2(i)*botflx*rpdel(i,k) + adefac2 = adefac2-addcmr2(i)*topflx*rpdel(i,k) + adtopflx = adtopflx-addcmr2(i)*efac2*rpdel(i,k) + addcmr2(i) = 0.d0 + efac2 = 1.d0 + if (q(i,k,m)+dcmr2(i) .lt. 0.) then + t1 = q(i,k,m)/dcmr2(i) + if (t1 .lt. 0.) then + t1 = -t1 + endif + t1 = t1-eps + if (tinyalt .gt. t1) then + efac2 = tinyalt + else + efac2 = t1 + endif + endif + if (efac2 .eq. tinyalt .or. efac2 .gt. 1.) then + adefac2 = 0.d0 + endif + if (q(i,k,m)+dcmr2(i) .lt. 0.) then + if (tinyalt .gt. t1) then + adefac2 = 0.d0 + else + adt1 = adt1+adefac2 + adefac2 = 0.d0 + endif + t1 = q(i,k,m)/dcmr2(i) + if (t1 .lt. 0.) then + adt1 = -adt1 + endif + addcmr2(i) = addcmr2(i)-adt1*(q(i,k,m)/(dcmr2(i)* + $dcmr2(i))) + adq(i,k,m) = adq(i,k,m)+adt1/dcmr2(i) + adt1 = 0.d0 + endif + adbotflx = adbotflx+addcmr2(i)*efac1*rpdel(i,k) + adefac1 = adefac1+addcmr2(i)*botflx*rpdel(i,k) + adtopflx = adtopflx-addcmr2(i)*rpdel(i,k) + addcmr2(i) = 0.d0 + adbotflx = adbotflx-addcmr1(i)*efac1*rpdel(i,k+1) + adefac1 = adefac1-addcmr1(i)*botflx*rpdel(i,k+1) + addcmr1(i) = 0.d0 + efac1 = 1.d0 + if (q(i,k+1,m)+dcmr1(i) .lt. 0.) then + t1 = q(i,k+1,m)/dcmr1(i) + if (t1 .lt. 0.) then + t1 = -t1 + endif + t1 = t1-eps + if (tinyalt .gt. t1) then + efac1 = tinyalt + else + efac1 = t1 + endif + endif + if (efac1 .eq. tinyalt .or. efac1 .gt. 1.) then + adefac1 = 0.d0 + endif + if (q(i,k+1,m)+dcmr1(i) .lt. 0.) then + if (tinyalt .gt. t1) then + adefac1 = 0.d0 + else + adt1 = adt1+adefac1 + adefac1 = 0.d0 + endif + t1 = q(i,k+1,m)/dcmr1(i) + if (t1 .lt. 0.) then + adt1 = -adt1 + endif + addcmr1(i) = addcmr1(i)-adt1*(q(i,k+1,m)/(dcmr1(i)* + $dcmr1(i))) + adq(i,k+1,m) = adq(i,k+1,m)+adt1/dcmr1(i) + adt1 = 0.d0 + endif + adefac3 = 0.d0 + adefac2 = 0.d0 + adefac1 = 0.d0 + adbotflx = adbotflx-addcmr1(i)*rpdel(i,k+1) + addcmr1(i) = 0.d0 + adcmrc(i) = adcmrc(i)+adtopflx*beta(i,k)*etagdt(i)* + $adjfac + adcmrh(i,k) = adcmrh(i,k)-adtopflx*beta(i,k)*etagdt(i)* + $adjfac + adtopflx = 0.d0 + adcmrc(i) = adcmrc(i)+adbotflx*etagdt(i)*adjfac + adcmrh(i,k+1) = adcmrh(i,k+1)-adbotflx*etagdt(i)*adjfac + adbotflx = 0.d0 + adq(i,k+1,m) = adq(i,k+1,m)+adcmrc(i) + adcmrc(i) = 0.d0 + adq(i,k+1,m) = adq(i,k+1,m)+0.5d0*adcmrh(i,k+1) + adq(i,k,m) = adq(i,k,m)+0.5d0*adcmrh(i,k+1) + adcmrh(i,k+1) = 0.d0 + adq(i,k-1,m) = adq(i,k-1,m)+0.5d0*adcmrh(i,k) + adq(i,k,m) = adq(i,k,m)+0.5d0*adcmrh(i,k) + adcmrh(i,k) = 0.d0 + endif + end do + end do + endif + end do + + end subroutine hack_conv_adj + +!------------------------------------------------------------------------------ + + SUBROUTINE CONVTRAN_ADJ( NTRACE, Q, MU, MD, DU, + & EU, ED, DP, DSUBCLD, JT, + & MX, IDEEP, IL1G, IL2G, NSTEP, + & DELT, FRACIS, TCVV, INDEXSOL, LATI_INDEX, + & ADQ) +! +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND38, LD38 + + ! Arguments + INTEGER, INTENT(IN) :: NTRACE + INTEGER, INTENT(IN) :: JT(IIPAR) + INTEGER, INTENT(IN) :: MX(IIPAR) + INTEGER, INTENT(IN) :: IDEEP(IIPAR) + INTEGER, INTENT(IN) :: IL1G + INTEGER, INTENT(IN) :: IL2G + INTEGER, INTENT(IN) :: NSTEP + REAL*8, INTENT(IN) :: Q(IIPAR,LLPAR,NTRACE) + REAL*8, INTENT(INOUT) :: ADQ(IIPAR,LLPAR,NTRACE) + REAL*8, INTENT(IN) :: MU(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: MD(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: DU(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: EU(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: ED(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: DP(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: DSUBCLD(IIPAR) + REAL*8, INTENT(IN) :: DELT + REAL*8, INTENT(IN) :: FRACIS(IIPAR,LLPAR,NTRACE) + REAL*8, INTENT(IN) :: TCVV(NTRACE) + INTEGER, INTENT(IN) :: INDEXSOL(NTRACE) + INTEGER, INTENT(IN) :: LATI_INDEX + + ! Local variables + INTEGER :: I, K, KBM, KK, KKP1 + INTEGER :: KM1, KP1, KTM, M, ISTEP + INTEGER :: II, JJ, LL, NN + REAL*8 :: CABV, CBEL, CDIFR, CD2, DENOM + REAL*8 :: SMALL, MBSTH, MUPDUDP, MINC, MAXC + REAL*8 :: QN, FLUXIN, FLUXOUT, NETFLUX + REAL*8 :: CHAT(IIPAR,LLPAR) + REAL*8 :: COND(IIPAR,LLPAR) + REAL*8 :: CMIX(IIPAR,LLPAR) + REAL*8 :: FISG(IIPAR,LLPAR) + REAL*8 :: CONU(IIPAR,LLPAR) + REAL*8 :: DCONDT(IIPAR,LLPAR) + + integer ip1,ip2,m1 + real*8 adcabv + real*8 adcbel + real*8 adcdifr + real*8 adchat(iipar,llpar) + real*8 adcmix(iipar,llpar) + real*8 adcond(iipar,llpar) + real*8 adconu(iipar,llpar) + real*8 addcondt(iipar,llpar) + real*8 adfluxin + real*8 adfluxout + real*8 admaxc + real*8 adminc + real*8 adnetflux + real*8 adqn + real*8 adtmp + real*8 tmp + double precision adconuh + double precision adcondh + double precision qtmp(iipar,llpar,ntrace) + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adcabv = 0. + adcbel = 0. + adcdifr = 0. + do ip2 = 1, llpar + do ip1 = 1, iipar + adchat(ip1,ip2) = 0. + end do + end do + do ip2 = 1, llpar + do ip1 = 1, iipar + adcmix(ip1,ip2) = 0. + end do + end do + do ip2 = 1, llpar + do ip1 = 1, iipar + adcond(ip1,ip2) = 0. + end do + end do + do ip2 = 1, llpar + do ip1 = 1, iipar + adconu(ip1,ip2) = 0. + end do + end do + do ip2 = 1, llpar + do ip1 = 1, iipar + addcondt(ip1,ip2) = 0. + end do + end do + adfluxin = 0. + adfluxout = 0. + admaxc = 0. + adminc = 0. + adnetflux = 0. + adqn = 0. + adtmp = 0. + + !================================================================= + ! CONVTRAN begins here! + !================================================================= + + ! A small number + SMALL = 1.d-36 + + ! Threshold below which we treat the mass fluxes as zero (in mb/s) + MBSTH = 1.d-15 + + !================================================================= + ! Find the highest level top and bottom levels of convection + !================================================================= + KTM = LLPAR + KBM = LLPAR + DO I = IL1G, IL2G + KTM = MIN( KTM, JT(I) ) + KBM = MIN( KBM, MX(I) ) + ENDDO + + ! Loop ever each tracer + DO M = NTRACE,1,-1 + do k = 1, llpar + do i = il1g, il2g + cmix(i,k) = q(ideep(i),k,m) + if (cmix(i,k) .lt. 4.d0*smallest) then + cmix(i,k) = 0.d0 + endif + fisg(i,k) = fracis(ideep(i),k,m) + end do + end do + do k = 1, llpar + KM1 = MAX( 1, K-1 ) + do i = il1g, il2g + MINC = MIN( CMIX(I,KM1), CMIX(I,K) ) + MAXC = MAX( CMIX(I,KM1), CMIX(I,K) ) + + IF ( MINC < 0d0 ) THEN + CDIFR = 0.d0 + ELSE + CDIFR = ABS( CMIX(I,K)-CMIX(I,KM1) ) / MAX(MAXC,SMALL) + ENDIF + + IF ( CDIFR > 1.d-6 ) THEN + + ! If the two layers differ significantly. + ! use a geometric averaging procedure + CABV = MAX( CMIX(I,KM1), MAXC*TINYNUM, SMALLEST ) + CBEL = MAX( CMIX(I,K), MAXC*TINYNUM, SMALLEST ) + + CHAT(I,K) = LOG( CABV / CBEL) + & / ( CABV - CBEL) + & * CABV * CBEL + + ELSE + + ! Small diff, so just arithmetic mean + CHAT(I,K) = 0.5d0 * ( CMIX(I,K) + CMIX(I,KM1) ) + ENDIF + + conu(i,k) = chat(i,k) + cond(i,k) = chat(i,k) + dcondt(i,k) = 0.d0 + end do + end do + k = 2 + km1 = 1 + kk = llpar + do i = il1g, il2g + mupdudp = mu(i,kk)+du(i,kk)*dp(i,kk) + if (mupdudp .gt. mbsth) then + conu(i,kk) = eu(i,kk)*cmix(i,kk)*dp(i,kk)/mupdudp + endif + if (md(i,k) .lt. (-mbsth)) then + cond(i,k) = (-(ed(i,km1)*cmix(i,km1)*dp(i,km1)))/md(i,k) + endif + end do + do kk = llpar-1, 1, -1 + if (llpar .gt. kk+1) then + kkp1 = kk+1 + else + kkp1 = llpar + endif + do i = il1g, il2g + mupdudp = mu(i,kk)+du(i,kk)*dp(i,kk) + if (mupdudp .gt. mbsth) then + conu(i,kk) = (mu(i,kkp1)*conu(i,kkp1)*fisg(i,kk)+eu(i,kk)* + $cmix(i,kk)*dp(i,kk))/mupdudp + endif + end do + end do + do k = 3, llpar + KM1 = MAX( 1, K-1 ) + do i = il1g, il2g + if (md(i,k) .lt. (-mbsth)) then + cond(i,k) = (md(i,km1)*cond(i,km1)-ed(i,km1)*cmix(i,km1)* + $dp(i,km1))/md(i,k) + endif + end do + end do + do k = ktm, llpar + KM1 = MAX( 1, K-1 ) + KP1 = MIN( LLPAR, K+1 ) + do i = il1g, il2g + fluxin = mu(i,kp1)*conu(i,kp1)*fisg(i,k)+(mu(i,k)+md(i,k))* + $cmix(i,km1)-md(i,k)*cond(i,k) + fluxout = mu(i,k)*conu(i,k)+(mu(i,kp1)+md(i,kp1))*cmix(i,k)- + $md(i,kp1)*cond(i,kp1) + netflux = fluxin-fluxout + + IF ( ABS(NETFLUX) < MAX(FLUXIN,FLUXOUT)*TINYNUM) THEN + NETFLUX = 0.D0 + ENDIF + + dcondt(i,k) = netflux/dp(i,k) + end do + end do + do k = kbm, llpar + if (k-1 .gt. 1) then + km1 = k-1 + else + km1 = 1 + endif + do i = il1g, il2g + if (k .eq. mx(i)) then + fluxin = (mu(i,k)+md(i,k))*cmix(i,km1)-md(i,k)*cond(i,k) + fluxout = mu(i,k)*conu(i,k) + netflux = fluxin-fluxout + + IF ( ABS(NETFLUX) < MAX(FLUXIN,FLUXOUT)*TINYNUM) THEN + NETFLUX = 0.D0 + ENDIF + dcondt(i,k) = netflux/dp(i,k) + else if (k .gt. mx(i)) then + dcondt(i,k) = 0.d0 + endif + end do + end do + do k = 1, llpar + adqn = 0. + do i = il1g, il2g + adqn = 0. + qn = cmix(i,k)+dcondt(i,k)*delt + adqn = adqn+adq(ideep(i),k,m) + adq(ideep(i),k,m) = 0.d0 + if (qn .lt. 0.d0) then + adqn = 0. + endif + adcmix(i,k) = adcmix(i,k)+adqn + addcondt(i,k) = addcondt(i,k)+adqn*delt + adqn = 0. + end do + end do + do k = llpar, kbm, -1 + KM1 = MAX( 1, K-1 ) + do i = il2g, il1g, -1 + if (k .eq. mx(i)) then + fluxin = (mu(i,k)+md(i,k))*cmix(i,km1)-md(i,k)*cond(i,k) + fluxout = mu(i,k)*conu(i,k) + netflux = fluxin-fluxout + adnetflux = adnetflux+addcondt(i,k)/dp(i,k) + addcondt(i,k) = 0. + if (fluxin .gt. fluxout) then + if (netflux .lt. fluxin*tinynum) then + adnetflux = 0. + endif + else + if ((-netflux) .lt. fluxout*tinynum) then + adnetflux = 0. + endif + endif + adfluxin = adfluxin+adnetflux + adfluxout = adfluxout-adnetflux + adnetflux = 0. + adconu(i,k) = adconu(i,k)+adfluxout*mu(i,k) + adfluxout = 0. + adcmix(i,km1) = adcmix(i,km1)+adfluxin*(mu(i,k)+md(i,k)) + adcond(i,k) = adcond(i,k)-adfluxin*md(i,k) + adfluxin = 0. + else if (k .gt. mx(i)) then + addcondt(i,k) = 0. + endif + end do + end do + do k = ktm, llpar + adfluxin = 0. + adfluxout = 0. + adnetflux = 0. + KM1 = MAX( 1, K-1 ) + KP1 = MIN( LLPAR, K+1 ) + do i = il1g, il2g + adfluxin = 0. + adfluxout = 0. + adnetflux = 0. + fluxin = mu(i,kp1)*conu(i,kp1)*fisg(i,k)+(mu(i,k)+md(i,k))* + $cmix(i,km1)-md(i,k)*cond(i,k) + fluxout = mu(i,k)*conu(i,k)+(mu(i,kp1)+md(i,kp1))*cmix(i,k)- + $md(i,kp1)*cond(i,kp1) + netflux = fluxin-fluxout + adnetflux = adnetflux+addcondt(i,k)/dp(i,k) + addcondt(i,k) = 0. + if (fluxin .gt. fluxout) then + if (netflux .lt. fluxin*tinynum) then + adnetflux = 0. + endif + else + if ((-netflux) .lt. fluxout*tinynum) then + adnetflux = 0. + endif + endif + adfluxin = adfluxin+adnetflux + adfluxout = adfluxout-adnetflux + adnetflux = 0. + adcmix(i,k) = adcmix(i,k)+adfluxout*(mu(i,kp1)+md(i,kp1)) + adcond(i,kp1) = adcond(i,kp1)-adfluxout*md(i,kp1) + adconu(i,k) = adconu(i,k)+adfluxout*mu(i,k) + adfluxout = 0. + adcmix(i,km1) = adcmix(i,km1)+adfluxin*(mu(i,k)+md(i,k)) + adcond(i,k) = adcond(i,k)-adfluxin*md(i,k) + adconu(i,kp1) = adconu(i,kp1)+adfluxin*mu(i,kp1)*fisg(i,k) + adfluxin = 0. + end do + end do + do k = llpar, 3, -1 + KM1 = MAX( 1, K-1 ) + do i = il1g, il2g + if (md(i,k) .lt. (-mbsth)) then + adcondh = adcond(i,k) + adcond(i,k) = 0. + adcmix(i,km1) = adcmix(i,km1)-adcondh*(ed(i,km1)*dp(i,km1) + $/md(i,k)) + adcond(i,km1) = adcond(i,km1)+adcondh*(md(i,km1)/md(i,k)) + endif + end do + end do + do kk = 1, llpar-1 + if (llpar .gt. kk+1) then + kkp1 = kk+1 + else + kkp1 = llpar + endif + do i = il1g, il2g + mupdudp = mu(i,kk)+du(i,kk)*dp(i,kk) + if (mupdudp .gt. mbsth) then + adconuh = adconu(i,kk) + adconu(i,kk) = 0. + adcmix(i,kk) = adcmix(i,kk)+adconuh*(eu(i,kk)*dp(i,kk)/ + $mupdudp) + adconu(i,kkp1) = adconu(i,kkp1)+adconuh*(mu(i,kkp1)* + $fisg(i,kk)/mupdudp) + endif + end do + end do + k = 2 + km1 = 1 + kk = llpar + do i = il1g, il2g + mupdudp = mu(i,kk)+du(i,kk)*dp(i,kk) + if (md(i,k) .lt. (-mbsth)) then + adcmix(i,km1) = adcmix(i,km1)-adcond(i,k)*(ed(i,km1)*dp(i, + $km1)/md(i,k)) + adcond(i,k) = 0. + endif + if (mupdudp .gt. mbsth) then + adcmix(i,kk) = adcmix(i,kk)+adconu(i,kk)*(eu(i,kk)*dp(i,kk)/ + $mupdudp) + adconu(i,kk) = 0. + endif + end do + do k = llpar, 1, -1 + if (k-1 .gt. 1) then + km1 = k-1 + else + km1 = 1 + endif + do i = il2g, il1g, -1 + if (cmix(i,km1) .gt. cmix(i,k)) then + minc = cmix(i,k) + maxc = cmix(i,km1) + else + minc = cmix(i,km1) + maxc = cmix(i,k) + endif + if (minc .lt. 0.d0) then + cdifr = 0.d0 + else + if (maxc .gt. small) then + tmp = maxc + else + tmp = small + endif + if (cmix(i,k) .gt. cmix(i,km1)) then + cdifr = cmix(i,k)-cmix(i,km1)/tmp + else + cdifr = cmix(i,km1)-cmix(i,k)/tmp + endif + endif + addcondt(i,k) = 0. + adchat(i,k) = adchat(i,k)+adcond(i,k) + adcond(i,k) = 0. + adchat(i,k) = adchat(i,k)+adconu(i,k) + adconu(i,k) = 0. + if (cdifr .gt. 1.d-6) then + if (maxc*tinynum .gt. smallest) then + if (cmix(i,km1) .gt. maxc*tinynum) then + cabv = cmix(i,km1) + else + cabv = maxc*tinynum + endif + if (cmix(i,k) .gt. maxc*tinynum) then + cbel = cmix(i,k) + else + cbel = maxc*tinynum + endif + else + if (cmix(i,km1) .gt. smallest) then + cabv = cmix(i,km1) + else + cabv = smallest + endif + if (cmix(i,k) .gt. smallest) then + cbel = cmix(i,k) + else + cbel = smallest + endif + endif + adcabv = adcabv+adchat(i,k)*(log(cabv/cbel)/(cabv-cbel)+ + $(1./(cabv/cbel)/cbel/(cabv-cbel)-log(cabv/cbel)/((cabv-cbel)* + $(cabv-cbel)))*cabv)*cbel + adcbel = adcbel+adchat(i,k)*(log(cabv/cbel)/(cabv-cbel)* + $cabv+((-(1./(cabv/cbel)*(cabv/(cbel*cbel))/(cabv-cbel)))+log(cabv/ + $cbel)/((cabv-cbel)*(cabv-cbel)))*cabv*cbel) + adchat(i,k) = 0. + if (maxc*tinynum .gt. smallest) then + if (cmix(i,k) .gt. maxc*tinynum) then + adcmix(i,k) = adcmix(i,k)+adcbel + adcbel = 0. + else + admaxc = admaxc+adcbel*tinynum + adcbel = 0. + endif + if (cmix(i,km1) .gt. maxc*tinynum) then + adcmix(i,km1) = adcmix(i,km1)+adcabv + adcabv = 0. + else + admaxc = admaxc+adcabv*tinynum + adcabv = 0. + endif + else + if (cmix(i,k) .gt. smallest) then + adcmix(i,k) = adcmix(i,k)+adcbel + adcbel = 0. + else + adcbel = 0. + endif + if (cmix(i,km1) .gt. smallest) then + adcmix(i,km1) = adcmix(i,km1)+adcabv + adcabv = 0. + else + adcabv = 0. + endif + endif + else + adcmix(i,k) = adcmix(i,k)+0.5d0*adchat(i,k) + adcmix(i,km1) = adcmix(i,km1)+0.5d0*adchat(i,k) + adchat(i,k) = 0. + endif + if (minc .lt. 0.d0) then + adcdifr = 0. + else + if (cmix(i,k) .gt. cmix(i,km1)) then + adcmix(i,k) = adcmix(i,k)+adcdifr + adcmix(i,km1) = adcmix(i,km1)-adcdifr/tmp + adtmp = adtmp+adcdifr*(cmix(i,km1)/(tmp*tmp)) + adcdifr = 0. + else + adcmix(i,k) = adcmix(i,k)-adcdifr/tmp + adcmix(i,km1) = adcmix(i,km1)+adcdifr + adtmp = adtmp+adcdifr*(cmix(i,k)/(tmp*tmp)) + adcdifr = 0. + endif + if (maxc .gt. small) then + admaxc = admaxc+adtmp + adtmp = 0. + else + adtmp = 0. + endif + endif + if (cmix(i,km1) .gt. cmix(i,k)) then + adcmix(i,km1) = adcmix(i,km1)+admaxc + admaxc = 0. + adcmix(i,k) = adcmix(i,k)+adminc + adminc = 0. + else + adcmix(i,k) = adcmix(i,k)+admaxc + admaxc = 0. + adcmix(i,km1) = adcmix(i,km1)+adminc + adminc = 0. + endif + end do + end do + do k = 1, llpar + do i = il1g, il2g + cmix(i,k) = q(ideep(i),k,m) + if (cmix(i,k) .lt. 4.d0*smallest) then + adcmix(i,k) = 0. + endif + adq(ideep(i),k,m) = adq(ideep(i),k,m)+adcmix(i,k) + adcmix(i,k) = 0. + end do + end do + + ENDDO !M ; End of tracer loop + + ! Return to calling program + END SUBROUTINE CONVTRAN_ADJ + +!----------------------------------------------------------------------------- + + END MODULE FVDAS_CONVECT_ADJ_MOD diff --git a/code/adjoint/gckpp_adj_Function.f90 b/code/adjoint/gckpp_adj_Function.f90 new file mode 100644 index 0000000..fa4cf95 --- /dev/null +++ b/code/adjoint/gckpp_adj_Function.f90 @@ -0,0 +1,538 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! The ODE Function of Chemical Model File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Function.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_Function + + USE gckpp_adj_Parameters + IMPLICIT NONE + +! A - Rate for each equation + REAL(kind=dp) :: A(NREACT) + +! Need to declare this THREADPRIVATE for OMP parallelization (dkh, 07/28/09) +!$OMP THREADPRIVATE( A ) + +CONTAINS + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Fun - time derivatives of variables - Agregate form +! Arguments : +! V - Concentrations of variable species (local) +! F - Concentrations of fixed species (local) +! RCT - Rate constants (local) +! Vdot - Time derivative of variable species concentrations +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE Fun ( V, F, RCT, Vdot ) + +! V - Concentrations of variable species (local) + REAL(kind=dp) :: V(NVAR) +! F - Concentrations of fixed species (local) + REAL(kind=dp) :: F(NFIX) +! RCT - Rate constants (local) + REAL(kind=dp) :: RCT(NREACT) +! Vdot - Time derivative of variable species concentrations + REAL(kind=dp) :: Vdot(NVAR) + + +! Computation of equation rates + A(1) = RCT(1)*V(85)*V(89) + A(2) = RCT(2)*V(83)*V(89) + A(3) = RCT(3)*V(84)*V(89) + A(4) = RCT(4)*V(82)*V(89) + A(5) = RCT(5)*V(89)*V(90) + A(6) = RCT(6)*V(83)*V(83) + A(7) = RCT(7)*V(83)*V(83) + A(8) = RCT(8)*V(83)*V(84) + A(9) = RCT(9)*V(17)*V(83) + A(10) = RCT(10)*V(84)*V(85) + A(11) = RCT(11)*V(84)*V(84) + A(12) = RCT(12)*V(83)*F(9) + A(13) = RCT(13)*V(47)*V(83) + A(14) = RCT(14)*V(83)*F(2) + A(15) = RCT(15)*V(85)*V(90) + A(16) = RCT(16)*V(84)*V(90) + A(17) = RCT(17)*V(90)*V(90) + A(18) = RCT(18)*V(90)*V(90) + A(19) = RCT(19)*V(28)*V(83) + A(20) = RCT(20)*V(28)*V(83) + A(21) = RCT(21)*V(69)*V(83) + A(22) = RCT(22)*V(82)*V(83) + A(23) = RCT(23)*V(56)*V(83) + A(24) = RCT(24)*V(83)*V(85) + A(25) = RCT(25)*V(24)*V(83) + A(26) = RCT(26)*V(82)*V(84) + A(27) = RCT(27)*V(29) + A(28) = RCT(28)*V(29)*V(83) + A(29) = RCT(29)*V(84)*V(87) + A(30) = RCT(30)*V(85)*V(87) + A(31) = RCT(31)*V(83)*V(87) + A(32) = RCT(32)*V(82)*V(87) + A(33) = RCT(33)*V(25) + A(34) = RCT(34)*V(83)*F(11) + A(35) = RCT(35)*V(83)*F(13) + A(36) = RCT(36)*V(82)*V(87) + A(37) = RCT(37)*V(69)*V(87) + A(38) = RCT(38)*V(71)*V(83) + A(39) = RCT(39)*V(71)*V(87) + A(40) = RCT(40)*V(82)*V(86) + A(41) = RCT(41)*V(21) + A(42) = RCT(42)*V(85)*V(86) + A(43) = RCT(43)*V(23)*V(83) + A(44) = RCT(44)*V(74)*V(85) + A(45) = RCT(45)*V(16)*V(83) + A(46) = RCT(46)*V(16)*V(83) + A(47) = RCT(47)*V(52)*V(85) + A(48) = RCT(48)*V(70)*V(85) + A(49) = RCT(49)*V(22)*V(83) + A(50) = RCT(50)*V(72)*V(85) + A(51) = RCT(51)*V(72)*V(85) + A(52) = RCT(52)*V(54)*V(85) + A(53) = RCT(53)*V(62)*V(85) + A(54) = RCT(54)*V(60)*V(85) + A(55) = RCT(55)*V(79)*V(85) + A(56) = RCT(56)*V(79)*V(85) + A(57) = RCT(57)*V(57)*V(85) + A(58) = RCT(58)*V(57)*V(85) + A(59) = RCT(59)*V(66)*V(85) + A(60) = RCT(60)*V(65)*V(85) + A(61) = RCT(61)*V(64)*V(85) + A(62) = RCT(62)*V(64)*V(85) + A(63) = RCT(63)*V(59)*V(85) + A(64) = RCT(64)*V(59)*V(85) + A(65) = RCT(65)*V(51)*V(85) + A(66) = RCT(66)*V(55)*V(85) + A(67) = RCT(67)*V(53)*V(85) + A(68) = RCT(68)*V(67)*V(85) + A(69) = RCT(69)*V(63)*V(85) + A(70) = RCT(70)*V(22)*V(87) + A(71) = RCT(71)*V(73)*V(83) + A(72) = RCT(72)*V(83)*F(1) + A(73) = RCT(73)*V(68)*V(83) + A(74) = RCT(74)*V(81)*V(82) + A(75) = RCT(75)*V(18) + A(76) = RCT(76)*V(82)*V(88) + A(77) = RCT(77)*V(19) + A(78) = RCT(78)*V(78)*V(82) + A(79) = RCT(79)*V(44) + A(80) = RCT(80)*V(82)*F(5) + A(81) = RCT(81)*F(7) + A(82) = RCT(82)*V(81)*V(85) + A(83) = RCT(83)*V(85)*V(88) + A(84) = RCT(84)*V(78)*V(85) + A(85) = RCT(85)*V(85)*F(5) + A(86) = RCT(86)*V(68)*V(87) + A(87) = RCT(87)*V(49)*V(83) + A(88) = RCT(88)*V(49)*V(83) + A(89) = RCT(89)*V(52)*V(90) + A(90) = RCT(90)*V(70)*V(90) + A(91) = RCT(91)*V(72)*V(84) + A(92) = RCT(92)*V(54)*V(84) + A(93) = RCT(93)*V(62)*V(84) + A(94) = RCT(94)*V(60)*V(84) + A(95) = RCT(95)*V(79)*V(84) + A(96) = RCT(96)*V(57)*V(84) + A(97) = RCT(97)*V(66)*V(84) + A(98) = RCT(98)*V(65)*V(84) + A(99) = RCT(99)*V(64)*V(84) + A(100) = RCT(100)*V(59)*V(84) + A(101) = RCT(101)*V(51)*V(84) + A(102) = RCT(102)*V(55)*V(84) + A(103) = RCT(103)*V(53)*V(84) + A(104) = RCT(104)*V(67)*V(84) + A(105) = RCT(105)*V(63)*V(84) + A(106) = RCT(106)*V(76)*V(83) + A(107) = RCT(107)*V(74)*V(90) + A(108) = RCT(108)*V(76)*V(87) + A(109) = RCT(109)*V(72)*V(90) + A(110) = RCT(110)*V(54)*V(90) + A(111) = RCT(111)*V(62)*V(90) + A(112) = RCT(112)*V(60)*V(90) + A(113) = RCT(113)*V(79)*V(90) + A(114) = RCT(114)*V(57)*V(90) + A(115) = RCT(115)*V(66)*V(90) + A(116) = RCT(116)*V(65)*V(90) + A(117) = RCT(117)*V(64)*V(90) + A(118) = RCT(118)*V(59)*V(90) + A(119) = RCT(119)*V(51)*V(90) + A(120) = RCT(120)*V(55)*V(90) + A(121) = RCT(121)*V(53)*V(90) + A(122) = RCT(122)*V(67)*V(90) + A(123) = RCT(123)*V(63)*V(90) + A(124) = RCT(124)*V(83)*F(4) + A(125) = RCT(125)*V(83)*F(16) + A(126) = RCT(126)*V(74)*V(74) + A(127) = RCT(127)*V(74)*V(74) + A(128) = RCT(128)*V(74)*V(84) + A(129) = RCT(129)*V(52)*V(84) + A(130) = RCT(130)*V(70)*V(84) + A(131) = RCT(131)*V(84)*V(86) + A(132) = RCT(132)*V(81)*V(84) + A(133) = RCT(133)*V(84)*V(88) + A(134) = RCT(134)*V(78)*V(84) + A(135) = RCT(135)*V(84)*F(5) + A(136) = RCT(136)*V(48)*V(83) + A(137) = RCT(137)*V(48)*V(89) + A(138) = RCT(138)*V(44)*V(83) + A(139) = RCT(139)*V(44)*V(89) + A(140) = RCT(140)*V(50)*V(83) + A(141) = RCT(141)*V(48)*V(87) + A(142) = RCT(142)*V(83)*F(8) + A(143) = RCT(143)*V(75)*V(83) + A(144) = RCT(144)*V(87)*F(8) + A(145) = RCT(145)*V(75)*V(87) + A(146) = RCT(146)*V(46)*V(83) + A(147) = RCT(147)*V(77)*V(83) + A(148) = RCT(148)*V(80)*V(83) + A(149) = RCT(149)*V(61)*V(83) + A(150) = RCT(150)*V(52)*V(86) + A(151) = RCT(151)*V(70)*V(86) + A(152) = RCT(152)*V(52)*V(86) + A(153) = RCT(153)*V(70)*V(86) + A(154) = RCT(154)*V(46)*V(89) + A(155) = RCT(155)*V(77)*V(89) + A(156) = RCT(156)*V(80)*V(89) + A(157) = RCT(157)*V(46)*V(87) + A(158) = RCT(158)*V(80)*V(87) + A(159) = RCT(159)*V(80)*V(87) + A(160) = RCT(160)*V(81)*V(90) + A(161) = RCT(161)*V(88)*V(90) + A(162) = RCT(162)*V(78)*V(90) + A(163) = RCT(163)*V(90)*F(5) + A(164) = RCT(164)*V(81)*V(90) + A(165) = RCT(165)*V(88)*V(90) + A(166) = RCT(166)*V(78)*V(90) + A(167) = RCT(167)*V(90)*F(5) + A(168) = RCT(168)*V(39)*V(83) + A(169) = RCT(169)*V(38)*V(83) + A(170) = RCT(170)*V(35)*V(83) + A(171) = RCT(171)*V(31)*V(83) + A(172) = RCT(172)*V(32)*V(83) + A(173) = RCT(173)*V(30)*V(83) + A(174) = RCT(174)*V(33)*V(83) + A(175) = RCT(175)*V(37)*V(83) + A(176) = RCT(176)*V(36)*V(83) + A(177) = RCT(177)*V(83)*F(6) + A(178) = RCT(178)*V(45)*V(83) + A(179) = RCT(179)*V(41)*V(83) + A(180) = RCT(180)*V(43)*V(83) + A(181) = RCT(181)*V(42)*V(83) + A(182) = RCT(182)*V(40)*V(83) + A(183) = RCT(183)*V(26)*V(83) + A(184) = RCT(184)*V(27)*V(83) + A(185) = RCT(185)*V(23)*V(87) + A(186) = RCT(186)*V(83)*F(12) + A(187) = RCT(187)*V(58)*V(83) + A(188) = RCT(188)*V(58)*V(89) + A(189) = RCT(189)*V(86)*V(86) + A(190) = RCT(190)*V(86)*V(90) + A(191) = RCT(191)*V(86)*V(90) + A(192) = RCT(192)*V(72)*V(86) + A(193) = RCT(193)*V(62)*V(86) + A(194) = RCT(194)*V(60)*V(86) + A(195) = RCT(195)*V(79)*V(86) + A(196) = RCT(196)*V(57)*V(86) + A(197) = RCT(197)*V(66)*V(86) + A(198) = RCT(198)*V(65)*V(86) + A(199) = RCT(199)*V(64)*V(86) + A(200) = RCT(200)*V(59)*V(86) + A(201) = RCT(201)*V(53)*V(86) + A(202) = RCT(202)*V(54)*V(86) + A(203) = RCT(203)*V(51)*V(86) + A(204) = RCT(204)*V(55)*V(86) + A(205) = RCT(205)*V(67)*V(86) + A(206) = RCT(206)*V(63)*V(86) + A(207) = RCT(207)*V(72)*V(86) + A(208) = RCT(208)*V(62)*V(86) + A(209) = RCT(209)*V(60)*V(86) + A(210) = RCT(210)*V(79)*V(86) + A(211) = RCT(211)*V(57)*V(86) + A(212) = RCT(212)*V(66)*V(86) + A(213) = RCT(213)*V(64)*V(86) + A(214) = RCT(214)*V(59)*V(86) + A(215) = RCT(215)*V(54)*V(86) + A(216) = RCT(216)*V(65)*V(86) + A(217) = RCT(217)*V(51)*V(86) + A(218) = RCT(218)*V(55)*V(86) + A(219) = RCT(219)*V(67)*V(86) + A(220) = RCT(220)*V(63)*V(86) + A(221) = RCT(221)*V(53)*V(86) + A(222) = RCT(222)*V(74)*V(86) + A(223) = RCT(223)*V(74)*V(86) + A(224) = RCT(224)*V(81)*V(86) + A(225) = RCT(225)*V(86)*V(88) + A(226) = RCT(226)*V(78)*V(86) + A(227) = RCT(227)*V(86)*F(5) + A(228) = RCT(228)*V(87)*V(87) + A(229) = RCT(229)*F(3) + A(230) = RCT(230)*F(3) + A(231) = RCT(231)*F(3) + A(232) = RCT(232)*F(3) + A(233) = RCT(233)*F(3) + A(234) = RCT(234)*F(3) + A(235) = RCT(235)*F(3) + A(236) = RCT(236)*F(3) + A(237) = RCT(237)*F(3) + A(238) = RCT(238)*F(3) + A(239) = RCT(239)*F(3) + A(240) = RCT(240)*F(3) + A(241) = RCT(241)*F(3) + A(242) = RCT(242)*F(3) + A(243) = RCT(243)*V(82) + A(244) = RCT(244)*V(89) + A(245) = RCT(245)*V(21) + A(246) = RCT(246)*V(56) + A(247) = RCT(247)*V(69) + A(248) = RCT(248)*V(25) + A(249) = RCT(249)*V(17) + A(250) = RCT(250)*V(44) + A(251) = RCT(251)*V(18) + A(252) = RCT(252)*V(73) + A(253) = RCT(253)*V(84) + A(254) = RCT(254)*V(82) + A(255) = RCT(255)*V(87) + A(256) = RCT(256)*V(25) + A(257) = RCT(257)*V(34)*V(83) + A(258) = RCT(258)*V(34)*V(83) + A(259) = RCT(259)*V(34)*V(87) + A(260) = RCT(260)*V(20)*V(83) + A(261) = RCT(261)*V(89) + A(262) = RCT(262)*V(82) + A(263) = RCT(263)*V(17) + A(264) = RCT(264)*V(28) + A(265) = RCT(265)*V(69) + A(266) = RCT(266)*V(69) + A(267) = RCT(267)*V(56) + A(268) = RCT(268)*V(24) + A(269) = RCT(269)*V(29) + A(270) = RCT(270)*V(87) + A(271) = RCT(271)*V(87) + A(272) = RCT(272)*V(25) + A(273) = RCT(273)*V(25) + A(274) = RCT(274)*V(29) + A(275) = RCT(275)*V(71) + A(276) = RCT(276)*V(71) + A(277) = RCT(277)*V(21) + A(278) = RCT(278)*V(68) + A(279) = RCT(279)*V(49) + A(280) = RCT(280)*V(49) + A(281) = RCT(281)*V(76) + A(282) = RCT(282)*F(12) + A(283) = RCT(283)*V(50) + A(284) = RCT(284)*F(8) + A(285) = RCT(285)*F(8) + A(286) = RCT(286)*V(75) + A(287) = RCT(287)*V(75) + A(288) = RCT(288)*V(77) + A(289) = RCT(289)*V(77) + A(290) = RCT(290)*V(77) + A(291) = RCT(291)*V(80) + A(292) = RCT(292)*V(80) + A(293) = RCT(293)*V(61) + A(294) = RCT(294)*V(39) + A(295) = RCT(295)*V(38) + A(296) = RCT(296)*V(35) + A(297) = RCT(297)*V(31) + A(298) = RCT(298)*V(32) + A(299) = RCT(299)*V(30) + A(300) = RCT(300)*V(37) + A(301) = RCT(301)*V(33) + A(302) = RCT(302)*V(36) + A(303) = RCT(303)*F(6) + A(304) = RCT(304)*V(45) + A(305) = RCT(305)*V(41) + A(306) = RCT(306)*V(43) + A(307) = RCT(307)*V(42) + A(308) = RCT(308)*V(40) + A(309) = RCT(309)*V(26) + A(310) = RCT(310)*V(73) + A(311) = RCT(311)*V(27) + +! Aggregate function + Vdot(1) = A(247) + Vdot(2) = A(249) + Vdot(3) = A(246) + Vdot(4) = A(248) + Vdot(5) = A(243) + Vdot(6) = A(244) + Vdot(7) = A(245) + Vdot(8) = A(250) + Vdot(9) = A(251) + Vdot(10) = A(252) + Vdot(11) = A(260) + Vdot(12) = 0.25*A(258) + Vdot(13) = A(13)+A(34)+A(42)+A(72)+0.15*A(154)+0.16*A(156) + Vdot(14) = A(243)+A(244)+A(245)+A(246)+A(247)+A(248)+A(249)+A(250)+A(251)+A(252) + Vdot(15) = A(146) + Vdot(16) = -A(45)-A(46)+A(236) + Vdot(17) = A(7)-A(9)+A(11)-A(249)+0.5*A(253)-A(263) + Vdot(18) = A(74)-A(75)-A(251) + Vdot(19) = A(76)-A(77) + Vdot(20) = A(257)+0.75*A(258)+A(259)-A(260) + Vdot(21) = A(40)-A(41)-A(245)-A(277) + Vdot(22) = -A(49)-A(70)+A(232) + Vdot(23) = -A(43)-A(185)+A(237) + Vdot(24) = A(24)-A(25)+0.5*A(254)-A(268) + Vdot(25) = A(32)-A(33)-A(248)-A(256)-A(272)-A(273) + Vdot(26) = 0.7*A(134)-A(183)-A(309) + Vdot(27) = 0.41*A(131)-A(184)-A(311) + Vdot(28) = A(16)-A(19)-A(20)-A(264) + Vdot(29) = A(26)-A(27)-A(28)-A(269)-A(274) + Vdot(30) = A(91)-A(173)-A(299) + Vdot(31) = A(129)-A(171)-A(297) + Vdot(32) = A(103)-A(172)-A(298) + Vdot(33) = 0.7*A(132)-A(174)-A(301) + Vdot(34) = -A(257)-A(258)-A(259) + Vdot(35) = A(128)-A(170)-A(296) + Vdot(36) = 0.71*A(133)-A(176)-A(302) + Vdot(37) = A(130)-A(175)-A(300) + Vdot(38) = A(105)-A(169)-A(295) + Vdot(39) = A(104)-A(168)-A(294) + Vdot(40) = A(100)-A(182)-A(308) + Vdot(41) = A(97)-A(179)-A(305) + Vdot(42) = A(99)-A(181)-A(307) + Vdot(43) = A(98)+A(101)+A(102)-A(180)-A(306) + Vdot(44) = A(78)-A(79)-A(138)-A(139)-A(250) + Vdot(45) = A(95)+A(96)-A(178)-A(304) + Vdot(46) = -A(146)-A(154)-A(157)+A(233) + Vdot(47) = -A(13)+A(21)+A(37)+0.05*A(38)+0.61*A(59)+A(85)+0.33*A(115)+0.15*A(118)+0.42*A(137)+0.4*A(140)+2*A(142)& + &+A(143)+2*A(144)+A(145)+0.05*A(154)+0.05*A(155)+0.2*A(156)+A(163)+0.5*A(177)+0.4*A(188)+0.65*A(197)+0.83& + &*A(200)+A(227)+A(231)+A(265)+A(266)+A(275)+A(276)+A(278)+A(280)+A(283)+1.5*A(284)+2*A(285)+A(286)+A(287)& + &+A(288)+A(289)+A(292)+A(303)+0.67*A(305)+0.5*A(308) + Vdot(48) = -A(136)-A(137)-A(141)+0.07*A(154)+A(235)+A(288) + Vdot(49) = 0.32*A(50)+A(67)-A(87)-A(88)+0.16*A(109)+0.75*A(121)+0.5*A(172)+0.32*A(192)+A(201)+A(221)+A(234)-A(279)& + &-A(280)+A(298)+0.32*A(310) + Vdot(50) = 0.24*A(59)+0.95*A(60)+0.72*A(61)+0.6*A(65)+0.13*A(115)+0.5*A(116)+0.36*A(117)-A(140)+0.28*A(188)+0.26& + &*A(197)+A(198)+0.72*A(199)-A(283)+0.26*A(305)+0.7*A(307) + Vdot(51) = -A(65)-A(101)-A(119)-A(203)-A(217) + Vdot(52) = A(46)-A(47)+0.05*A(50)-A(89)+0.03*A(109)-A(129)-A(150)-A(152)+0.5*A(171)+0.05*A(192)+0.05*A(310) + Vdot(53) = A(45)+0.18*A(50)-A(67)-A(103)+0.09*A(109)-A(121)+0.5*A(172)+0.18*A(192)-A(201)-A(221)+0.18*A(310) + Vdot(54) = -A(52)+A(71)-A(92)-A(110)-A(202)-A(215) + Vdot(55) = -A(66)-A(102)-A(120)+A(158)-A(204)-A(218) + Vdot(56) = A(22)-A(23)+A(37)+A(39)+0.1*A(55)+A(56)+A(58)+0.08*A(59)+0.05*A(60)+A(62)+A(64)+0.1*A(65)+0.85*A(68)+A(70)& + &+A(86)+A(108)+0.425*A(122)+A(144)+A(145)+A(159)+A(185)+0.85*A(205)+A(242)-A(246)+0.5*A(254)+A(255)+2*A(256)& + &+A(259)-A(267) + Vdot(57) = -A(57)-A(58)-A(96)+0.07*A(113)-A(114)+0.136*A(195)-A(196)-A(211) + Vdot(58) = 0.34*A(55)+A(57)+0.06*A(113)+0.5*A(114)+0.509*A(178)-A(187)-A(188)+0.127*A(195)+A(196)+0.373*A(304) + Vdot(59) = -A(63)-A(64)-A(100)-A(118)+0.43*A(148)+A(182)-A(200)-A(214) + Vdot(60) = -A(54)-A(94)+A(106)+A(108)-A(112)-A(194)-A(209) + Vdot(61) = 0.33*A(59)+0.95*A(60)+A(63)+0.16*A(90)+0.2*A(111)+0.18*A(115)+0.5*A(116)+A(118)+0.59*A(138)-A(149)+0.65& + &*A(153)+0.2*A(188)+0.36*A(197)+A(198)+0.83*A(200)-A(293)+0.36*A(305)+A(308) + Vdot(62) = -A(53)+A(87)+A(88)-A(93)-A(111)-A(193)-A(208) + Vdot(63) = -A(69)-A(105)-A(123)+A(141)+A(169)-A(206)-A(220) + Vdot(64) = -A(61)-A(62)-A(99)-A(117)+A(147)+0.5*A(181)-A(199)-A(213) + Vdot(65) = -A(60)-A(98)-A(116)+0.5*A(180)-A(198)-A(216) + Vdot(66) = -A(59)-A(97)-A(115)+A(179)+0.44*A(187)-A(197)-A(212) + Vdot(67) = -A(68)-A(104)-A(122)+A(157)+A(168)-A(205)-A(219) + Vdot(68) = A(47)+0.13*A(50)+0.57*A(52)-A(73)-A(86)+0.75*A(89)+0.09*A(90)+0.07*A(109)+0.54*A(110)+0.25*A(116)+0.25& + &*A(119)+0.25*A(120)+0.25*A(122)+0.25*A(123)+A(125)+A(150)+A(152)+0.35*A(153)+0.5*A(171)+0.5*A(173)+0.5& + &*A(180)+0.5*A(181)+0.13*A(192)+0.57*A(202)+A(215)+A(216)+A(217)+A(218)+A(219)+A(220)-A(278)+A(294)+A(295)& + &+A(297)+A(299)+A(306)+0.13*A(310) + Vdot(69) = A(5)+A(15)+A(17)+2*A(18)+A(20)-A(21)+A(35)-A(37)+0.05*A(38)+A(48)+0.39*A(52)+0.96*A(53)+0.56*A(55)+0.75& + &*A(57)+0.35*A(59)+0.28*A(61)+A(63)+0.3*A(65)+A(66)+0.15*A(68)+A(69)+A(83)+A(84)+0.75*A(89)+1.25*A(90)+0.75& + &*A(107)+0.75*A(109)+0.95*A(110)+0.5*A(111)+0.75*A(112)+1.1*A(113)+1.13*A(114)+0.95*A(115)+0.75*A(116)+0.89& + &*A(117)+0.85*A(118)+1.25*A(119)+1.25*A(120)+0.75*A(121)+0.83*A(122)+1.25*A(123)+0.29*A(133)+0.535*A(137)& + &+2.23*A(138)+0.6*A(139)+A(151)+0.9*A(154)+0.8*A(155)+0.7*A(156)+A(160)+2*A(161)+2*A(162)+A(163)+A(164)& + &+A(165)+A(166)+A(167)+0.5*A(184)+A(186)+0.12*A(188)+A(190)+A(191)+0.2*A(193)+0.69*A(195)+0.75*A(196)+0.4& + &*A(197)+0.28*A(199)+0.17*A(200)+0.39*A(202)+A(203)+A(204)+0.15*A(205)+A(206)+A(225)+A(226)+A(240)-A(247)& + &+A(257)+A(259)+A(264)-A(265)-A(266)+A(282)+A(283)+0.5*A(284)+A(289)+A(292)+A(293)+A(300)+A(302)+0.627*A(304)& + &+0.3*A(307)+0.5*A(308)+A(309) + Vdot(70) = -A(48)-A(90)-A(130)+A(136)-A(151)-A(153)+A(175) + Vdot(71) = -A(38)-A(39)+A(44)+A(48)+0.32*A(50)+0.75*A(52)+0.93*A(54)+A(69)+0.5*A(90)+0.75*A(107)+0.16*A(109)+0.38& + &*A(110)+0.5*A(112)+0.5*A(123)+A(124)+2*A(126)+A(127)+0.5*A(137)+A(151)+0.04*A(155)+0.5*A(170)+0.5*A(174)& + &+0.32*A(192)+A(194)+0.75*A(202)+A(206)+A(222)+A(223)+A(239)-A(275)-A(276)+A(287)+A(296)+A(300)+A(301)+0.32& + &*A(310) + Vdot(72) = A(49)-A(50)-A(51)+0.3*A(52)+A(70)-A(91)-A(109)+0.15*A(110)+0.5*A(173)-A(192)+0.3*A(202)-A(207) + Vdot(73) = A(51)+0.04*A(53)+0.07*A(54)-A(71)+A(92)-A(252)-A(310) + Vdot(74) = A(43)-A(44)+0.32*A(50)+A(82)-A(107)+0.16*A(109)-2*A(126)-2*A(127)-A(128)+A(160)+0.5*A(170)+A(185)+0.32& + &*A(192)-A(222)-A(223)+A(224)+A(278)+0.85*A(281)+0.32*A(310) + Vdot(75) = 0.53*A(59)+0.28*A(61)+0.3*A(65)+A(66)+A(94)+0.5*A(111)+0.29*A(115)+0.14*A(117)+0.25*A(119)+0.5*A(120)& + &-A(143)-A(145)+A(149)+0.82*A(155)+0.8*A(156)+0.6*A(188)+0.8*A(193)+0.58*A(197)+0.28*A(199)+0.17*A(200)+0.5& + &*A(203)+A(204)-A(286)-A(287)+0.58*A(305)+0.3*A(307) + Vdot(76) = 0.19*A(50)-A(106)-A(108)+0.35*A(109)+0.25*A(112)+0.25*A(113)+0.25*A(114)+0.25*A(115)+0.25*A(117)+0.19& + &*A(192)+A(207)+A(208)+A(209)+A(210)+A(211)+A(212)+A(213)+A(214)+A(238)-A(281)+0.19*A(310) + Vdot(77) = 0.34*A(55)+0.05*A(68)+0.2*A(113)+0.03*A(122)-A(147)+0.159*A(154)-A(155)+0.402*A(195)+0.05*A(205)-A(288)& + &-A(289)-A(290)+0.368*A(304) + Vdot(78) = -A(78)+A(79)-A(84)-A(134)+0.57*A(148)+A(159)-A(162)-A(166)+A(183)+0.41*A(187)-A(226)+A(290)+A(291) + Vdot(79) = -A(55)-A(56)-A(95)-A(113)+A(146)+0.491*A(178)-A(195)-A(210) + Vdot(80) = 0.22*A(55)+0.1*A(68)+0.14*A(113)+0.05*A(122)-A(148)+0.387*A(154)-A(156)-A(158)-A(159)+0.288*A(195)+0.1& + &*A(205)-A(291)-A(292)+0.259*A(304) + Vdot(81) = A(73)-A(74)+A(75)-A(82)+A(86)-A(132)-A(160)-A(164)+0.5*A(174)-A(224)+0.15*A(281) + Vdot(82) = A(1)-A(4)+A(10)+A(15)-A(22)+A(25)-A(26)+A(27)+A(28)+A(29)+2*A(30)+A(31)-A(32)+A(33)-A(40)+A(41)+A(42)+A(44)& + &+A(47)+A(48)+A(50)+2*A(52)+0.96*A(53)+0.93*A(54)+0.9*A(55)+A(57)+0.92*A(59)+1.95*A(60)+A(61)+A(63)+1.9*A(65)& + &+2*A(66)+A(67)+1.15*A(68)+2*A(69)-A(74)+A(75)-A(76)+A(77)-A(78)+A(79)-A(80)+A(81)+A(82)+A(83)+A(84)+A(85)& + &+A(110)+A(116)+A(119)+A(120)+0.575*A(122)+A(123)+A(138)+A(139)+0.5*A(180)+A(186)+A(198)+A(202)+A(203)+A(204)& + &+0.15*A(205)+A(206)+A(215)+A(216)+A(217)+A(218)+A(219)+A(220)+2*A(228)+A(230)-A(243)-A(254)-A(262)+A(267)& + &+A(270)+A(272)+A(274)+0.6*A(277)+A(282)+A(294)+A(295)+A(306)+A(310) + Vdot(83) = -A(2)+A(3)-2*A(6)-2*A(7)-A(8)-A(9)+A(10)-A(12)-A(13)-A(14)-A(19)-A(21)-A(22)-A(23)-A(24)-A(25)-A(28)+A(29)& + &-A(31)-A(34)-A(35)-A(38)-A(43)-A(45)-A(46)-A(49)-A(71)-A(72)-A(73)-A(87)-A(88)-A(106)-A(124)-A(125)+0.44& + &*A(131)-A(136)+0.135*A(137)-A(138)-A(140)-A(142)-A(143)-A(146)-A(147)-A(148)-A(149)+0.27*A(154)+0.08*A(155)& + &+0.215*A(156)-A(168)-A(169)-0.5*A(170)-0.5*A(171)-0.5*A(172)-0.5*A(173)-0.5*A(174)-A(175)-A(176)-0.5*A(177)& + &-0.491*A(178)-A(179)-0.5*A(180)-0.5*A(181)-A(182)-A(183)-0.5*A(184)-A(186)-A(187)+0.1*A(188)-A(257)-A(258)& + &-A(260)+2*A(261)+2*A(263)+A(264)+A(267)+A(268)+A(269)+A(294)+A(295)+A(296)+A(297)+A(298)+A(299)+A(300)& + &+A(301)+A(302)+A(303)+A(304)+A(305)+A(306)+A(307)+A(308)+A(309)+A(311) + Vdot(84) = A(2)-A(3)+A(5)-A(8)+A(9)-A(10)-2*A(11)+A(12)+A(13)+A(15)-A(16)+2*A(18)+A(21)-A(26)+A(27)-A(29)+A(31)+A(34)& + &+A(35)+A(37)+0.05*A(38)+A(44)+A(47)+A(48)+0.27*A(50)+0.9*A(55)+A(57)+0.92*A(59)+0.05*A(60)+0.28*A(61)+A(63)& + &+0.3*A(65)+A(67)+0.8*A(68)+A(83)+A(85)+A(89)+A(90)-A(91)-A(92)-A(93)-A(94)-A(95)-A(96)-A(97)-A(98)-A(99)& + &-A(100)-A(101)-A(102)-A(103)-A(104)-A(105)+A(107)+0.64*A(109)+0.5*A(110)+0.3*A(111)+0.5*A(112)+0.92*A(113)& + &+A(114)+A(115)+0.5*A(116)+0.64*A(117)+1.15*A(118)+0.75*A(119)+0.5*A(120)+A(121)+0.45*A(122)+0.5*A(123)& + &+A(124)+A(125)+2*A(126)-A(128)-A(129)-A(130)-A(131)-A(132)-A(133)-A(134)-A(135)+0.3*A(137)+2*A(138)+A(139)& + &+0.2*A(140)+A(142)+A(144)+A(149)+A(150)+A(151)+0.06*A(154)+0.06*A(155)+0.275*A(156)+A(160)+2*A(161)+A(162)+2& + &*A(163)+0.15*A(187)+A(190)+0.27*A(192)+0.8*A(193)+0.864*A(195)+A(196)+A(197)+0.28*A(199)+A(200)+A(201)+0.5& + &*A(203)+0.8*A(205)+A(222)+A(225)+A(227)-A(253)+A(260)+A(264)+2*A(265)+A(274)+A(275)+A(278)+2*A(283)+2*A(285)& + &+A(286)+A(289)+A(291)+A(292)+A(293)+A(294)+A(295)+A(296)+A(297)+A(298)+A(299)+A(300)+A(301)+A(302)+A(303)& + &+A(304)+A(305)+A(306)+0.3*A(307)+A(308)+0.27*A(310) + Vdot(85) = -A(1)-A(10)-A(15)-A(24)-A(30)+A(36)-A(42)-A(44)-A(47)-A(48)-A(50)-A(51)-A(52)-A(53)-A(54)-A(55)-A(56)-A(57)& + &-A(58)-A(59)-A(60)-A(61)-A(62)-A(63)-A(64)-A(65)-A(66)-A(67)-A(68)-A(69)-A(82)-A(83)-A(84)-A(85)+A(229)& + &+A(262)+A(268)+A(271)+A(273) + Vdot(86) = 0.95*A(38)+A(39)-A(40)+A(41)-A(42)+0.96*A(53)+0.93*A(54)+0.72*A(61)+0.6*A(65)+A(84)+A(93)+0.3*A(111)+0.5& + &*A(112)+0.36*A(117)+0.25*A(119)-A(131)+A(143)+A(145)-A(150)-A(151)-A(152)-A(153)+A(162)+0.5*A(184)-2*A(189)& + &-A(190)-A(191)-A(192)-0.8*A(193)-A(195)-A(196)-A(197)-A(198)-0.28*A(199)-A(200)-A(201)-A(202)-0.5*A(203)& + &-A(204)-A(205)-A(206)-A(207)-A(208)-A(209)-A(210)-A(211)-A(212)-A(213)-A(214)-A(215)-A(216)-A(217)-A(218)& + &-A(219)-A(220)-A(221)-A(222)-A(223)-A(224)-A(225)-A(227)+0.6*A(277)+A(279)+0.85*A(281)+A(286)+A(289)+A(292)& + &+A(293)+0.7*A(307)+A(309) + Vdot(87) = A(4)+A(23)-A(29)-A(30)-A(31)-A(32)+A(33)-A(36)-A(37)-A(39)-A(70)-A(86)-A(108)-A(141)-A(144)-A(145)-A(157)& + &-A(158)-A(159)-A(185)-2*A(228)-A(255)-A(259)+A(269)-A(270)-A(271)+A(272)+A(273)+0.4*A(277) + Vdot(88) = -A(76)+A(77)-A(83)-A(133)+0.8*A(140)-A(161)-A(165)+A(176)-A(225) + Vdot(89) = -A(1)-A(2)-A(3)-A(4)-A(5)+A(6)+0.15*A(131)+0.3*A(132)+0.29*A(133)+0.3*A(134)+0.3*A(135)-A(137)-A(139)-0.9& + &*A(154)-0.8*A(155)-0.8*A(156)-0.7*A(188)+A(241)-A(244)-A(261)+A(262)+A(270)+A(273) + Vdot(90) = -A(5)+A(14)-A(15)-A(16)-2*A(17)-2*A(18)+A(19)+A(42)+0.18*A(50)+A(72)-A(89)-A(90)+A(93)+A(94)-A(107)-0.91& + &*A(109)-A(110)-A(111)-A(112)-A(113)-A(114)-A(115)-A(116)-A(117)-A(118)-A(119)-A(120)-A(121)-A(122)-A(123)& + &+0.44*A(131)+0.305*A(137)+A(150)+A(151)-A(160)-A(161)-A(162)-A(163)-A(164)-A(165)-A(166)-A(167)+2*A(189)& + &-A(191)+1.18*A(192)+A(193)+A(194)+A(195)+A(196)+A(197)+A(198)+A(199)+A(200)+A(201)+A(202)+A(203)+A(204)& + &+A(205)+A(206)+A(222)+A(224)+A(225)+A(226)+A(227)+A(257)+A(258)+A(259)+A(275)+0.4*A(277)+A(279)+2*A(280)& + &+0.15*A(281)+A(290)+0.18*A(310)+A(311) + +END SUBROUTINE Fun + +! End of Fun function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +END MODULE gckpp_adj_Function + diff --git a/code/adjoint/gckpp_adj_Global.f90 b/code/adjoint/gckpp_adj_Global.f90 new file mode 100644 index 0000000..bfc6506 --- /dev/null +++ b/code/adjoint/gckpp_adj_Global.f90 @@ -0,0 +1,128 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Global Data Module File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Global.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_Global + + USE gckpp_adj_Parameters, ONLY: dp, NSPEC, NVAR, NFIX, NREACT + PUBLIC + SAVE + + +! Declaration of global variables + +! C - Concentration of all species + REAL(kind=dp) :: C(NSPEC) +! VAR - Concentrations of variable species (global) + REAL(kind=dp) :: VAR(NVAR) + ! VAR - Concentrations of variable species (global) + REAL(kind=dp) :: VAR_ADJ(NVAR) + ! VAR - Concentrations of variable species (global) + REAL(kind=dp) :: V_CSPEC(NVAR) + ! VAR - Concentrations of variable species (global) + REAL(kind=dp) :: V_CSPEC_ADJ(NVAR) +! FIX - Concentrations of fixed species (global) + REAL(kind=dp) :: FIX(NFIX) +!! dkh: take this out so that VAR can be threadprivate (dkh, 07/28/09) +! VAR, FIX are chunks of array C +! EQUIVALENCE( C(1),VAR(1) ) +! EQUIVALENCE( C(91),FIX(1) ) +! RCONST - Rate constants (global) + REAL(kind=dp) :: RCONST(NREACT) +! TIME - Current integration time + REAL(kind=dp) :: TIME +! SUN - Sunlight intensity between [0,1] + REAL(kind=dp) :: SUN +! TEMP - Temperature + REAL(kind=dp) :: TEMP +! RTOLS - (scalar) Relative tolerance + REAL(kind=dp) :: RTOLS +! TSTART - Integration start time + REAL(kind=dp) :: TSTART +! TEND - Integration end time + REAL(kind=dp) :: TEND +! DT - Integration step + REAL(kind=dp) :: DT +! ATOL - Absolute tolerance + REAL(kind=dp) :: ATOL(NVAR) +! RTOL - Relative tolerance + REAL(kind=dp) :: RTOL(NVAR) +! STEPMIN - Lower bound for integration step + REAL(kind=dp) :: STEPMIN +! STEPMAX - Upper bound for integration step + REAL(kind=dp) :: STEPMAX +! CFACTOR - Conversion factor for concentration units + REAL(kind=dp) :: CFACTOR +! DDMTYPE - DDM sensitivity w.r.t.: 0=init.val., 1=params + INTEGER :: DDMTYPE + + ! INLINED global variable declarations + + ! Number of cost function being evaluated + INTEGER, PARAMETER :: NJ = 1 + + ! Total number of tropospheric grid cells + INTEGER :: NTT + + ! Total number of tropospheric grid cells + INTEGER :: JLOOP + + ! Parameter for insuring positive tracer values, same as in reader.f + REAL*8, PARAMETER :: SMAL2 = 1.0d-99 + REAL*8, PARAMETER :: SMALL2 = 1.0d-99 + + ! Modified for reaction rate sensitivity as well as emissions (tww, 05/08/12) + ! Number of reaction rate coeff adjoints + O3 dep + INTEGER, PARAMETER :: NCOEFF_EM = 15 + INTEGER, PARAMETER :: NCOEFF_RATE = 0 ! Must Match NRRATE - Max 297 (hml, 04/02/13) + INTEGER, PARAMETER :: NCOEFF = NCOEFF_EM + NCOEFF_RATE + + ! VAR_R_ADJ - Concentrations of reaction rate adjoint (global) + REAL(kind=dp) :: VAR_R_ADJ(NCOEFF) + + ! Reaction numbers for each (define in INIT_KPP) + INTEGER :: JCOEFF(NCOEFF) + INTEGER :: IND(NREACT) + + ! INLINED global variable declarations + +! Need to declare these THREADPRIVATE for OMP parallelization (dkh, 07/28/09) +!$OMP THREADPRIVATE( JLOOP ) +!$OMP THREADPRIVATE( C ) +!$OMP THREADPRIVATE( VAR ) +!$OMP THREADPRIVATE( VAR_ADJ ) +!$OMP THREADPRIVATE( FIX ) +!$OMP THREADPRIVATE( V_CSPEC ) +!$OMP THREADPRIVATE( V_CSPEC_ADJ ) +!$OMP THREADPRIVATE( TIME ) +!$OMP THREADPRIVATE( VAR_R_ADJ ) +!$OMP THREADPRIVATE( RCONST ) + +! Move stack_ptr here and make THREADPRIVATE for OMP parallelization (dkh, 07/28/09) + INTEGER :: stack_ptr = 0 ! last written entry +!$OMP THREADPRIVATE( stack_ptr ) + + INTEGER :: DMAP(NCOEFF) + +END MODULE gckpp_adj_Global + diff --git a/code/adjoint/gckpp_adj_Hessian.f90 b/code/adjoint/gckpp_adj_Hessian.f90 new file mode 100644 index 0000000..be02355 --- /dev/null +++ b/code/adjoint/gckpp_adj_Hessian.f90 @@ -0,0 +1,3190 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Hessian File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Hessian.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_Hessian + + USE gckpp_adj_Parameters + USE gckpp_adj_HessianSP + + IMPLICIT NONE + +CONTAINS + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Hessian - function for Hessian (Jac derivative w.r.t. variables) +! Arguments : +! V - Concentrations of variable species (local) +! F - Concentrations of fixed species (local) +! RCT - Rate constants (local) +! HESS - Hessian of Var (i.e. the 3-tensor d Jac / d Var) +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE Hessian ( V, F, RCT, HESS ) + +! V - Concentrations of variable species (local) + REAL(kind=dp) :: V(NVAR) +! F - Concentrations of fixed species (local) + REAL(kind=dp) :: F(NFIX) +! RCT - Rate constants (local) + REAL(kind=dp) :: RCT(NREACT) +! HESS - Hessian of Var (i.e. the 3-tensor d Jac / d Var) + REAL(kind=dp) :: HESS(NHESS) + +! -------------------------------------------------------- +! Note: HESS is represented in coordinate sparse format: +! HESS(m) = d^2 f_i / dv_j dv_k = d Jac_{i,j} / dv_k +! where i = IHESS_I(m), j = IHESS_J(m), k = IHESS_K(m). +! -------------------------------------------------------- +! Note: d^2 f_i / dv_j dv_k = d^2 f_i / dv_k dv_j, +! therefore only the terms d^2 f_i / dv_j dv_k +! with j <= k are computed and stored in HESS. +! -------------------------------------------------------- + +! Local variables +! D2A - Second derivatives of equation rates + REAL(kind=dp) :: D2A(208) + +! Computation of the second derivatives of equation rates +! D2A(1) = d^2 A(1) / dV(85)dV(89) + D2A(1) = RCT(1) +! D2A(2) = d^2 A(2) / dV(83)dV(89) + D2A(2) = RCT(2) +! D2A(3) = d^2 A(3) / dV(84)dV(89) + D2A(3) = RCT(3) +! D2A(4) = d^2 A(4) / dV(82)dV(89) + D2A(4) = RCT(4) +! D2A(5) = d^2 A(5) / dV(89)dV(90) + D2A(5) = RCT(5) +! D2A(6) = d^2 A(6)/{dV(83)dV(83)} + D2A(6) = RCT(6)*2 +! D2A(7) = d^2 A(7)/{dV(83)dV(83)} + D2A(7) = RCT(7)*2 +! D2A(8) = d^2 A(8) / dV(83)dV(84) + D2A(8) = RCT(8) +! D2A(9) = d^2 A(9) / dV(17)dV(83) + D2A(9) = RCT(9) +! D2A(10) = d^2 A(10) / dV(84)dV(85) + D2A(10) = RCT(10) +! D2A(11) = d^2 A(11)/{dV(84)dV(84)} + D2A(11) = RCT(11)*2 +! D2A(12) = d^2 A(13) / dV(47)dV(83) + D2A(12) = RCT(13) +! D2A(13) = d^2 A(15) / dV(85)dV(90) + D2A(13) = RCT(15) +! D2A(14) = d^2 A(16) / dV(84)dV(90) + D2A(14) = RCT(16) +! D2A(15) = d^2 A(17)/{dV(90)dV(90)} + D2A(15) = RCT(17)*2 +! D2A(16) = d^2 A(18)/{dV(90)dV(90)} + D2A(16) = RCT(18)*2 +! D2A(17) = d^2 A(19) / dV(28)dV(83) + D2A(17) = RCT(19) +! D2A(18) = d^2 A(20) / dV(28)dV(83) + D2A(18) = RCT(20) +! D2A(19) = d^2 A(21) / dV(69)dV(83) + D2A(19) = RCT(21) +! D2A(20) = d^2 A(22) / dV(82)dV(83) + D2A(20) = RCT(22) +! D2A(21) = d^2 A(23) / dV(56)dV(83) + D2A(21) = RCT(23) +! D2A(22) = d^2 A(24) / dV(83)dV(85) + D2A(22) = RCT(24) +! D2A(23) = d^2 A(25) / dV(24)dV(83) + D2A(23) = RCT(25) +! D2A(24) = d^2 A(26) / dV(82)dV(84) + D2A(24) = RCT(26) +! D2A(25) = d^2 A(28) / dV(29)dV(83) + D2A(25) = RCT(28) +! D2A(26) = d^2 A(29) / dV(84)dV(87) + D2A(26) = RCT(29) +! D2A(27) = d^2 A(30) / dV(85)dV(87) + D2A(27) = RCT(30) +! D2A(28) = d^2 A(31) / dV(83)dV(87) + D2A(28) = RCT(31) +! D2A(29) = d^2 A(32) / dV(82)dV(87) + D2A(29) = RCT(32) +! D2A(30) = d^2 A(36) / dV(82)dV(87) + D2A(30) = RCT(36) +! D2A(31) = d^2 A(37) / dV(69)dV(87) + D2A(31) = RCT(37) +! D2A(32) = d^2 A(38) / dV(71)dV(83) + D2A(32) = RCT(38) +! D2A(33) = d^2 A(39) / dV(71)dV(87) + D2A(33) = RCT(39) +! D2A(34) = d^2 A(40) / dV(82)dV(86) + D2A(34) = RCT(40) +! D2A(35) = d^2 A(42) / dV(85)dV(86) + D2A(35) = RCT(42) +! D2A(36) = d^2 A(43) / dV(23)dV(83) + D2A(36) = RCT(43) +! D2A(37) = d^2 A(44) / dV(74)dV(85) + D2A(37) = RCT(44) +! D2A(38) = d^2 A(45) / dV(16)dV(83) + D2A(38) = RCT(45) +! D2A(39) = d^2 A(46) / dV(16)dV(83) + D2A(39) = RCT(46) +! D2A(40) = d^2 A(47) / dV(52)dV(85) + D2A(40) = RCT(47) +! D2A(41) = d^2 A(48) / dV(70)dV(85) + D2A(41) = RCT(48) +! D2A(42) = d^2 A(49) / dV(22)dV(83) + D2A(42) = RCT(49) +! D2A(43) = d^2 A(50) / dV(72)dV(85) + D2A(43) = RCT(50) +! D2A(44) = d^2 A(51) / dV(72)dV(85) + D2A(44) = RCT(51) +! D2A(45) = d^2 A(52) / dV(54)dV(85) + D2A(45) = RCT(52) +! D2A(46) = d^2 A(53) / dV(62)dV(85) + D2A(46) = RCT(53) +! D2A(47) = d^2 A(54) / dV(60)dV(85) + D2A(47) = RCT(54) +! D2A(48) = d^2 A(55) / dV(79)dV(85) + D2A(48) = RCT(55) +! D2A(49) = d^2 A(56) / dV(79)dV(85) + D2A(49) = RCT(56) +! D2A(50) = d^2 A(57) / dV(57)dV(85) + D2A(50) = RCT(57) +! D2A(51) = d^2 A(58) / dV(57)dV(85) + D2A(51) = RCT(58) +! D2A(52) = d^2 A(59) / dV(66)dV(85) + D2A(52) = RCT(59) +! D2A(53) = d^2 A(60) / dV(65)dV(85) + D2A(53) = RCT(60) +! D2A(54) = d^2 A(61) / dV(64)dV(85) + D2A(54) = RCT(61) +! D2A(55) = d^2 A(62) / dV(64)dV(85) + D2A(55) = RCT(62) +! D2A(56) = d^2 A(63) / dV(59)dV(85) + D2A(56) = RCT(63) +! D2A(57) = d^2 A(64) / dV(59)dV(85) + D2A(57) = RCT(64) +! D2A(58) = d^2 A(65) / dV(51)dV(85) + D2A(58) = RCT(65) +! D2A(59) = d^2 A(66) / dV(55)dV(85) + D2A(59) = RCT(66) +! D2A(60) = d^2 A(67) / dV(53)dV(85) + D2A(60) = RCT(67) +! D2A(61) = d^2 A(68) / dV(67)dV(85) + D2A(61) = RCT(68) +! D2A(62) = d^2 A(69) / dV(63)dV(85) + D2A(62) = RCT(69) +! D2A(63) = d^2 A(70) / dV(22)dV(87) + D2A(63) = RCT(70) +! D2A(64) = d^2 A(71) / dV(73)dV(83) + D2A(64) = RCT(71) +! D2A(65) = d^2 A(73) / dV(68)dV(83) + D2A(65) = RCT(73) +! D2A(66) = d^2 A(74) / dV(81)dV(82) + D2A(66) = RCT(74) +! D2A(67) = d^2 A(76) / dV(82)dV(88) + D2A(67) = RCT(76) +! D2A(68) = d^2 A(78) / dV(78)dV(82) + D2A(68) = RCT(78) +! D2A(69) = d^2 A(82) / dV(81)dV(85) + D2A(69) = RCT(82) +! D2A(70) = d^2 A(83) / dV(85)dV(88) + D2A(70) = RCT(83) +! D2A(71) = d^2 A(84) / dV(78)dV(85) + D2A(71) = RCT(84) +! D2A(72) = d^2 A(86) / dV(68)dV(87) + D2A(72) = RCT(86) +! D2A(73) = d^2 A(87) / dV(49)dV(83) + D2A(73) = RCT(87) +! D2A(74) = d^2 A(88) / dV(49)dV(83) + D2A(74) = RCT(88) +! D2A(75) = d^2 A(89) / dV(52)dV(90) + D2A(75) = RCT(89) +! D2A(76) = d^2 A(90) / dV(70)dV(90) + D2A(76) = RCT(90) +! D2A(77) = d^2 A(91) / dV(72)dV(84) + D2A(77) = RCT(91) +! D2A(78) = d^2 A(92) / dV(54)dV(84) + D2A(78) = RCT(92) +! D2A(79) = d^2 A(93) / dV(62)dV(84) + D2A(79) = RCT(93) +! D2A(80) = d^2 A(94) / dV(60)dV(84) + D2A(80) = RCT(94) +! D2A(81) = d^2 A(95) / dV(79)dV(84) + D2A(81) = RCT(95) +! D2A(82) = d^2 A(96) / dV(57)dV(84) + D2A(82) = RCT(96) +! D2A(83) = d^2 A(97) / dV(66)dV(84) + D2A(83) = RCT(97) +! D2A(84) = d^2 A(98) / dV(65)dV(84) + D2A(84) = RCT(98) +! D2A(85) = d^2 A(99) / dV(64)dV(84) + D2A(85) = RCT(99) +! D2A(86) = d^2 A(100) / dV(59)dV(84) + D2A(86) = RCT(100) +! D2A(87) = d^2 A(101) / dV(51)dV(84) + D2A(87) = RCT(101) +! D2A(88) = d^2 A(102) / dV(55)dV(84) + D2A(88) = RCT(102) +! D2A(89) = d^2 A(103) / dV(53)dV(84) + D2A(89) = RCT(103) +! D2A(90) = d^2 A(104) / dV(67)dV(84) + D2A(90) = RCT(104) +! D2A(91) = d^2 A(105) / dV(63)dV(84) + D2A(91) = RCT(105) +! D2A(92) = d^2 A(106) / dV(76)dV(83) + D2A(92) = RCT(106) +! D2A(93) = d^2 A(107) / dV(74)dV(90) + D2A(93) = RCT(107) +! D2A(94) = d^2 A(108) / dV(76)dV(87) + D2A(94) = RCT(108) +! D2A(95) = d^2 A(109) / dV(72)dV(90) + D2A(95) = RCT(109) +! D2A(96) = d^2 A(110) / dV(54)dV(90) + D2A(96) = RCT(110) +! D2A(97) = d^2 A(111) / dV(62)dV(90) + D2A(97) = RCT(111) +! D2A(98) = d^2 A(112) / dV(60)dV(90) + D2A(98) = RCT(112) +! D2A(99) = d^2 A(113) / dV(79)dV(90) + D2A(99) = RCT(113) +! D2A(100) = d^2 A(114) / dV(57)dV(90) + D2A(100) = RCT(114) +! D2A(101) = d^2 A(115) / dV(66)dV(90) + D2A(101) = RCT(115) +! D2A(102) = d^2 A(116) / dV(65)dV(90) + D2A(102) = RCT(116) +! D2A(103) = d^2 A(117) / dV(64)dV(90) + D2A(103) = RCT(117) +! D2A(104) = d^2 A(118) / dV(59)dV(90) + D2A(104) = RCT(118) +! D2A(105) = d^2 A(119) / dV(51)dV(90) + D2A(105) = RCT(119) +! D2A(106) = d^2 A(120) / dV(55)dV(90) + D2A(106) = RCT(120) +! D2A(107) = d^2 A(121) / dV(53)dV(90) + D2A(107) = RCT(121) +! D2A(108) = d^2 A(122) / dV(67)dV(90) + D2A(108) = RCT(122) +! D2A(109) = d^2 A(123) / dV(63)dV(90) + D2A(109) = RCT(123) +! D2A(110) = d^2 A(126)/{dV(74)dV(74)} + D2A(110) = RCT(126)*2 +! D2A(111) = d^2 A(127)/{dV(74)dV(74)} + D2A(111) = RCT(127)*2 +! D2A(112) = d^2 A(128) / dV(74)dV(84) + D2A(112) = RCT(128) +! D2A(113) = d^2 A(129) / dV(52)dV(84) + D2A(113) = RCT(129) +! D2A(114) = d^2 A(130) / dV(70)dV(84) + D2A(114) = RCT(130) +! D2A(115) = d^2 A(131) / dV(84)dV(86) + D2A(115) = RCT(131) +! D2A(116) = d^2 A(132) / dV(81)dV(84) + D2A(116) = RCT(132) +! D2A(117) = d^2 A(133) / dV(84)dV(88) + D2A(117) = RCT(133) +! D2A(118) = d^2 A(134) / dV(78)dV(84) + D2A(118) = RCT(134) +! D2A(119) = d^2 A(136) / dV(48)dV(83) + D2A(119) = RCT(136) +! D2A(120) = d^2 A(137) / dV(48)dV(89) + D2A(120) = RCT(137) +! D2A(121) = d^2 A(138) / dV(44)dV(83) + D2A(121) = RCT(138) +! D2A(122) = d^2 A(139) / dV(44)dV(89) + D2A(122) = RCT(139) +! D2A(123) = d^2 A(140) / dV(50)dV(83) + D2A(123) = RCT(140) +! D2A(124) = d^2 A(141) / dV(48)dV(87) + D2A(124) = RCT(141) +! D2A(125) = d^2 A(143) / dV(75)dV(83) + D2A(125) = RCT(143) +! D2A(126) = d^2 A(145) / dV(75)dV(87) + D2A(126) = RCT(145) +! D2A(127) = d^2 A(146) / dV(46)dV(83) + D2A(127) = RCT(146) +! D2A(128) = d^2 A(147) / dV(77)dV(83) + D2A(128) = RCT(147) +! D2A(129) = d^2 A(148) / dV(80)dV(83) + D2A(129) = RCT(148) +! D2A(130) = d^2 A(149) / dV(61)dV(83) + D2A(130) = RCT(149) +! D2A(131) = d^2 A(150) / dV(52)dV(86) + D2A(131) = RCT(150) +! D2A(132) = d^2 A(151) / dV(70)dV(86) + D2A(132) = RCT(151) +! D2A(133) = d^2 A(152) / dV(52)dV(86) + D2A(133) = RCT(152) +! D2A(134) = d^2 A(153) / dV(70)dV(86) + D2A(134) = RCT(153) +! D2A(135) = d^2 A(154) / dV(46)dV(89) + D2A(135) = RCT(154) +! D2A(136) = d^2 A(155) / dV(77)dV(89) + D2A(136) = RCT(155) +! D2A(137) = d^2 A(156) / dV(80)dV(89) + D2A(137) = RCT(156) +! D2A(138) = d^2 A(157) / dV(46)dV(87) + D2A(138) = RCT(157) +! D2A(139) = d^2 A(158) / dV(80)dV(87) + D2A(139) = RCT(158) +! D2A(140) = d^2 A(159) / dV(80)dV(87) + D2A(140) = RCT(159) +! D2A(141) = d^2 A(160) / dV(81)dV(90) + D2A(141) = RCT(160) +! D2A(142) = d^2 A(161) / dV(88)dV(90) + D2A(142) = RCT(161) +! D2A(143) = d^2 A(162) / dV(78)dV(90) + D2A(143) = RCT(162) +! D2A(144) = d^2 A(164) / dV(81)dV(90) + D2A(144) = RCT(164) +! D2A(145) = d^2 A(165) / dV(88)dV(90) + D2A(145) = RCT(165) +! D2A(146) = d^2 A(166) / dV(78)dV(90) + D2A(146) = RCT(166) +! D2A(147) = d^2 A(168) / dV(39)dV(83) + D2A(147) = RCT(168) +! D2A(148) = d^2 A(169) / dV(38)dV(83) + D2A(148) = RCT(169) +! D2A(149) = d^2 A(170) / dV(35)dV(83) + D2A(149) = RCT(170) +! D2A(150) = d^2 A(171) / dV(31)dV(83) + D2A(150) = RCT(171) +! D2A(151) = d^2 A(172) / dV(32)dV(83) + D2A(151) = RCT(172) +! D2A(152) = d^2 A(173) / dV(30)dV(83) + D2A(152) = RCT(173) +! D2A(153) = d^2 A(174) / dV(33)dV(83) + D2A(153) = RCT(174) +! D2A(154) = d^2 A(175) / dV(37)dV(83) + D2A(154) = RCT(175) +! D2A(155) = d^2 A(176) / dV(36)dV(83) + D2A(155) = RCT(176) +! D2A(156) = d^2 A(178) / dV(45)dV(83) + D2A(156) = RCT(178) +! D2A(157) = d^2 A(179) / dV(41)dV(83) + D2A(157) = RCT(179) +! D2A(158) = d^2 A(180) / dV(43)dV(83) + D2A(158) = RCT(180) +! D2A(159) = d^2 A(181) / dV(42)dV(83) + D2A(159) = RCT(181) +! D2A(160) = d^2 A(182) / dV(40)dV(83) + D2A(160) = RCT(182) +! D2A(161) = d^2 A(183) / dV(26)dV(83) + D2A(161) = RCT(183) +! D2A(162) = d^2 A(184) / dV(27)dV(83) + D2A(162) = RCT(184) +! D2A(163) = d^2 A(185) / dV(23)dV(87) + D2A(163) = RCT(185) +! D2A(164) = d^2 A(187) / dV(58)dV(83) + D2A(164) = RCT(187) +! D2A(165) = d^2 A(188) / dV(58)dV(89) + D2A(165) = RCT(188) +! D2A(166) = d^2 A(189)/{dV(86)dV(86)} + D2A(166) = RCT(189)*2 +! D2A(167) = d^2 A(190) / dV(86)dV(90) + D2A(167) = RCT(190) +! D2A(168) = d^2 A(191) / dV(86)dV(90) + D2A(168) = RCT(191) +! D2A(169) = d^2 A(192) / dV(72)dV(86) + D2A(169) = RCT(192) +! D2A(170) = d^2 A(193) / dV(62)dV(86) + D2A(170) = RCT(193) +! D2A(171) = d^2 A(194) / dV(60)dV(86) + D2A(171) = RCT(194) +! D2A(172) = d^2 A(195) / dV(79)dV(86) + D2A(172) = RCT(195) +! D2A(173) = d^2 A(196) / dV(57)dV(86) + D2A(173) = RCT(196) +! D2A(174) = d^2 A(197) / dV(66)dV(86) + D2A(174) = RCT(197) +! D2A(175) = d^2 A(198) / dV(65)dV(86) + D2A(175) = RCT(198) +! D2A(176) = d^2 A(199) / dV(64)dV(86) + D2A(176) = RCT(199) +! D2A(177) = d^2 A(200) / dV(59)dV(86) + D2A(177) = RCT(200) +! D2A(178) = d^2 A(201) / dV(53)dV(86) + D2A(178) = RCT(201) +! D2A(179) = d^2 A(202) / dV(54)dV(86) + D2A(179) = RCT(202) +! D2A(180) = d^2 A(203) / dV(51)dV(86) + D2A(180) = RCT(203) +! D2A(181) = d^2 A(204) / dV(55)dV(86) + D2A(181) = RCT(204) +! D2A(182) = d^2 A(205) / dV(67)dV(86) + D2A(182) = RCT(205) +! D2A(183) = d^2 A(206) / dV(63)dV(86) + D2A(183) = RCT(206) +! D2A(184) = d^2 A(207) / dV(72)dV(86) + D2A(184) = RCT(207) +! D2A(185) = d^2 A(208) / dV(62)dV(86) + D2A(185) = RCT(208) +! D2A(186) = d^2 A(209) / dV(60)dV(86) + D2A(186) = RCT(209) +! D2A(187) = d^2 A(210) / dV(79)dV(86) + D2A(187) = RCT(210) +! D2A(188) = d^2 A(211) / dV(57)dV(86) + D2A(188) = RCT(211) +! D2A(189) = d^2 A(212) / dV(66)dV(86) + D2A(189) = RCT(212) +! D2A(190) = d^2 A(213) / dV(64)dV(86) + D2A(190) = RCT(213) +! D2A(191) = d^2 A(214) / dV(59)dV(86) + D2A(191) = RCT(214) +! D2A(192) = d^2 A(215) / dV(54)dV(86) + D2A(192) = RCT(215) +! D2A(193) = d^2 A(216) / dV(65)dV(86) + D2A(193) = RCT(216) +! D2A(194) = d^2 A(217) / dV(51)dV(86) + D2A(194) = RCT(217) +! D2A(195) = d^2 A(218) / dV(55)dV(86) + D2A(195) = RCT(218) +! D2A(196) = d^2 A(219) / dV(67)dV(86) + D2A(196) = RCT(219) +! D2A(197) = d^2 A(220) / dV(63)dV(86) + D2A(197) = RCT(220) +! D2A(198) = d^2 A(221) / dV(53)dV(86) + D2A(198) = RCT(221) +! D2A(199) = d^2 A(222) / dV(74)dV(86) + D2A(199) = RCT(222) +! D2A(200) = d^2 A(223) / dV(74)dV(86) + D2A(200) = RCT(223) +! D2A(201) = d^2 A(224) / dV(81)dV(86) + D2A(201) = RCT(224) +! D2A(202) = d^2 A(225) / dV(86)dV(88) + D2A(202) = RCT(225) +! D2A(203) = d^2 A(226) / dV(78)dV(86) + D2A(203) = RCT(226) +! D2A(204) = d^2 A(228)/{dV(87)dV(87)} + D2A(204) = RCT(228)*2 +! D2A(205) = d^2 A(257) / dV(34)dV(83) + D2A(205) = RCT(257) +! D2A(206) = d^2 A(258) / dV(34)dV(83) + D2A(206) = RCT(258) +! D2A(207) = d^2 A(259) / dV(34)dV(87) + D2A(207) = RCT(259) +! D2A(208) = d^2 A(260) / dV(20)dV(83) + D2A(208) = RCT(260) + +! Computation of the Jacobian derivative +! HESS(1) = d^2 Vdot(11)/{dV(20)dV(83)} = d^2 Vdot(11)/{dV(83)dV(20)} + HESS(1) = D2A(208) +! HESS(2) = d^2 Vdot(12)/{dV(34)dV(83)} = d^2 Vdot(12)/{dV(83)dV(34)} + HESS(2) = 0.25*D2A(206) +! HESS(3) = d^2 Vdot(13)/{dV(46)dV(89)} = d^2 Vdot(13)/{dV(89)dV(46)} + HESS(3) = 0.15*D2A(135) +! HESS(4) = d^2 Vdot(13)/{dV(47)dV(83)} = d^2 Vdot(13)/{dV(83)dV(47)} + HESS(4) = D2A(12) +! HESS(5) = d^2 Vdot(13)/{dV(80)dV(89)} = d^2 Vdot(13)/{dV(89)dV(80)} + HESS(5) = 0.16*D2A(137) +! HESS(6) = d^2 Vdot(13)/{dV(85)dV(86)} = d^2 Vdot(13)/{dV(86)dV(85)} + HESS(6) = D2A(35) +! HESS(7) = d^2 Vdot(15)/{dV(46)dV(83)} = d^2 Vdot(15)/{dV(83)dV(46)} + HESS(7) = D2A(127) +! HESS(8) = d^2 Vdot(16)/{dV(16)dV(83)} = d^2 Vdot(16)/{dV(83)dV(16)} + HESS(8) = -D2A(38)-D2A(39) +! HESS(9) = d^2 Vdot(17)/{dV(17)dV(83)} = d^2 Vdot(17)/{dV(83)dV(17)} + HESS(9) = -D2A(9) +! HESS(10) = d^2 Vdot(17)/{dV(83)dV(83)} = d^2 Vdot(17)/{dV(83)dV(83)} + HESS(10) = D2A(7) +! HESS(11) = d^2 Vdot(17)/{dV(84)dV(84)} = d^2 Vdot(17)/{dV(84)dV(84)} + HESS(11) = D2A(11) +! HESS(12) = d^2 Vdot(18)/{dV(81)dV(82)} = d^2 Vdot(18)/{dV(82)dV(81)} + HESS(12) = D2A(66) +! HESS(13) = d^2 Vdot(19)/{dV(82)dV(88)} = d^2 Vdot(19)/{dV(88)dV(82)} + HESS(13) = D2A(67) +! HESS(14) = d^2 Vdot(20)/{dV(20)dV(83)} = d^2 Vdot(20)/{dV(83)dV(20)} + HESS(14) = -D2A(208) +! HESS(15) = d^2 Vdot(20)/{dV(34)dV(83)} = d^2 Vdot(20)/{dV(83)dV(34)} + HESS(15) = D2A(205)+0.75*D2A(206) +! HESS(16) = d^2 Vdot(20)/{dV(34)dV(87)} = d^2 Vdot(20)/{dV(87)dV(34)} + HESS(16) = D2A(207) +! HESS(17) = d^2 Vdot(21)/{dV(82)dV(86)} = d^2 Vdot(21)/{dV(86)dV(82)} + HESS(17) = D2A(34) +! HESS(18) = d^2 Vdot(22)/{dV(22)dV(83)} = d^2 Vdot(22)/{dV(83)dV(22)} + HESS(18) = -D2A(42) +! HESS(19) = d^2 Vdot(22)/{dV(22)dV(87)} = d^2 Vdot(22)/{dV(87)dV(22)} + HESS(19) = -D2A(63) +! HESS(20) = d^2 Vdot(23)/{dV(23)dV(83)} = d^2 Vdot(23)/{dV(83)dV(23)} + HESS(20) = -D2A(36) +! HESS(21) = d^2 Vdot(23)/{dV(23)dV(87)} = d^2 Vdot(23)/{dV(87)dV(23)} + HESS(21) = -D2A(163) +! HESS(22) = d^2 Vdot(24)/{dV(24)dV(83)} = d^2 Vdot(24)/{dV(83)dV(24)} + HESS(22) = -D2A(23) +! HESS(23) = d^2 Vdot(24)/{dV(83)dV(85)} = d^2 Vdot(24)/{dV(85)dV(83)} + HESS(23) = D2A(22) +! HESS(24) = d^2 Vdot(25)/{dV(82)dV(87)} = d^2 Vdot(25)/{dV(87)dV(82)} + HESS(24) = D2A(29) +! HESS(25) = d^2 Vdot(26)/{dV(26)dV(83)} = d^2 Vdot(26)/{dV(83)dV(26)} + HESS(25) = -D2A(161) +! HESS(26) = d^2 Vdot(26)/{dV(78)dV(84)} = d^2 Vdot(26)/{dV(84)dV(78)} + HESS(26) = 0.7*D2A(118) +! HESS(27) = d^2 Vdot(27)/{dV(27)dV(83)} = d^2 Vdot(27)/{dV(83)dV(27)} + HESS(27) = -D2A(162) +! HESS(28) = d^2 Vdot(27)/{dV(84)dV(86)} = d^2 Vdot(27)/{dV(86)dV(84)} + HESS(28) = 0.41*D2A(115) +! HESS(29) = d^2 Vdot(28)/{dV(28)dV(83)} = d^2 Vdot(28)/{dV(83)dV(28)} + HESS(29) = -D2A(17)-D2A(18) +! HESS(30) = d^2 Vdot(28)/{dV(84)dV(90)} = d^2 Vdot(28)/{dV(90)dV(84)} + HESS(30) = D2A(14) +! HESS(31) = d^2 Vdot(29)/{dV(29)dV(83)} = d^2 Vdot(29)/{dV(83)dV(29)} + HESS(31) = -D2A(25) +! HESS(32) = d^2 Vdot(29)/{dV(82)dV(84)} = d^2 Vdot(29)/{dV(84)dV(82)} + HESS(32) = D2A(24) +! HESS(33) = d^2 Vdot(30)/{dV(30)dV(83)} = d^2 Vdot(30)/{dV(83)dV(30)} + HESS(33) = -D2A(152) +! HESS(34) = d^2 Vdot(30)/{dV(72)dV(84)} = d^2 Vdot(30)/{dV(84)dV(72)} + HESS(34) = D2A(77) +! HESS(35) = d^2 Vdot(31)/{dV(31)dV(83)} = d^2 Vdot(31)/{dV(83)dV(31)} + HESS(35) = -D2A(150) +! HESS(36) = d^2 Vdot(31)/{dV(52)dV(84)} = d^2 Vdot(31)/{dV(84)dV(52)} + HESS(36) = D2A(113) +! HESS(37) = d^2 Vdot(32)/{dV(32)dV(83)} = d^2 Vdot(32)/{dV(83)dV(32)} + HESS(37) = -D2A(151) +! HESS(38) = d^2 Vdot(32)/{dV(53)dV(84)} = d^2 Vdot(32)/{dV(84)dV(53)} + HESS(38) = D2A(89) +! HESS(39) = d^2 Vdot(33)/{dV(33)dV(83)} = d^2 Vdot(33)/{dV(83)dV(33)} + HESS(39) = -D2A(153) +! HESS(40) = d^2 Vdot(33)/{dV(81)dV(84)} = d^2 Vdot(33)/{dV(84)dV(81)} + HESS(40) = 0.7*D2A(116) +! HESS(41) = d^2 Vdot(34)/{dV(34)dV(83)} = d^2 Vdot(34)/{dV(83)dV(34)} + HESS(41) = -D2A(205)-D2A(206) +! HESS(42) = d^2 Vdot(34)/{dV(34)dV(87)} = d^2 Vdot(34)/{dV(87)dV(34)} + HESS(42) = -D2A(207) +! HESS(43) = d^2 Vdot(35)/{dV(35)dV(83)} = d^2 Vdot(35)/{dV(83)dV(35)} + HESS(43) = -D2A(149) +! HESS(44) = d^2 Vdot(35)/{dV(74)dV(84)} = d^2 Vdot(35)/{dV(84)dV(74)} + HESS(44) = D2A(112) +! HESS(45) = d^2 Vdot(36)/{dV(36)dV(83)} = d^2 Vdot(36)/{dV(83)dV(36)} + HESS(45) = -D2A(155) +! HESS(46) = d^2 Vdot(36)/{dV(84)dV(88)} = d^2 Vdot(36)/{dV(88)dV(84)} + HESS(46) = 0.71*D2A(117) +! HESS(47) = d^2 Vdot(37)/{dV(37)dV(83)} = d^2 Vdot(37)/{dV(83)dV(37)} + HESS(47) = -D2A(154) +! HESS(48) = d^2 Vdot(37)/{dV(70)dV(84)} = d^2 Vdot(37)/{dV(84)dV(70)} + HESS(48) = D2A(114) +! HESS(49) = d^2 Vdot(38)/{dV(38)dV(83)} = d^2 Vdot(38)/{dV(83)dV(38)} + HESS(49) = -D2A(148) +! HESS(50) = d^2 Vdot(38)/{dV(63)dV(84)} = d^2 Vdot(38)/{dV(84)dV(63)} + HESS(50) = D2A(91) +! HESS(51) = d^2 Vdot(39)/{dV(39)dV(83)} = d^2 Vdot(39)/{dV(83)dV(39)} + HESS(51) = -D2A(147) +! HESS(52) = d^2 Vdot(39)/{dV(67)dV(84)} = d^2 Vdot(39)/{dV(84)dV(67)} + HESS(52) = D2A(90) +! HESS(53) = d^2 Vdot(40)/{dV(40)dV(83)} = d^2 Vdot(40)/{dV(83)dV(40)} + HESS(53) = -D2A(160) +! HESS(54) = d^2 Vdot(40)/{dV(59)dV(84)} = d^2 Vdot(40)/{dV(84)dV(59)} + HESS(54) = D2A(86) +! HESS(55) = d^2 Vdot(41)/{dV(41)dV(83)} = d^2 Vdot(41)/{dV(83)dV(41)} + HESS(55) = -D2A(157) +! HESS(56) = d^2 Vdot(41)/{dV(66)dV(84)} = d^2 Vdot(41)/{dV(84)dV(66)} + HESS(56) = D2A(83) +! HESS(57) = d^2 Vdot(42)/{dV(42)dV(83)} = d^2 Vdot(42)/{dV(83)dV(42)} + HESS(57) = -D2A(159) +! HESS(58) = d^2 Vdot(42)/{dV(64)dV(84)} = d^2 Vdot(42)/{dV(84)dV(64)} + HESS(58) = D2A(85) +! HESS(59) = d^2 Vdot(43)/{dV(43)dV(83)} = d^2 Vdot(43)/{dV(83)dV(43)} + HESS(59) = -D2A(158) +! HESS(60) = d^2 Vdot(43)/{dV(51)dV(84)} = d^2 Vdot(43)/{dV(84)dV(51)} + HESS(60) = D2A(87) +! HESS(61) = d^2 Vdot(43)/{dV(55)dV(84)} = d^2 Vdot(43)/{dV(84)dV(55)} + HESS(61) = D2A(88) +! HESS(62) = d^2 Vdot(43)/{dV(65)dV(84)} = d^2 Vdot(43)/{dV(84)dV(65)} + HESS(62) = D2A(84) +! HESS(63) = d^2 Vdot(44)/{dV(44)dV(83)} = d^2 Vdot(44)/{dV(83)dV(44)} + HESS(63) = -D2A(121) +! HESS(64) = d^2 Vdot(44)/{dV(44)dV(89)} = d^2 Vdot(44)/{dV(89)dV(44)} + HESS(64) = -D2A(122) +! HESS(65) = d^2 Vdot(44)/{dV(78)dV(82)} = d^2 Vdot(44)/{dV(82)dV(78)} + HESS(65) = D2A(68) +! HESS(66) = d^2 Vdot(45)/{dV(45)dV(83)} = d^2 Vdot(45)/{dV(83)dV(45)} + HESS(66) = -D2A(156) +! HESS(67) = d^2 Vdot(45)/{dV(57)dV(84)} = d^2 Vdot(45)/{dV(84)dV(57)} + HESS(67) = D2A(82) +! HESS(68) = d^2 Vdot(45)/{dV(79)dV(84)} = d^2 Vdot(45)/{dV(84)dV(79)} + HESS(68) = D2A(81) +! HESS(69) = d^2 Vdot(46)/{dV(46)dV(83)} = d^2 Vdot(46)/{dV(83)dV(46)} + HESS(69) = -D2A(127) +! HESS(70) = d^2 Vdot(46)/{dV(46)dV(87)} = d^2 Vdot(46)/{dV(87)dV(46)} + HESS(70) = -D2A(138) +! HESS(71) = d^2 Vdot(46)/{dV(46)dV(89)} = d^2 Vdot(46)/{dV(89)dV(46)} + HESS(71) = -D2A(135) +! HESS(72) = d^2 Vdot(47)/{dV(46)dV(89)} = d^2 Vdot(47)/{dV(89)dV(46)} + HESS(72) = 0.05*D2A(135) +! HESS(73) = d^2 Vdot(47)/{dV(47)dV(83)} = d^2 Vdot(47)/{dV(83)dV(47)} + HESS(73) = -D2A(12) +! HESS(74) = d^2 Vdot(47)/{dV(48)dV(89)} = d^2 Vdot(47)/{dV(89)dV(48)} + HESS(74) = 0.42*D2A(120) +! HESS(75) = d^2 Vdot(47)/{dV(50)dV(83)} = d^2 Vdot(47)/{dV(83)dV(50)} + HESS(75) = 0.4*D2A(123) +! HESS(76) = d^2 Vdot(47)/{dV(58)dV(89)} = d^2 Vdot(47)/{dV(89)dV(58)} + HESS(76) = 0.4*D2A(165) +! HESS(77) = d^2 Vdot(47)/{dV(59)dV(86)} = d^2 Vdot(47)/{dV(86)dV(59)} + HESS(77) = 0.83*D2A(177) +! HESS(78) = d^2 Vdot(47)/{dV(59)dV(90)} = d^2 Vdot(47)/{dV(90)dV(59)} + HESS(78) = 0.15*D2A(104) +! HESS(79) = d^2 Vdot(47)/{dV(66)dV(85)} = d^2 Vdot(47)/{dV(85)dV(66)} + HESS(79) = 0.61*D2A(52) +! HESS(80) = d^2 Vdot(47)/{dV(66)dV(86)} = d^2 Vdot(47)/{dV(86)dV(66)} + HESS(80) = 0.65*D2A(174) +! HESS(81) = d^2 Vdot(47)/{dV(66)dV(90)} = d^2 Vdot(47)/{dV(90)dV(66)} + HESS(81) = 0.33*D2A(101) +! HESS(82) = d^2 Vdot(47)/{dV(69)dV(83)} = d^2 Vdot(47)/{dV(83)dV(69)} + HESS(82) = D2A(19) +! HESS(83) = d^2 Vdot(47)/{dV(69)dV(87)} = d^2 Vdot(47)/{dV(87)dV(69)} + HESS(83) = D2A(31) +! HESS(84) = d^2 Vdot(47)/{dV(71)dV(83)} = d^2 Vdot(47)/{dV(83)dV(71)} + HESS(84) = 0.05*D2A(32) +! HESS(85) = d^2 Vdot(47)/{dV(75)dV(83)} = d^2 Vdot(47)/{dV(83)dV(75)} + HESS(85) = D2A(125) +! HESS(86) = d^2 Vdot(47)/{dV(75)dV(87)} = d^2 Vdot(47)/{dV(87)dV(75)} + HESS(86) = D2A(126) +! HESS(87) = d^2 Vdot(47)/{dV(77)dV(89)} = d^2 Vdot(47)/{dV(89)dV(77)} + HESS(87) = 0.05*D2A(136) +! HESS(88) = d^2 Vdot(47)/{dV(80)dV(89)} = d^2 Vdot(47)/{dV(89)dV(80)} + HESS(88) = 0.2*D2A(137) +! HESS(89) = d^2 Vdot(48)/{dV(46)dV(89)} = d^2 Vdot(48)/{dV(89)dV(46)} + HESS(89) = 0.07*D2A(135) +! HESS(90) = d^2 Vdot(48)/{dV(48)dV(83)} = d^2 Vdot(48)/{dV(83)dV(48)} + HESS(90) = -D2A(119) +! HESS(91) = d^2 Vdot(48)/{dV(48)dV(87)} = d^2 Vdot(48)/{dV(87)dV(48)} + HESS(91) = -D2A(124) +! HESS(92) = d^2 Vdot(48)/{dV(48)dV(89)} = d^2 Vdot(48)/{dV(89)dV(48)} + HESS(92) = -D2A(120) +! HESS(93) = d^2 Vdot(49)/{dV(32)dV(83)} = d^2 Vdot(49)/{dV(83)dV(32)} + HESS(93) = 0.5*D2A(151) +! HESS(94) = d^2 Vdot(49)/{dV(49)dV(83)} = d^2 Vdot(49)/{dV(83)dV(49)} + HESS(94) = -D2A(73)-D2A(74) +! HESS(95) = d^2 Vdot(49)/{dV(53)dV(85)} = d^2 Vdot(49)/{dV(85)dV(53)} + HESS(95) = D2A(60) +! HESS(96) = d^2 Vdot(49)/{dV(53)dV(86)} = d^2 Vdot(49)/{dV(86)dV(53)} + HESS(96) = D2A(178)+D2A(198) +! HESS(97) = d^2 Vdot(49)/{dV(53)dV(90)} = d^2 Vdot(49)/{dV(90)dV(53)} + HESS(97) = 0.75*D2A(107) +! HESS(98) = d^2 Vdot(49)/{dV(72)dV(85)} = d^2 Vdot(49)/{dV(85)dV(72)} + HESS(98) = 0.32*D2A(43) +! HESS(99) = d^2 Vdot(49)/{dV(72)dV(86)} = d^2 Vdot(49)/{dV(86)dV(72)} + HESS(99) = 0.32*D2A(169) +! HESS(100) = d^2 Vdot(49)/{dV(72)dV(90)} = d^2 Vdot(49)/{dV(90)dV(72)} + HESS(100) = 0.16*D2A(95) +! HESS(101) = d^2 Vdot(50)/{dV(50)dV(83)} = d^2 Vdot(50)/{dV(83)dV(50)} + HESS(101) = -D2A(123) +! HESS(102) = d^2 Vdot(50)/{dV(51)dV(85)} = d^2 Vdot(50)/{dV(85)dV(51)} + HESS(102) = 0.6*D2A(58) +! HESS(103) = d^2 Vdot(50)/{dV(58)dV(89)} = d^2 Vdot(50)/{dV(89)dV(58)} + HESS(103) = 0.28*D2A(165) +! HESS(104) = d^2 Vdot(50)/{dV(64)dV(85)} = d^2 Vdot(50)/{dV(85)dV(64)} + HESS(104) = 0.72*D2A(54) +! HESS(105) = d^2 Vdot(50)/{dV(64)dV(86)} = d^2 Vdot(50)/{dV(86)dV(64)} + HESS(105) = 0.72*D2A(176) +! HESS(106) = d^2 Vdot(50)/{dV(64)dV(90)} = d^2 Vdot(50)/{dV(90)dV(64)} + HESS(106) = 0.36*D2A(103) +! HESS(107) = d^2 Vdot(50)/{dV(65)dV(85)} = d^2 Vdot(50)/{dV(85)dV(65)} + HESS(107) = 0.95*D2A(53) +! HESS(108) = d^2 Vdot(50)/{dV(65)dV(86)} = d^2 Vdot(50)/{dV(86)dV(65)} + HESS(108) = D2A(175) +! HESS(109) = d^2 Vdot(50)/{dV(65)dV(90)} = d^2 Vdot(50)/{dV(90)dV(65)} + HESS(109) = 0.5*D2A(102) +! HESS(110) = d^2 Vdot(50)/{dV(66)dV(85)} = d^2 Vdot(50)/{dV(85)dV(66)} + HESS(110) = 0.24*D2A(52) +! HESS(111) = d^2 Vdot(50)/{dV(66)dV(86)} = d^2 Vdot(50)/{dV(86)dV(66)} + HESS(111) = 0.26*D2A(174) +! HESS(112) = d^2 Vdot(50)/{dV(66)dV(90)} = d^2 Vdot(50)/{dV(90)dV(66)} + HESS(112) = 0.13*D2A(101) +! HESS(113) = d^2 Vdot(51)/{dV(51)dV(84)} = d^2 Vdot(51)/{dV(84)dV(51)} + HESS(113) = -D2A(87) +! HESS(114) = d^2 Vdot(51)/{dV(51)dV(85)} = d^2 Vdot(51)/{dV(85)dV(51)} + HESS(114) = -D2A(58) +! HESS(115) = d^2 Vdot(51)/{dV(51)dV(86)} = d^2 Vdot(51)/{dV(86)dV(51)} + HESS(115) = -D2A(180)-D2A(194) +! HESS(116) = d^2 Vdot(51)/{dV(51)dV(90)} = d^2 Vdot(51)/{dV(90)dV(51)} + HESS(116) = -D2A(105) +! HESS(117) = d^2 Vdot(52)/{dV(16)dV(83)} = d^2 Vdot(52)/{dV(83)dV(16)} + HESS(117) = D2A(39) +! HESS(118) = d^2 Vdot(52)/{dV(31)dV(83)} = d^2 Vdot(52)/{dV(83)dV(31)} + HESS(118) = 0.5*D2A(150) +! HESS(119) = d^2 Vdot(52)/{dV(52)dV(84)} = d^2 Vdot(52)/{dV(84)dV(52)} + HESS(119) = -D2A(113) +! HESS(120) = d^2 Vdot(52)/{dV(52)dV(85)} = d^2 Vdot(52)/{dV(85)dV(52)} + HESS(120) = -D2A(40) +! HESS(121) = d^2 Vdot(52)/{dV(52)dV(86)} = d^2 Vdot(52)/{dV(86)dV(52)} + HESS(121) = -D2A(131)-D2A(133) +! HESS(122) = d^2 Vdot(52)/{dV(52)dV(90)} = d^2 Vdot(52)/{dV(90)dV(52)} + HESS(122) = -D2A(75) +! HESS(123) = d^2 Vdot(52)/{dV(72)dV(85)} = d^2 Vdot(52)/{dV(85)dV(72)} + HESS(123) = 0.05*D2A(43) +! HESS(124) = d^2 Vdot(52)/{dV(72)dV(86)} = d^2 Vdot(52)/{dV(86)dV(72)} + HESS(124) = 0.05*D2A(169) +! HESS(125) = d^2 Vdot(52)/{dV(72)dV(90)} = d^2 Vdot(52)/{dV(90)dV(72)} + HESS(125) = 0.03*D2A(95) +! HESS(126) = d^2 Vdot(53)/{dV(16)dV(83)} = d^2 Vdot(53)/{dV(83)dV(16)} + HESS(126) = D2A(38) +! HESS(127) = d^2 Vdot(53)/{dV(32)dV(83)} = d^2 Vdot(53)/{dV(83)dV(32)} + HESS(127) = 0.5*D2A(151) +! HESS(128) = d^2 Vdot(53)/{dV(53)dV(84)} = d^2 Vdot(53)/{dV(84)dV(53)} + HESS(128) = -D2A(89) +! HESS(129) = d^2 Vdot(53)/{dV(53)dV(85)} = d^2 Vdot(53)/{dV(85)dV(53)} + HESS(129) = -D2A(60) +! HESS(130) = d^2 Vdot(53)/{dV(53)dV(86)} = d^2 Vdot(53)/{dV(86)dV(53)} + HESS(130) = -D2A(178)-D2A(198) +! HESS(131) = d^2 Vdot(53)/{dV(53)dV(90)} = d^2 Vdot(53)/{dV(90)dV(53)} + HESS(131) = -D2A(107) +! HESS(132) = d^2 Vdot(53)/{dV(72)dV(85)} = d^2 Vdot(53)/{dV(85)dV(72)} + HESS(132) = 0.18*D2A(43) +! HESS(133) = d^2 Vdot(53)/{dV(72)dV(86)} = d^2 Vdot(53)/{dV(86)dV(72)} + HESS(133) = 0.18*D2A(169) +! HESS(134) = d^2 Vdot(53)/{dV(72)dV(90)} = d^2 Vdot(53)/{dV(90)dV(72)} + HESS(134) = 0.09*D2A(95) +! HESS(135) = d^2 Vdot(54)/{dV(54)dV(84)} = d^2 Vdot(54)/{dV(84)dV(54)} + HESS(135) = -D2A(78) +! HESS(136) = d^2 Vdot(54)/{dV(54)dV(85)} = d^2 Vdot(54)/{dV(85)dV(54)} + HESS(136) = -D2A(45) +! HESS(137) = d^2 Vdot(54)/{dV(54)dV(86)} = d^2 Vdot(54)/{dV(86)dV(54)} + HESS(137) = -D2A(179)-D2A(192) +! HESS(138) = d^2 Vdot(54)/{dV(54)dV(90)} = d^2 Vdot(54)/{dV(90)dV(54)} + HESS(138) = -D2A(96) +! HESS(139) = d^2 Vdot(54)/{dV(73)dV(83)} = d^2 Vdot(54)/{dV(83)dV(73)} + HESS(139) = D2A(64) +! HESS(140) = d^2 Vdot(55)/{dV(55)dV(84)} = d^2 Vdot(55)/{dV(84)dV(55)} + HESS(140) = -D2A(88) +! HESS(141) = d^2 Vdot(55)/{dV(55)dV(85)} = d^2 Vdot(55)/{dV(85)dV(55)} + HESS(141) = -D2A(59) +! HESS(142) = d^2 Vdot(55)/{dV(55)dV(86)} = d^2 Vdot(55)/{dV(86)dV(55)} + HESS(142) = -D2A(181)-D2A(195) +! HESS(143) = d^2 Vdot(55)/{dV(55)dV(90)} = d^2 Vdot(55)/{dV(90)dV(55)} + HESS(143) = -D2A(106) +! HESS(144) = d^2 Vdot(55)/{dV(80)dV(87)} = d^2 Vdot(55)/{dV(87)dV(80)} + HESS(144) = D2A(139) +! HESS(145) = d^2 Vdot(56)/{dV(22)dV(87)} = d^2 Vdot(56)/{dV(87)dV(22)} + HESS(145) = D2A(63) +! HESS(146) = d^2 Vdot(56)/{dV(23)dV(87)} = d^2 Vdot(56)/{dV(87)dV(23)} + HESS(146) = D2A(163) +! HESS(147) = d^2 Vdot(56)/{dV(34)dV(87)} = d^2 Vdot(56)/{dV(87)dV(34)} + HESS(147) = D2A(207) +! HESS(148) = d^2 Vdot(56)/{dV(51)dV(85)} = d^2 Vdot(56)/{dV(85)dV(51)} + HESS(148) = 0.1*D2A(58) +! HESS(149) = d^2 Vdot(56)/{dV(56)dV(83)} = d^2 Vdot(56)/{dV(83)dV(56)} + HESS(149) = -D2A(21) +! HESS(150) = d^2 Vdot(56)/{dV(57)dV(85)} = d^2 Vdot(56)/{dV(85)dV(57)} + HESS(150) = D2A(51) +! HESS(151) = d^2 Vdot(56)/{dV(59)dV(85)} = d^2 Vdot(56)/{dV(85)dV(59)} + HESS(151) = D2A(57) +! HESS(152) = d^2 Vdot(56)/{dV(64)dV(85)} = d^2 Vdot(56)/{dV(85)dV(64)} + HESS(152) = D2A(55) +! HESS(153) = d^2 Vdot(56)/{dV(65)dV(85)} = d^2 Vdot(56)/{dV(85)dV(65)} + HESS(153) = 0.05*D2A(53) +! HESS(154) = d^2 Vdot(56)/{dV(66)dV(85)} = d^2 Vdot(56)/{dV(85)dV(66)} + HESS(154) = 0.08*D2A(52) +! HESS(155) = d^2 Vdot(56)/{dV(67)dV(85)} = d^2 Vdot(56)/{dV(85)dV(67)} + HESS(155) = 0.85*D2A(61) +! HESS(156) = d^2 Vdot(56)/{dV(67)dV(86)} = d^2 Vdot(56)/{dV(86)dV(67)} + HESS(156) = 0.85*D2A(182) +! HESS(157) = d^2 Vdot(56)/{dV(67)dV(90)} = d^2 Vdot(56)/{dV(90)dV(67)} + HESS(157) = 0.425*D2A(108) +! HESS(158) = d^2 Vdot(56)/{dV(68)dV(87)} = d^2 Vdot(56)/{dV(87)dV(68)} + HESS(158) = D2A(72) +! HESS(159) = d^2 Vdot(56)/{dV(69)dV(87)} = d^2 Vdot(56)/{dV(87)dV(69)} + HESS(159) = D2A(31) +! HESS(160) = d^2 Vdot(56)/{dV(71)dV(87)} = d^2 Vdot(56)/{dV(87)dV(71)} + HESS(160) = D2A(33) +! HESS(161) = d^2 Vdot(56)/{dV(75)dV(87)} = d^2 Vdot(56)/{dV(87)dV(75)} + HESS(161) = D2A(126) +! HESS(162) = d^2 Vdot(56)/{dV(76)dV(87)} = d^2 Vdot(56)/{dV(87)dV(76)} + HESS(162) = D2A(94) +! HESS(163) = d^2 Vdot(56)/{dV(79)dV(85)} = d^2 Vdot(56)/{dV(85)dV(79)} + HESS(163) = 0.1*D2A(48)+D2A(49) +! HESS(164) = d^2 Vdot(56)/{dV(80)dV(87)} = d^2 Vdot(56)/{dV(87)dV(80)} + HESS(164) = D2A(140) +! HESS(165) = d^2 Vdot(56)/{dV(82)dV(83)} = d^2 Vdot(56)/{dV(83)dV(82)} + HESS(165) = D2A(20) +! HESS(166) = d^2 Vdot(57)/{dV(57)dV(84)} = d^2 Vdot(57)/{dV(84)dV(57)} + HESS(166) = -D2A(82) +! HESS(167) = d^2 Vdot(57)/{dV(57)dV(85)} = d^2 Vdot(57)/{dV(85)dV(57)} + HESS(167) = -D2A(50)-D2A(51) +! HESS(168) = d^2 Vdot(57)/{dV(57)dV(86)} = d^2 Vdot(57)/{dV(86)dV(57)} + HESS(168) = -D2A(173)-D2A(188) +! HESS(169) = d^2 Vdot(57)/{dV(57)dV(90)} = d^2 Vdot(57)/{dV(90)dV(57)} + HESS(169) = -D2A(100) +! HESS(170) = d^2 Vdot(57)/{dV(79)dV(86)} = d^2 Vdot(57)/{dV(86)dV(79)} + HESS(170) = 0.136*D2A(172) +! HESS(171) = d^2 Vdot(57)/{dV(79)dV(90)} = d^2 Vdot(57)/{dV(90)dV(79)} + HESS(171) = 0.07*D2A(99) +! HESS(172) = d^2 Vdot(58)/{dV(45)dV(83)} = d^2 Vdot(58)/{dV(83)dV(45)} + HESS(172) = 0.509*D2A(156) +! HESS(173) = d^2 Vdot(58)/{dV(57)dV(85)} = d^2 Vdot(58)/{dV(85)dV(57)} + HESS(173) = D2A(50) +! HESS(174) = d^2 Vdot(58)/{dV(57)dV(86)} = d^2 Vdot(58)/{dV(86)dV(57)} + HESS(174) = D2A(173) +! HESS(175) = d^2 Vdot(58)/{dV(57)dV(90)} = d^2 Vdot(58)/{dV(90)dV(57)} + HESS(175) = 0.5*D2A(100) +! HESS(176) = d^2 Vdot(58)/{dV(58)dV(83)} = d^2 Vdot(58)/{dV(83)dV(58)} + HESS(176) = -D2A(164) +! HESS(177) = d^2 Vdot(58)/{dV(58)dV(89)} = d^2 Vdot(58)/{dV(89)dV(58)} + HESS(177) = -D2A(165) +! HESS(178) = d^2 Vdot(58)/{dV(79)dV(85)} = d^2 Vdot(58)/{dV(85)dV(79)} + HESS(178) = 0.34*D2A(48) +! HESS(179) = d^2 Vdot(58)/{dV(79)dV(86)} = d^2 Vdot(58)/{dV(86)dV(79)} + HESS(179) = 0.127*D2A(172) +! HESS(180) = d^2 Vdot(58)/{dV(79)dV(90)} = d^2 Vdot(58)/{dV(90)dV(79)} + HESS(180) = 0.06*D2A(99) +! HESS(181) = d^2 Vdot(59)/{dV(40)dV(83)} = d^2 Vdot(59)/{dV(83)dV(40)} + HESS(181) = D2A(160) +! HESS(182) = d^2 Vdot(59)/{dV(59)dV(84)} = d^2 Vdot(59)/{dV(84)dV(59)} + HESS(182) = -D2A(86) +! HESS(183) = d^2 Vdot(59)/{dV(59)dV(85)} = d^2 Vdot(59)/{dV(85)dV(59)} + HESS(183) = -D2A(56)-D2A(57) +! HESS(184) = d^2 Vdot(59)/{dV(59)dV(86)} = d^2 Vdot(59)/{dV(86)dV(59)} + HESS(184) = -D2A(177)-D2A(191) +! HESS(185) = d^2 Vdot(59)/{dV(59)dV(90)} = d^2 Vdot(59)/{dV(90)dV(59)} + HESS(185) = -D2A(104) +! HESS(186) = d^2 Vdot(59)/{dV(80)dV(83)} = d^2 Vdot(59)/{dV(83)dV(80)} + HESS(186) = 0.43*D2A(129) +! HESS(187) = d^2 Vdot(60)/{dV(60)dV(84)} = d^2 Vdot(60)/{dV(84)dV(60)} + HESS(187) = -D2A(80) +! HESS(188) = d^2 Vdot(60)/{dV(60)dV(85)} = d^2 Vdot(60)/{dV(85)dV(60)} + HESS(188) = -D2A(47) +! HESS(189) = d^2 Vdot(60)/{dV(60)dV(86)} = d^2 Vdot(60)/{dV(86)dV(60)} + HESS(189) = -D2A(171)-D2A(186) +! HESS(190) = d^2 Vdot(60)/{dV(60)dV(90)} = d^2 Vdot(60)/{dV(90)dV(60)} + HESS(190) = -D2A(98) +! HESS(191) = d^2 Vdot(60)/{dV(76)dV(83)} = d^2 Vdot(60)/{dV(83)dV(76)} + HESS(191) = D2A(92) +! HESS(192) = d^2 Vdot(60)/{dV(76)dV(87)} = d^2 Vdot(60)/{dV(87)dV(76)} + HESS(192) = D2A(94) +! HESS(193) = d^2 Vdot(61)/{dV(44)dV(83)} = d^2 Vdot(61)/{dV(83)dV(44)} + HESS(193) = 0.59*D2A(121) +! HESS(194) = d^2 Vdot(61)/{dV(58)dV(89)} = d^2 Vdot(61)/{dV(89)dV(58)} + HESS(194) = 0.2*D2A(165) +! HESS(195) = d^2 Vdot(61)/{dV(59)dV(85)} = d^2 Vdot(61)/{dV(85)dV(59)} + HESS(195) = D2A(56) +! HESS(196) = d^2 Vdot(61)/{dV(59)dV(86)} = d^2 Vdot(61)/{dV(86)dV(59)} + HESS(196) = 0.83*D2A(177) +! HESS(197) = d^2 Vdot(61)/{dV(59)dV(90)} = d^2 Vdot(61)/{dV(90)dV(59)} + HESS(197) = D2A(104) +! HESS(198) = d^2 Vdot(61)/{dV(61)dV(83)} = d^2 Vdot(61)/{dV(83)dV(61)} + HESS(198) = -D2A(130) +! HESS(199) = d^2 Vdot(61)/{dV(62)dV(90)} = d^2 Vdot(61)/{dV(90)dV(62)} + HESS(199) = 0.2*D2A(97) +! HESS(200) = d^2 Vdot(61)/{dV(65)dV(85)} = d^2 Vdot(61)/{dV(85)dV(65)} + HESS(200) = 0.95*D2A(53) +! HESS(201) = d^2 Vdot(61)/{dV(65)dV(86)} = d^2 Vdot(61)/{dV(86)dV(65)} + HESS(201) = D2A(175) +! HESS(202) = d^2 Vdot(61)/{dV(65)dV(90)} = d^2 Vdot(61)/{dV(90)dV(65)} + HESS(202) = 0.5*D2A(102) +! HESS(203) = d^2 Vdot(61)/{dV(66)dV(85)} = d^2 Vdot(61)/{dV(85)dV(66)} + HESS(203) = 0.33*D2A(52) +! HESS(204) = d^2 Vdot(61)/{dV(66)dV(86)} = d^2 Vdot(61)/{dV(86)dV(66)} + HESS(204) = 0.36*D2A(174) +! HESS(205) = d^2 Vdot(61)/{dV(66)dV(90)} = d^2 Vdot(61)/{dV(90)dV(66)} + HESS(205) = 0.18*D2A(101) +! HESS(206) = d^2 Vdot(61)/{dV(70)dV(86)} = d^2 Vdot(61)/{dV(86)dV(70)} + HESS(206) = 0.65*D2A(134) +! HESS(207) = d^2 Vdot(61)/{dV(70)dV(90)} = d^2 Vdot(61)/{dV(90)dV(70)} + HESS(207) = 0.16*D2A(76) +! HESS(208) = d^2 Vdot(62)/{dV(49)dV(83)} = d^2 Vdot(62)/{dV(83)dV(49)} + HESS(208) = D2A(73)+D2A(74) +! HESS(209) = d^2 Vdot(62)/{dV(62)dV(84)} = d^2 Vdot(62)/{dV(84)dV(62)} + HESS(209) = -D2A(79) +! HESS(210) = d^2 Vdot(62)/{dV(62)dV(85)} = d^2 Vdot(62)/{dV(85)dV(62)} + HESS(210) = -D2A(46) +! HESS(211) = d^2 Vdot(62)/{dV(62)dV(86)} = d^2 Vdot(62)/{dV(86)dV(62)} + HESS(211) = -D2A(170)-D2A(185) +! HESS(212) = d^2 Vdot(62)/{dV(62)dV(90)} = d^2 Vdot(62)/{dV(90)dV(62)} + HESS(212) = -D2A(97) +! HESS(213) = d^2 Vdot(63)/{dV(38)dV(83)} = d^2 Vdot(63)/{dV(83)dV(38)} + HESS(213) = D2A(148) +! HESS(214) = d^2 Vdot(63)/{dV(48)dV(87)} = d^2 Vdot(63)/{dV(87)dV(48)} + HESS(214) = D2A(124) +! HESS(215) = d^2 Vdot(63)/{dV(63)dV(84)} = d^2 Vdot(63)/{dV(84)dV(63)} + HESS(215) = -D2A(91) +! HESS(216) = d^2 Vdot(63)/{dV(63)dV(85)} = d^2 Vdot(63)/{dV(85)dV(63)} + HESS(216) = -D2A(62) +! HESS(217) = d^2 Vdot(63)/{dV(63)dV(86)} = d^2 Vdot(63)/{dV(86)dV(63)} + HESS(217) = -D2A(183)-D2A(197) +! HESS(218) = d^2 Vdot(63)/{dV(63)dV(90)} = d^2 Vdot(63)/{dV(90)dV(63)} + HESS(218) = -D2A(109) +! HESS(219) = d^2 Vdot(64)/{dV(42)dV(83)} = d^2 Vdot(64)/{dV(83)dV(42)} + HESS(219) = 0.5*D2A(159) +! HESS(220) = d^2 Vdot(64)/{dV(64)dV(84)} = d^2 Vdot(64)/{dV(84)dV(64)} + HESS(220) = -D2A(85) +! HESS(221) = d^2 Vdot(64)/{dV(64)dV(85)} = d^2 Vdot(64)/{dV(85)dV(64)} + HESS(221) = -D2A(54)-D2A(55) +! HESS(222) = d^2 Vdot(64)/{dV(64)dV(86)} = d^2 Vdot(64)/{dV(86)dV(64)} + HESS(222) = -D2A(176)-D2A(190) +! HESS(223) = d^2 Vdot(64)/{dV(64)dV(90)} = d^2 Vdot(64)/{dV(90)dV(64)} + HESS(223) = -D2A(103) +! HESS(224) = d^2 Vdot(64)/{dV(77)dV(83)} = d^2 Vdot(64)/{dV(83)dV(77)} + HESS(224) = D2A(128) +! HESS(225) = d^2 Vdot(65)/{dV(43)dV(83)} = d^2 Vdot(65)/{dV(83)dV(43)} + HESS(225) = 0.5*D2A(158) +! HESS(226) = d^2 Vdot(65)/{dV(65)dV(84)} = d^2 Vdot(65)/{dV(84)dV(65)} + HESS(226) = -D2A(84) +! HESS(227) = d^2 Vdot(65)/{dV(65)dV(85)} = d^2 Vdot(65)/{dV(85)dV(65)} + HESS(227) = -D2A(53) +! HESS(228) = d^2 Vdot(65)/{dV(65)dV(86)} = d^2 Vdot(65)/{dV(86)dV(65)} + HESS(228) = -D2A(175)-D2A(193) +! HESS(229) = d^2 Vdot(65)/{dV(65)dV(90)} = d^2 Vdot(65)/{dV(90)dV(65)} + HESS(229) = -D2A(102) +! HESS(230) = d^2 Vdot(66)/{dV(41)dV(83)} = d^2 Vdot(66)/{dV(83)dV(41)} + HESS(230) = D2A(157) +! HESS(231) = d^2 Vdot(66)/{dV(58)dV(83)} = d^2 Vdot(66)/{dV(83)dV(58)} + HESS(231) = 0.44*D2A(164) +! HESS(232) = d^2 Vdot(66)/{dV(66)dV(84)} = d^2 Vdot(66)/{dV(84)dV(66)} + HESS(232) = -D2A(83) +! HESS(233) = d^2 Vdot(66)/{dV(66)dV(85)} = d^2 Vdot(66)/{dV(85)dV(66)} + HESS(233) = -D2A(52) +! HESS(234) = d^2 Vdot(66)/{dV(66)dV(86)} = d^2 Vdot(66)/{dV(86)dV(66)} + HESS(234) = -D2A(174)-D2A(189) +! HESS(235) = d^2 Vdot(66)/{dV(66)dV(90)} = d^2 Vdot(66)/{dV(90)dV(66)} + HESS(235) = -D2A(101) +! HESS(236) = d^2 Vdot(67)/{dV(39)dV(83)} = d^2 Vdot(67)/{dV(83)dV(39)} + HESS(236) = D2A(147) +! HESS(237) = d^2 Vdot(67)/{dV(46)dV(87)} = d^2 Vdot(67)/{dV(87)dV(46)} + HESS(237) = D2A(138) +! HESS(238) = d^2 Vdot(67)/{dV(67)dV(84)} = d^2 Vdot(67)/{dV(84)dV(67)} + HESS(238) = -D2A(90) +! HESS(239) = d^2 Vdot(67)/{dV(67)dV(85)} = d^2 Vdot(67)/{dV(85)dV(67)} + HESS(239) = -D2A(61) +! HESS(240) = d^2 Vdot(67)/{dV(67)dV(86)} = d^2 Vdot(67)/{dV(86)dV(67)} + HESS(240) = -D2A(182)-D2A(196) +! HESS(241) = d^2 Vdot(67)/{dV(67)dV(90)} = d^2 Vdot(67)/{dV(90)dV(67)} + HESS(241) = -D2A(108) +! HESS(242) = d^2 Vdot(68)/{dV(30)dV(83)} = d^2 Vdot(68)/{dV(83)dV(30)} + HESS(242) = 0.5*D2A(152) +! HESS(243) = d^2 Vdot(68)/{dV(31)dV(83)} = d^2 Vdot(68)/{dV(83)dV(31)} + HESS(243) = 0.5*D2A(150) +! HESS(244) = d^2 Vdot(68)/{dV(42)dV(83)} = d^2 Vdot(68)/{dV(83)dV(42)} + HESS(244) = 0.5*D2A(159) +! HESS(245) = d^2 Vdot(68)/{dV(43)dV(83)} = d^2 Vdot(68)/{dV(83)dV(43)} + HESS(245) = 0.5*D2A(158) +! HESS(246) = d^2 Vdot(68)/{dV(51)dV(86)} = d^2 Vdot(68)/{dV(86)dV(51)} + HESS(246) = D2A(194) +! HESS(247) = d^2 Vdot(68)/{dV(51)dV(90)} = d^2 Vdot(68)/{dV(90)dV(51)} + HESS(247) = 0.25*D2A(105) +! HESS(248) = d^2 Vdot(68)/{dV(52)dV(85)} = d^2 Vdot(68)/{dV(85)dV(52)} + HESS(248) = D2A(40) +! HESS(249) = d^2 Vdot(68)/{dV(52)dV(86)} = d^2 Vdot(68)/{dV(86)dV(52)} + HESS(249) = D2A(131)+D2A(133) +! HESS(250) = d^2 Vdot(68)/{dV(52)dV(90)} = d^2 Vdot(68)/{dV(90)dV(52)} + HESS(250) = 0.75*D2A(75) +! HESS(251) = d^2 Vdot(68)/{dV(54)dV(85)} = d^2 Vdot(68)/{dV(85)dV(54)} + HESS(251) = 0.57*D2A(45) +! HESS(252) = d^2 Vdot(68)/{dV(54)dV(86)} = d^2 Vdot(68)/{dV(86)dV(54)} + HESS(252) = 0.57*D2A(179)+D2A(192) +! HESS(253) = d^2 Vdot(68)/{dV(54)dV(90)} = d^2 Vdot(68)/{dV(90)dV(54)} + HESS(253) = 0.54*D2A(96) +! HESS(254) = d^2 Vdot(68)/{dV(55)dV(86)} = d^2 Vdot(68)/{dV(86)dV(55)} + HESS(254) = D2A(195) +! HESS(255) = d^2 Vdot(68)/{dV(55)dV(90)} = d^2 Vdot(68)/{dV(90)dV(55)} + HESS(255) = 0.25*D2A(106) +! HESS(256) = d^2 Vdot(68)/{dV(63)dV(86)} = d^2 Vdot(68)/{dV(86)dV(63)} + HESS(256) = D2A(197) +! HESS(257) = d^2 Vdot(68)/{dV(63)dV(90)} = d^2 Vdot(68)/{dV(90)dV(63)} + HESS(257) = 0.25*D2A(109) +! HESS(258) = d^2 Vdot(68)/{dV(65)dV(86)} = d^2 Vdot(68)/{dV(86)dV(65)} + HESS(258) = D2A(193) +! HESS(259) = d^2 Vdot(68)/{dV(65)dV(90)} = d^2 Vdot(68)/{dV(90)dV(65)} + HESS(259) = 0.25*D2A(102) +! HESS(260) = d^2 Vdot(68)/{dV(67)dV(86)} = d^2 Vdot(68)/{dV(86)dV(67)} + HESS(260) = D2A(196) +! HESS(261) = d^2 Vdot(68)/{dV(67)dV(90)} = d^2 Vdot(68)/{dV(90)dV(67)} + HESS(261) = 0.25*D2A(108) +! HESS(262) = d^2 Vdot(68)/{dV(68)dV(83)} = d^2 Vdot(68)/{dV(83)dV(68)} + HESS(262) = -D2A(65) +! HESS(263) = d^2 Vdot(68)/{dV(68)dV(87)} = d^2 Vdot(68)/{dV(87)dV(68)} + HESS(263) = -D2A(72) +! HESS(264) = d^2 Vdot(68)/{dV(70)dV(86)} = d^2 Vdot(68)/{dV(86)dV(70)} + HESS(264) = 0.35*D2A(134) +! HESS(265) = d^2 Vdot(68)/{dV(70)dV(90)} = d^2 Vdot(68)/{dV(90)dV(70)} + HESS(265) = 0.09*D2A(76) +! HESS(266) = d^2 Vdot(68)/{dV(72)dV(85)} = d^2 Vdot(68)/{dV(85)dV(72)} + HESS(266) = 0.13*D2A(43) +! HESS(267) = d^2 Vdot(68)/{dV(72)dV(86)} = d^2 Vdot(68)/{dV(86)dV(72)} + HESS(267) = 0.13*D2A(169) +! HESS(268) = d^2 Vdot(68)/{dV(72)dV(90)} = d^2 Vdot(68)/{dV(90)dV(72)} + HESS(268) = 0.07*D2A(95) +! HESS(269) = d^2 Vdot(69)/{dV(27)dV(83)} = d^2 Vdot(69)/{dV(83)dV(27)} + HESS(269) = 0.5*D2A(162) +! HESS(270) = d^2 Vdot(69)/{dV(28)dV(83)} = d^2 Vdot(69)/{dV(83)dV(28)} + HESS(270) = D2A(18) +! HESS(271) = d^2 Vdot(69)/{dV(34)dV(83)} = d^2 Vdot(69)/{dV(83)dV(34)} + HESS(271) = D2A(205) +! HESS(272) = d^2 Vdot(69)/{dV(34)dV(87)} = d^2 Vdot(69)/{dV(87)dV(34)} + HESS(272) = D2A(207) +! HESS(273) = d^2 Vdot(69)/{dV(44)dV(83)} = d^2 Vdot(69)/{dV(83)dV(44)} + HESS(273) = 2.23*D2A(121) +! HESS(274) = d^2 Vdot(69)/{dV(44)dV(89)} = d^2 Vdot(69)/{dV(89)dV(44)} + HESS(274) = 0.6*D2A(122) +! HESS(275) = d^2 Vdot(69)/{dV(46)dV(89)} = d^2 Vdot(69)/{dV(89)dV(46)} + HESS(275) = 0.9*D2A(135) +! HESS(276) = d^2 Vdot(69)/{dV(48)dV(89)} = d^2 Vdot(69)/{dV(89)dV(48)} + HESS(276) = 0.535*D2A(120) +! HESS(277) = d^2 Vdot(69)/{dV(51)dV(85)} = d^2 Vdot(69)/{dV(85)dV(51)} + HESS(277) = 0.3*D2A(58) +! HESS(278) = d^2 Vdot(69)/{dV(51)dV(86)} = d^2 Vdot(69)/{dV(86)dV(51)} + HESS(278) = D2A(180) +! HESS(279) = d^2 Vdot(69)/{dV(51)dV(90)} = d^2 Vdot(69)/{dV(90)dV(51)} + HESS(279) = 1.25*D2A(105) +! HESS(280) = d^2 Vdot(69)/{dV(52)dV(90)} = d^2 Vdot(69)/{dV(90)dV(52)} + HESS(280) = 0.75*D2A(75) +! HESS(281) = d^2 Vdot(69)/{dV(53)dV(90)} = d^2 Vdot(69)/{dV(90)dV(53)} + HESS(281) = 0.75*D2A(107) +! HESS(282) = d^2 Vdot(69)/{dV(54)dV(85)} = d^2 Vdot(69)/{dV(85)dV(54)} + HESS(282) = 0.39*D2A(45) +! HESS(283) = d^2 Vdot(69)/{dV(54)dV(86)} = d^2 Vdot(69)/{dV(86)dV(54)} + HESS(283) = 0.39*D2A(179) +! HESS(284) = d^2 Vdot(69)/{dV(54)dV(90)} = d^2 Vdot(69)/{dV(90)dV(54)} + HESS(284) = 0.95*D2A(96) +! HESS(285) = d^2 Vdot(69)/{dV(55)dV(85)} = d^2 Vdot(69)/{dV(85)dV(55)} + HESS(285) = D2A(59) +! HESS(286) = d^2 Vdot(69)/{dV(55)dV(86)} = d^2 Vdot(69)/{dV(86)dV(55)} + HESS(286) = D2A(181) +! HESS(287) = d^2 Vdot(69)/{dV(55)dV(90)} = d^2 Vdot(69)/{dV(90)dV(55)} + HESS(287) = 1.25*D2A(106) +! HESS(288) = d^2 Vdot(69)/{dV(57)dV(85)} = d^2 Vdot(69)/{dV(85)dV(57)} + HESS(288) = 0.75*D2A(50) +! HESS(289) = d^2 Vdot(69)/{dV(57)dV(86)} = d^2 Vdot(69)/{dV(86)dV(57)} + HESS(289) = 0.75*D2A(173) +! HESS(290) = d^2 Vdot(69)/{dV(57)dV(90)} = d^2 Vdot(69)/{dV(90)dV(57)} + HESS(290) = 1.13*D2A(100) +! HESS(291) = d^2 Vdot(69)/{dV(58)dV(89)} = d^2 Vdot(69)/{dV(89)dV(58)} + HESS(291) = 0.12*D2A(165) +! HESS(292) = d^2 Vdot(69)/{dV(59)dV(85)} = d^2 Vdot(69)/{dV(85)dV(59)} + HESS(292) = D2A(56) +! HESS(293) = d^2 Vdot(69)/{dV(59)dV(86)} = d^2 Vdot(69)/{dV(86)dV(59)} + HESS(293) = 0.17*D2A(177) +! HESS(294) = d^2 Vdot(69)/{dV(59)dV(90)} = d^2 Vdot(69)/{dV(90)dV(59)} + HESS(294) = 0.85*D2A(104) +! HESS(295) = d^2 Vdot(69)/{dV(60)dV(90)} = d^2 Vdot(69)/{dV(90)dV(60)} + HESS(295) = 0.75*D2A(98) +! HESS(296) = d^2 Vdot(69)/{dV(62)dV(85)} = d^2 Vdot(69)/{dV(85)dV(62)} + HESS(296) = 0.96*D2A(46) +! HESS(297) = d^2 Vdot(69)/{dV(62)dV(86)} = d^2 Vdot(69)/{dV(86)dV(62)} + HESS(297) = 0.2*D2A(170) +! HESS(298) = d^2 Vdot(69)/{dV(62)dV(90)} = d^2 Vdot(69)/{dV(90)dV(62)} + HESS(298) = 0.5*D2A(97) +! HESS(299) = d^2 Vdot(69)/{dV(63)dV(85)} = d^2 Vdot(69)/{dV(85)dV(63)} + HESS(299) = D2A(62) +! HESS(300) = d^2 Vdot(69)/{dV(63)dV(86)} = d^2 Vdot(69)/{dV(86)dV(63)} + HESS(300) = D2A(183) +! HESS(301) = d^2 Vdot(69)/{dV(63)dV(90)} = d^2 Vdot(69)/{dV(90)dV(63)} + HESS(301) = 1.25*D2A(109) +! HESS(302) = d^2 Vdot(69)/{dV(64)dV(85)} = d^2 Vdot(69)/{dV(85)dV(64)} + HESS(302) = 0.28*D2A(54) +! HESS(303) = d^2 Vdot(69)/{dV(64)dV(86)} = d^2 Vdot(69)/{dV(86)dV(64)} + HESS(303) = 0.28*D2A(176) +! HESS(304) = d^2 Vdot(69)/{dV(64)dV(90)} = d^2 Vdot(69)/{dV(90)dV(64)} + HESS(304) = 0.89*D2A(103) +! HESS(305) = d^2 Vdot(69)/{dV(65)dV(90)} = d^2 Vdot(69)/{dV(90)dV(65)} + HESS(305) = 0.75*D2A(102) +! HESS(306) = d^2 Vdot(69)/{dV(66)dV(85)} = d^2 Vdot(69)/{dV(85)dV(66)} + HESS(306) = 0.35*D2A(52) +! HESS(307) = d^2 Vdot(69)/{dV(66)dV(86)} = d^2 Vdot(69)/{dV(86)dV(66)} + HESS(307) = 0.4*D2A(174) +! HESS(308) = d^2 Vdot(69)/{dV(66)dV(90)} = d^2 Vdot(69)/{dV(90)dV(66)} + HESS(308) = 0.95*D2A(101) +! HESS(309) = d^2 Vdot(69)/{dV(67)dV(85)} = d^2 Vdot(69)/{dV(85)dV(67)} + HESS(309) = 0.15*D2A(61) +! HESS(310) = d^2 Vdot(69)/{dV(67)dV(86)} = d^2 Vdot(69)/{dV(86)dV(67)} + HESS(310) = 0.15*D2A(182) +! HESS(311) = d^2 Vdot(69)/{dV(67)dV(90)} = d^2 Vdot(69)/{dV(90)dV(67)} + HESS(311) = 0.83*D2A(108) +! HESS(312) = d^2 Vdot(69)/{dV(69)dV(83)} = d^2 Vdot(69)/{dV(83)dV(69)} + HESS(312) = -D2A(19) +! HESS(313) = d^2 Vdot(69)/{dV(69)dV(87)} = d^2 Vdot(69)/{dV(87)dV(69)} + HESS(313) = -D2A(31) +! HESS(314) = d^2 Vdot(69)/{dV(70)dV(85)} = d^2 Vdot(69)/{dV(85)dV(70)} + HESS(314) = D2A(41) +! HESS(315) = d^2 Vdot(69)/{dV(70)dV(86)} = d^2 Vdot(69)/{dV(86)dV(70)} + HESS(315) = D2A(132) +! HESS(316) = d^2 Vdot(69)/{dV(70)dV(90)} = d^2 Vdot(69)/{dV(90)dV(70)} + HESS(316) = 1.25*D2A(76) +! HESS(317) = d^2 Vdot(69)/{dV(71)dV(83)} = d^2 Vdot(69)/{dV(83)dV(71)} + HESS(317) = 0.05*D2A(32) +! HESS(318) = d^2 Vdot(69)/{dV(72)dV(90)} = d^2 Vdot(69)/{dV(90)dV(72)} + HESS(318) = 0.75*D2A(95) +! HESS(319) = d^2 Vdot(69)/{dV(74)dV(90)} = d^2 Vdot(69)/{dV(90)dV(74)} + HESS(319) = 0.75*D2A(93) +! HESS(320) = d^2 Vdot(69)/{dV(77)dV(89)} = d^2 Vdot(69)/{dV(89)dV(77)} + HESS(320) = 0.8*D2A(136) +! HESS(321) = d^2 Vdot(69)/{dV(78)dV(85)} = d^2 Vdot(69)/{dV(85)dV(78)} + HESS(321) = D2A(71) +! HESS(322) = d^2 Vdot(69)/{dV(78)dV(86)} = d^2 Vdot(69)/{dV(86)dV(78)} + HESS(322) = D2A(203) +! HESS(323) = d^2 Vdot(69)/{dV(78)dV(90)} = d^2 Vdot(69)/{dV(90)dV(78)} + HESS(323) = 2*D2A(143)+D2A(146) +! HESS(324) = d^2 Vdot(69)/{dV(79)dV(85)} = d^2 Vdot(69)/{dV(85)dV(79)} + HESS(324) = 0.56*D2A(48) +! HESS(325) = d^2 Vdot(69)/{dV(79)dV(86)} = d^2 Vdot(69)/{dV(86)dV(79)} + HESS(325) = 0.69*D2A(172) +! HESS(326) = d^2 Vdot(69)/{dV(79)dV(90)} = d^2 Vdot(69)/{dV(90)dV(79)} + HESS(326) = 1.1*D2A(99) +! HESS(327) = d^2 Vdot(69)/{dV(80)dV(89)} = d^2 Vdot(69)/{dV(89)dV(80)} + HESS(327) = 0.7*D2A(137) +! HESS(328) = d^2 Vdot(69)/{dV(81)dV(90)} = d^2 Vdot(69)/{dV(90)dV(81)} + HESS(328) = D2A(141)+D2A(144) +! HESS(329) = d^2 Vdot(69)/{dV(84)dV(88)} = d^2 Vdot(69)/{dV(88)dV(84)} + HESS(329) = 0.29*D2A(117) +! HESS(330) = d^2 Vdot(69)/{dV(85)dV(88)} = d^2 Vdot(69)/{dV(88)dV(85)} + HESS(330) = D2A(70) +! HESS(331) = d^2 Vdot(69)/{dV(85)dV(90)} = d^2 Vdot(69)/{dV(90)dV(85)} + HESS(331) = D2A(13) +! HESS(332) = d^2 Vdot(69)/{dV(86)dV(88)} = d^2 Vdot(69)/{dV(88)dV(86)} + HESS(332) = D2A(202) +! HESS(333) = d^2 Vdot(69)/{dV(86)dV(90)} = d^2 Vdot(69)/{dV(90)dV(86)} + HESS(333) = D2A(167)+D2A(168) +! HESS(334) = d^2 Vdot(69)/{dV(88)dV(90)} = d^2 Vdot(69)/{dV(90)dV(88)} + HESS(334) = 2*D2A(142)+D2A(145) +! HESS(335) = d^2 Vdot(69)/{dV(89)dV(90)} = d^2 Vdot(69)/{dV(90)dV(89)} + HESS(335) = D2A(5) +! HESS(336) = d^2 Vdot(69)/{dV(90)dV(90)} = d^2 Vdot(69)/{dV(90)dV(90)} + HESS(336) = D2A(15)+2*D2A(16) +! HESS(337) = d^2 Vdot(70)/{dV(37)dV(83)} = d^2 Vdot(70)/{dV(83)dV(37)} + HESS(337) = D2A(154) +! HESS(338) = d^2 Vdot(70)/{dV(48)dV(83)} = d^2 Vdot(70)/{dV(83)dV(48)} + HESS(338) = D2A(119) +! HESS(339) = d^2 Vdot(70)/{dV(70)dV(84)} = d^2 Vdot(70)/{dV(84)dV(70)} + HESS(339) = -D2A(114) +! HESS(340) = d^2 Vdot(70)/{dV(70)dV(85)} = d^2 Vdot(70)/{dV(85)dV(70)} + HESS(340) = -D2A(41) +! HESS(341) = d^2 Vdot(70)/{dV(70)dV(86)} = d^2 Vdot(70)/{dV(86)dV(70)} + HESS(341) = -D2A(132)-D2A(134) +! HESS(342) = d^2 Vdot(70)/{dV(70)dV(90)} = d^2 Vdot(70)/{dV(90)dV(70)} + HESS(342) = -D2A(76) +! HESS(343) = d^2 Vdot(71)/{dV(33)dV(83)} = d^2 Vdot(71)/{dV(83)dV(33)} + HESS(343) = 0.5*D2A(153) +! HESS(344) = d^2 Vdot(71)/{dV(35)dV(83)} = d^2 Vdot(71)/{dV(83)dV(35)} + HESS(344) = 0.5*D2A(149) +! HESS(345) = d^2 Vdot(71)/{dV(48)dV(89)} = d^2 Vdot(71)/{dV(89)dV(48)} + HESS(345) = 0.5*D2A(120) +! HESS(346) = d^2 Vdot(71)/{dV(54)dV(85)} = d^2 Vdot(71)/{dV(85)dV(54)} + HESS(346) = 0.75*D2A(45) +! HESS(347) = d^2 Vdot(71)/{dV(54)dV(86)} = d^2 Vdot(71)/{dV(86)dV(54)} + HESS(347) = 0.75*D2A(179) +! HESS(348) = d^2 Vdot(71)/{dV(54)dV(90)} = d^2 Vdot(71)/{dV(90)dV(54)} + HESS(348) = 0.38*D2A(96) +! HESS(349) = d^2 Vdot(71)/{dV(60)dV(85)} = d^2 Vdot(71)/{dV(85)dV(60)} + HESS(349) = 0.93*D2A(47) +! HESS(350) = d^2 Vdot(71)/{dV(60)dV(86)} = d^2 Vdot(71)/{dV(86)dV(60)} + HESS(350) = D2A(171) +! HESS(351) = d^2 Vdot(71)/{dV(60)dV(90)} = d^2 Vdot(71)/{dV(90)dV(60)} + HESS(351) = 0.5*D2A(98) +! HESS(352) = d^2 Vdot(71)/{dV(63)dV(85)} = d^2 Vdot(71)/{dV(85)dV(63)} + HESS(352) = D2A(62) +! HESS(353) = d^2 Vdot(71)/{dV(63)dV(86)} = d^2 Vdot(71)/{dV(86)dV(63)} + HESS(353) = D2A(183) +! HESS(354) = d^2 Vdot(71)/{dV(63)dV(90)} = d^2 Vdot(71)/{dV(90)dV(63)} + HESS(354) = 0.5*D2A(109) +! HESS(355) = d^2 Vdot(71)/{dV(70)dV(85)} = d^2 Vdot(71)/{dV(85)dV(70)} + HESS(355) = D2A(41) +! HESS(356) = d^2 Vdot(71)/{dV(70)dV(86)} = d^2 Vdot(71)/{dV(86)dV(70)} + HESS(356) = D2A(132) +! HESS(357) = d^2 Vdot(71)/{dV(70)dV(90)} = d^2 Vdot(71)/{dV(90)dV(70)} + HESS(357) = 0.5*D2A(76) +! HESS(358) = d^2 Vdot(71)/{dV(71)dV(83)} = d^2 Vdot(71)/{dV(83)dV(71)} + HESS(358) = -D2A(32) +! HESS(359) = d^2 Vdot(71)/{dV(71)dV(87)} = d^2 Vdot(71)/{dV(87)dV(71)} + HESS(359) = -D2A(33) +! HESS(360) = d^2 Vdot(71)/{dV(72)dV(85)} = d^2 Vdot(71)/{dV(85)dV(72)} + HESS(360) = 0.32*D2A(43) +! HESS(361) = d^2 Vdot(71)/{dV(72)dV(86)} = d^2 Vdot(71)/{dV(86)dV(72)} + HESS(361) = 0.32*D2A(169) +! HESS(362) = d^2 Vdot(71)/{dV(72)dV(90)} = d^2 Vdot(71)/{dV(90)dV(72)} + HESS(362) = 0.16*D2A(95) +! HESS(363) = d^2 Vdot(71)/{dV(74)dV(74)} = d^2 Vdot(71)/{dV(74)dV(74)} + HESS(363) = 2*D2A(110)+D2A(111) +! HESS(364) = d^2 Vdot(71)/{dV(74)dV(85)} = d^2 Vdot(71)/{dV(85)dV(74)} + HESS(364) = D2A(37) +! HESS(365) = d^2 Vdot(71)/{dV(74)dV(86)} = d^2 Vdot(71)/{dV(86)dV(74)} + HESS(365) = D2A(199)+D2A(200) +! HESS(366) = d^2 Vdot(71)/{dV(74)dV(90)} = d^2 Vdot(71)/{dV(90)dV(74)} + HESS(366) = 0.75*D2A(93) +! HESS(367) = d^2 Vdot(71)/{dV(77)dV(89)} = d^2 Vdot(71)/{dV(89)dV(77)} + HESS(367) = 0.04*D2A(136) +! HESS(368) = d^2 Vdot(72)/{dV(22)dV(83)} = d^2 Vdot(72)/{dV(83)dV(22)} + HESS(368) = D2A(42) +! HESS(369) = d^2 Vdot(72)/{dV(22)dV(87)} = d^2 Vdot(72)/{dV(87)dV(22)} + HESS(369) = D2A(63) +! HESS(370) = d^2 Vdot(72)/{dV(30)dV(83)} = d^2 Vdot(72)/{dV(83)dV(30)} + HESS(370) = 0.5*D2A(152) +! HESS(371) = d^2 Vdot(72)/{dV(54)dV(85)} = d^2 Vdot(72)/{dV(85)dV(54)} + HESS(371) = 0.3*D2A(45) +! HESS(372) = d^2 Vdot(72)/{dV(54)dV(86)} = d^2 Vdot(72)/{dV(86)dV(54)} + HESS(372) = 0.3*D2A(179) +! HESS(373) = d^2 Vdot(72)/{dV(54)dV(90)} = d^2 Vdot(72)/{dV(90)dV(54)} + HESS(373) = 0.15*D2A(96) +! HESS(374) = d^2 Vdot(72)/{dV(72)dV(84)} = d^2 Vdot(72)/{dV(84)dV(72)} + HESS(374) = -D2A(77) +! HESS(375) = d^2 Vdot(72)/{dV(72)dV(85)} = d^2 Vdot(72)/{dV(85)dV(72)} + HESS(375) = -D2A(43)-D2A(44) +! HESS(376) = d^2 Vdot(72)/{dV(72)dV(86)} = d^2 Vdot(72)/{dV(86)dV(72)} + HESS(376) = -D2A(169)-D2A(184) +! HESS(377) = d^2 Vdot(72)/{dV(72)dV(90)} = d^2 Vdot(72)/{dV(90)dV(72)} + HESS(377) = -D2A(95) +! HESS(378) = d^2 Vdot(73)/{dV(54)dV(84)} = d^2 Vdot(73)/{dV(84)dV(54)} + HESS(378) = D2A(78) +! HESS(379) = d^2 Vdot(73)/{dV(60)dV(85)} = d^2 Vdot(73)/{dV(85)dV(60)} + HESS(379) = 0.07*D2A(47) +! HESS(380) = d^2 Vdot(73)/{dV(62)dV(85)} = d^2 Vdot(73)/{dV(85)dV(62)} + HESS(380) = 0.04*D2A(46) +! HESS(381) = d^2 Vdot(73)/{dV(72)dV(85)} = d^2 Vdot(73)/{dV(85)dV(72)} + HESS(381) = D2A(44) +! HESS(382) = d^2 Vdot(73)/{dV(73)dV(83)} = d^2 Vdot(73)/{dV(83)dV(73)} + HESS(382) = -D2A(64) +! HESS(383) = d^2 Vdot(74)/{dV(23)dV(83)} = d^2 Vdot(74)/{dV(83)dV(23)} + HESS(383) = D2A(36) +! HESS(384) = d^2 Vdot(74)/{dV(23)dV(87)} = d^2 Vdot(74)/{dV(87)dV(23)} + HESS(384) = D2A(163) +! HESS(385) = d^2 Vdot(74)/{dV(35)dV(83)} = d^2 Vdot(74)/{dV(83)dV(35)} + HESS(385) = 0.5*D2A(149) +! HESS(386) = d^2 Vdot(74)/{dV(72)dV(85)} = d^2 Vdot(74)/{dV(85)dV(72)} + HESS(386) = 0.32*D2A(43) +! HESS(387) = d^2 Vdot(74)/{dV(72)dV(86)} = d^2 Vdot(74)/{dV(86)dV(72)} + HESS(387) = 0.32*D2A(169) +! HESS(388) = d^2 Vdot(74)/{dV(72)dV(90)} = d^2 Vdot(74)/{dV(90)dV(72)} + HESS(388) = 0.16*D2A(95) +! HESS(389) = d^2 Vdot(74)/{dV(74)dV(74)} = d^2 Vdot(74)/{dV(74)dV(74)} + HESS(389) = -2*D2A(110)-2*D2A(111) +! HESS(390) = d^2 Vdot(74)/{dV(74)dV(84)} = d^2 Vdot(74)/{dV(84)dV(74)} + HESS(390) = -D2A(112) +! HESS(391) = d^2 Vdot(74)/{dV(74)dV(85)} = d^2 Vdot(74)/{dV(85)dV(74)} + HESS(391) = -D2A(37) +! HESS(392) = d^2 Vdot(74)/{dV(74)dV(86)} = d^2 Vdot(74)/{dV(86)dV(74)} + HESS(392) = -D2A(199)-D2A(200) +! HESS(393) = d^2 Vdot(74)/{dV(74)dV(90)} = d^2 Vdot(74)/{dV(90)dV(74)} + HESS(393) = -D2A(93) +! HESS(394) = d^2 Vdot(74)/{dV(81)dV(85)} = d^2 Vdot(74)/{dV(85)dV(81)} + HESS(394) = D2A(69) +! HESS(395) = d^2 Vdot(74)/{dV(81)dV(86)} = d^2 Vdot(74)/{dV(86)dV(81)} + HESS(395) = D2A(201) +! HESS(396) = d^2 Vdot(74)/{dV(81)dV(90)} = d^2 Vdot(74)/{dV(90)dV(81)} + HESS(396) = D2A(141) +! HESS(397) = d^2 Vdot(75)/{dV(51)dV(85)} = d^2 Vdot(75)/{dV(85)dV(51)} + HESS(397) = 0.3*D2A(58) +! HESS(398) = d^2 Vdot(75)/{dV(51)dV(86)} = d^2 Vdot(75)/{dV(86)dV(51)} + HESS(398) = 0.5*D2A(180) +! HESS(399) = d^2 Vdot(75)/{dV(51)dV(90)} = d^2 Vdot(75)/{dV(90)dV(51)} + HESS(399) = 0.25*D2A(105) +! HESS(400) = d^2 Vdot(75)/{dV(55)dV(85)} = d^2 Vdot(75)/{dV(85)dV(55)} + HESS(400) = D2A(59) +! HESS(401) = d^2 Vdot(75)/{dV(55)dV(86)} = d^2 Vdot(75)/{dV(86)dV(55)} + HESS(401) = D2A(181) +! HESS(402) = d^2 Vdot(75)/{dV(55)dV(90)} = d^2 Vdot(75)/{dV(90)dV(55)} + HESS(402) = 0.5*D2A(106) +! HESS(403) = d^2 Vdot(75)/{dV(58)dV(89)} = d^2 Vdot(75)/{dV(89)dV(58)} + HESS(403) = 0.6*D2A(165) +! HESS(404) = d^2 Vdot(75)/{dV(59)dV(86)} = d^2 Vdot(75)/{dV(86)dV(59)} + HESS(404) = 0.17*D2A(177) +! HESS(405) = d^2 Vdot(75)/{dV(60)dV(84)} = d^2 Vdot(75)/{dV(84)dV(60)} + HESS(405) = D2A(80) +! HESS(406) = d^2 Vdot(75)/{dV(61)dV(83)} = d^2 Vdot(75)/{dV(83)dV(61)} + HESS(406) = D2A(130) +! HESS(407) = d^2 Vdot(75)/{dV(62)dV(86)} = d^2 Vdot(75)/{dV(86)dV(62)} + HESS(407) = 0.8*D2A(170) +! HESS(408) = d^2 Vdot(75)/{dV(62)dV(90)} = d^2 Vdot(75)/{dV(90)dV(62)} + HESS(408) = 0.5*D2A(97) +! HESS(409) = d^2 Vdot(75)/{dV(64)dV(85)} = d^2 Vdot(75)/{dV(85)dV(64)} + HESS(409) = 0.28*D2A(54) +! HESS(410) = d^2 Vdot(75)/{dV(64)dV(86)} = d^2 Vdot(75)/{dV(86)dV(64)} + HESS(410) = 0.28*D2A(176) +! HESS(411) = d^2 Vdot(75)/{dV(64)dV(90)} = d^2 Vdot(75)/{dV(90)dV(64)} + HESS(411) = 0.14*D2A(103) +! HESS(412) = d^2 Vdot(75)/{dV(66)dV(85)} = d^2 Vdot(75)/{dV(85)dV(66)} + HESS(412) = 0.53*D2A(52) +! HESS(413) = d^2 Vdot(75)/{dV(66)dV(86)} = d^2 Vdot(75)/{dV(86)dV(66)} + HESS(413) = 0.58*D2A(174) +! HESS(414) = d^2 Vdot(75)/{dV(66)dV(90)} = d^2 Vdot(75)/{dV(90)dV(66)} + HESS(414) = 0.29*D2A(101) +! HESS(415) = d^2 Vdot(75)/{dV(75)dV(83)} = d^2 Vdot(75)/{dV(83)dV(75)} + HESS(415) = -D2A(125) +! HESS(416) = d^2 Vdot(75)/{dV(75)dV(87)} = d^2 Vdot(75)/{dV(87)dV(75)} + HESS(416) = -D2A(126) +! HESS(417) = d^2 Vdot(75)/{dV(77)dV(89)} = d^2 Vdot(75)/{dV(89)dV(77)} + HESS(417) = 0.82*D2A(136) +! HESS(418) = d^2 Vdot(75)/{dV(80)dV(89)} = d^2 Vdot(75)/{dV(89)dV(80)} + HESS(418) = 0.8*D2A(137) +! HESS(419) = d^2 Vdot(76)/{dV(57)dV(86)} = d^2 Vdot(76)/{dV(86)dV(57)} + HESS(419) = D2A(188) +! HESS(420) = d^2 Vdot(76)/{dV(57)dV(90)} = d^2 Vdot(76)/{dV(90)dV(57)} + HESS(420) = 0.25*D2A(100) +! HESS(421) = d^2 Vdot(76)/{dV(59)dV(86)} = d^2 Vdot(76)/{dV(86)dV(59)} + HESS(421) = D2A(191) +! HESS(422) = d^2 Vdot(76)/{dV(60)dV(86)} = d^2 Vdot(76)/{dV(86)dV(60)} + HESS(422) = D2A(186) +! HESS(423) = d^2 Vdot(76)/{dV(60)dV(90)} = d^2 Vdot(76)/{dV(90)dV(60)} + HESS(423) = 0.25*D2A(98) +! HESS(424) = d^2 Vdot(76)/{dV(62)dV(86)} = d^2 Vdot(76)/{dV(86)dV(62)} + HESS(424) = D2A(185) +! HESS(425) = d^2 Vdot(76)/{dV(64)dV(86)} = d^2 Vdot(76)/{dV(86)dV(64)} + HESS(425) = D2A(190) +! HESS(426) = d^2 Vdot(76)/{dV(64)dV(90)} = d^2 Vdot(76)/{dV(90)dV(64)} + HESS(426) = 0.25*D2A(103) +! HESS(427) = d^2 Vdot(76)/{dV(66)dV(86)} = d^2 Vdot(76)/{dV(86)dV(66)} + HESS(427) = D2A(189) +! HESS(428) = d^2 Vdot(76)/{dV(66)dV(90)} = d^2 Vdot(76)/{dV(90)dV(66)} + HESS(428) = 0.25*D2A(101) +! HESS(429) = d^2 Vdot(76)/{dV(72)dV(85)} = d^2 Vdot(76)/{dV(85)dV(72)} + HESS(429) = 0.19*D2A(43) +! HESS(430) = d^2 Vdot(76)/{dV(72)dV(86)} = d^2 Vdot(76)/{dV(86)dV(72)} + HESS(430) = 0.19*D2A(169)+D2A(184) +! HESS(431) = d^2 Vdot(76)/{dV(72)dV(90)} = d^2 Vdot(76)/{dV(90)dV(72)} + HESS(431) = 0.35*D2A(95) +! HESS(432) = d^2 Vdot(76)/{dV(76)dV(83)} = d^2 Vdot(76)/{dV(83)dV(76)} + HESS(432) = -D2A(92) +! HESS(433) = d^2 Vdot(76)/{dV(76)dV(87)} = d^2 Vdot(76)/{dV(87)dV(76)} + HESS(433) = -D2A(94) +! HESS(434) = d^2 Vdot(76)/{dV(79)dV(86)} = d^2 Vdot(76)/{dV(86)dV(79)} + HESS(434) = D2A(187) +! HESS(435) = d^2 Vdot(76)/{dV(79)dV(90)} = d^2 Vdot(76)/{dV(90)dV(79)} + HESS(435) = 0.25*D2A(99) +! HESS(436) = d^2 Vdot(77)/{dV(46)dV(89)} = d^2 Vdot(77)/{dV(89)dV(46)} + HESS(436) = 0.159*D2A(135) +! HESS(437) = d^2 Vdot(77)/{dV(67)dV(85)} = d^2 Vdot(77)/{dV(85)dV(67)} + HESS(437) = 0.05*D2A(61) +! HESS(438) = d^2 Vdot(77)/{dV(67)dV(86)} = d^2 Vdot(77)/{dV(86)dV(67)} + HESS(438) = 0.05*D2A(182) +! HESS(439) = d^2 Vdot(77)/{dV(67)dV(90)} = d^2 Vdot(77)/{dV(90)dV(67)} + HESS(439) = 0.03*D2A(108) +! HESS(440) = d^2 Vdot(77)/{dV(77)dV(83)} = d^2 Vdot(77)/{dV(83)dV(77)} + HESS(440) = -D2A(128) +! HESS(441) = d^2 Vdot(77)/{dV(77)dV(89)} = d^2 Vdot(77)/{dV(89)dV(77)} + HESS(441) = -D2A(136) +! HESS(442) = d^2 Vdot(77)/{dV(79)dV(85)} = d^2 Vdot(77)/{dV(85)dV(79)} + HESS(442) = 0.34*D2A(48) +! HESS(443) = d^2 Vdot(77)/{dV(79)dV(86)} = d^2 Vdot(77)/{dV(86)dV(79)} + HESS(443) = 0.402*D2A(172) +! HESS(444) = d^2 Vdot(77)/{dV(79)dV(90)} = d^2 Vdot(77)/{dV(90)dV(79)} + HESS(444) = 0.2*D2A(99) +! HESS(445) = d^2 Vdot(78)/{dV(26)dV(83)} = d^2 Vdot(78)/{dV(83)dV(26)} + HESS(445) = D2A(161) +! HESS(446) = d^2 Vdot(78)/{dV(58)dV(83)} = d^2 Vdot(78)/{dV(83)dV(58)} + HESS(446) = 0.41*D2A(164) +! HESS(447) = d^2 Vdot(78)/{dV(78)dV(82)} = d^2 Vdot(78)/{dV(82)dV(78)} + HESS(447) = -D2A(68) +! HESS(448) = d^2 Vdot(78)/{dV(78)dV(84)} = d^2 Vdot(78)/{dV(84)dV(78)} + HESS(448) = -D2A(118) +! HESS(449) = d^2 Vdot(78)/{dV(78)dV(85)} = d^2 Vdot(78)/{dV(85)dV(78)} + HESS(449) = -D2A(71) +! HESS(450) = d^2 Vdot(78)/{dV(78)dV(86)} = d^2 Vdot(78)/{dV(86)dV(78)} + HESS(450) = -D2A(203) +! HESS(451) = d^2 Vdot(78)/{dV(78)dV(90)} = d^2 Vdot(78)/{dV(90)dV(78)} + HESS(451) = -D2A(143)-D2A(146) +! HESS(452) = d^2 Vdot(78)/{dV(80)dV(83)} = d^2 Vdot(78)/{dV(83)dV(80)} + HESS(452) = 0.57*D2A(129) +! HESS(453) = d^2 Vdot(78)/{dV(80)dV(87)} = d^2 Vdot(78)/{dV(87)dV(80)} + HESS(453) = D2A(140) +! HESS(454) = d^2 Vdot(79)/{dV(45)dV(83)} = d^2 Vdot(79)/{dV(83)dV(45)} + HESS(454) = 0.491*D2A(156) +! HESS(455) = d^2 Vdot(79)/{dV(46)dV(83)} = d^2 Vdot(79)/{dV(83)dV(46)} + HESS(455) = D2A(127) +! HESS(456) = d^2 Vdot(79)/{dV(79)dV(84)} = d^2 Vdot(79)/{dV(84)dV(79)} + HESS(456) = -D2A(81) +! HESS(457) = d^2 Vdot(79)/{dV(79)dV(85)} = d^2 Vdot(79)/{dV(85)dV(79)} + HESS(457) = -D2A(48)-D2A(49) +! HESS(458) = d^2 Vdot(79)/{dV(79)dV(86)} = d^2 Vdot(79)/{dV(86)dV(79)} + HESS(458) = -D2A(172)-D2A(187) +! HESS(459) = d^2 Vdot(79)/{dV(79)dV(90)} = d^2 Vdot(79)/{dV(90)dV(79)} + HESS(459) = -D2A(99) +! HESS(460) = d^2 Vdot(80)/{dV(46)dV(89)} = d^2 Vdot(80)/{dV(89)dV(46)} + HESS(460) = 0.387*D2A(135) +! HESS(461) = d^2 Vdot(80)/{dV(67)dV(85)} = d^2 Vdot(80)/{dV(85)dV(67)} + HESS(461) = 0.1*D2A(61) +! HESS(462) = d^2 Vdot(80)/{dV(67)dV(86)} = d^2 Vdot(80)/{dV(86)dV(67)} + HESS(462) = 0.1*D2A(182) +! HESS(463) = d^2 Vdot(80)/{dV(67)dV(90)} = d^2 Vdot(80)/{dV(90)dV(67)} + HESS(463) = 0.05*D2A(108) +! HESS(464) = d^2 Vdot(80)/{dV(79)dV(85)} = d^2 Vdot(80)/{dV(85)dV(79)} + HESS(464) = 0.22*D2A(48) +! HESS(465) = d^2 Vdot(80)/{dV(79)dV(86)} = d^2 Vdot(80)/{dV(86)dV(79)} + HESS(465) = 0.288*D2A(172) +! HESS(466) = d^2 Vdot(80)/{dV(79)dV(90)} = d^2 Vdot(80)/{dV(90)dV(79)} + HESS(466) = 0.14*D2A(99) +! HESS(467) = d^2 Vdot(80)/{dV(80)dV(83)} = d^2 Vdot(80)/{dV(83)dV(80)} + HESS(467) = -D2A(129) +! HESS(468) = d^2 Vdot(80)/{dV(80)dV(87)} = d^2 Vdot(80)/{dV(87)dV(80)} + HESS(468) = -D2A(139)-D2A(140) +! HESS(469) = d^2 Vdot(80)/{dV(80)dV(89)} = d^2 Vdot(80)/{dV(89)dV(80)} + HESS(469) = -D2A(137) +! HESS(470) = d^2 Vdot(81)/{dV(33)dV(83)} = d^2 Vdot(81)/{dV(83)dV(33)} + HESS(470) = 0.5*D2A(153) +! HESS(471) = d^2 Vdot(81)/{dV(68)dV(83)} = d^2 Vdot(81)/{dV(83)dV(68)} + HESS(471) = D2A(65) +! HESS(472) = d^2 Vdot(81)/{dV(68)dV(87)} = d^2 Vdot(81)/{dV(87)dV(68)} + HESS(472) = D2A(72) +! HESS(473) = d^2 Vdot(81)/{dV(81)dV(82)} = d^2 Vdot(81)/{dV(82)dV(81)} + HESS(473) = -D2A(66) +! HESS(474) = d^2 Vdot(81)/{dV(81)dV(84)} = d^2 Vdot(81)/{dV(84)dV(81)} + HESS(474) = -D2A(116) +! HESS(475) = d^2 Vdot(81)/{dV(81)dV(85)} = d^2 Vdot(81)/{dV(85)dV(81)} + HESS(475) = -D2A(69) +! HESS(476) = d^2 Vdot(81)/{dV(81)dV(86)} = d^2 Vdot(81)/{dV(86)dV(81)} + HESS(476) = -D2A(201) +! HESS(477) = d^2 Vdot(81)/{dV(81)dV(90)} = d^2 Vdot(81)/{dV(90)dV(81)} + HESS(477) = -D2A(141)-D2A(144) +! HESS(478) = d^2 Vdot(82)/{dV(24)dV(83)} = d^2 Vdot(82)/{dV(83)dV(24)} + HESS(478) = D2A(23) +! HESS(479) = d^2 Vdot(82)/{dV(29)dV(83)} = d^2 Vdot(82)/{dV(83)dV(29)} + HESS(479) = D2A(25) +! HESS(480) = d^2 Vdot(82)/{dV(43)dV(83)} = d^2 Vdot(82)/{dV(83)dV(43)} + HESS(480) = 0.5*D2A(158) +! HESS(481) = d^2 Vdot(82)/{dV(44)dV(83)} = d^2 Vdot(82)/{dV(83)dV(44)} + HESS(481) = D2A(121) +! HESS(482) = d^2 Vdot(82)/{dV(44)dV(89)} = d^2 Vdot(82)/{dV(89)dV(44)} + HESS(482) = D2A(122) +! HESS(483) = d^2 Vdot(82)/{dV(51)dV(85)} = d^2 Vdot(82)/{dV(85)dV(51)} + HESS(483) = 1.9*D2A(58) +! HESS(484) = d^2 Vdot(82)/{dV(51)dV(86)} = d^2 Vdot(82)/{dV(86)dV(51)} + HESS(484) = D2A(180)+D2A(194) +! HESS(485) = d^2 Vdot(82)/{dV(51)dV(90)} = d^2 Vdot(82)/{dV(90)dV(51)} + HESS(485) = D2A(105) +! HESS(486) = d^2 Vdot(82)/{dV(52)dV(85)} = d^2 Vdot(82)/{dV(85)dV(52)} + HESS(486) = D2A(40) +! HESS(487) = d^2 Vdot(82)/{dV(53)dV(85)} = d^2 Vdot(82)/{dV(85)dV(53)} + HESS(487) = D2A(60) +! HESS(488) = d^2 Vdot(82)/{dV(54)dV(85)} = d^2 Vdot(82)/{dV(85)dV(54)} + HESS(488) = 2*D2A(45) +! HESS(489) = d^2 Vdot(82)/{dV(54)dV(86)} = d^2 Vdot(82)/{dV(86)dV(54)} + HESS(489) = D2A(179)+D2A(192) +! HESS(490) = d^2 Vdot(82)/{dV(54)dV(90)} = d^2 Vdot(82)/{dV(90)dV(54)} + HESS(490) = D2A(96) +! HESS(491) = d^2 Vdot(82)/{dV(55)dV(85)} = d^2 Vdot(82)/{dV(85)dV(55)} + HESS(491) = 2*D2A(59) +! HESS(492) = d^2 Vdot(82)/{dV(55)dV(86)} = d^2 Vdot(82)/{dV(86)dV(55)} + HESS(492) = D2A(181)+D2A(195) +! HESS(493) = d^2 Vdot(82)/{dV(55)dV(90)} = d^2 Vdot(82)/{dV(90)dV(55)} + HESS(493) = D2A(106) +! HESS(494) = d^2 Vdot(82)/{dV(57)dV(85)} = d^2 Vdot(82)/{dV(85)dV(57)} + HESS(494) = D2A(50) +! HESS(495) = d^2 Vdot(82)/{dV(59)dV(85)} = d^2 Vdot(82)/{dV(85)dV(59)} + HESS(495) = D2A(56) +! HESS(496) = d^2 Vdot(82)/{dV(60)dV(85)} = d^2 Vdot(82)/{dV(85)dV(60)} + HESS(496) = 0.93*D2A(47) +! HESS(497) = d^2 Vdot(82)/{dV(62)dV(85)} = d^2 Vdot(82)/{dV(85)dV(62)} + HESS(497) = 0.96*D2A(46) +! HESS(498) = d^2 Vdot(82)/{dV(63)dV(85)} = d^2 Vdot(82)/{dV(85)dV(63)} + HESS(498) = 2*D2A(62) +! HESS(499) = d^2 Vdot(82)/{dV(63)dV(86)} = d^2 Vdot(82)/{dV(86)dV(63)} + HESS(499) = D2A(183)+D2A(197) +! HESS(500) = d^2 Vdot(82)/{dV(63)dV(90)} = d^2 Vdot(82)/{dV(90)dV(63)} + HESS(500) = D2A(109) +! HESS(501) = d^2 Vdot(82)/{dV(64)dV(85)} = d^2 Vdot(82)/{dV(85)dV(64)} + HESS(501) = D2A(54) +! HESS(502) = d^2 Vdot(82)/{dV(65)dV(85)} = d^2 Vdot(82)/{dV(85)dV(65)} + HESS(502) = 1.95*D2A(53) +! HESS(503) = d^2 Vdot(82)/{dV(65)dV(86)} = d^2 Vdot(82)/{dV(86)dV(65)} + HESS(503) = D2A(175)+D2A(193) +! HESS(504) = d^2 Vdot(82)/{dV(65)dV(90)} = d^2 Vdot(82)/{dV(90)dV(65)} + HESS(504) = D2A(102) +! HESS(505) = d^2 Vdot(82)/{dV(66)dV(85)} = d^2 Vdot(82)/{dV(85)dV(66)} + HESS(505) = 0.92*D2A(52) +! HESS(506) = d^2 Vdot(82)/{dV(67)dV(85)} = d^2 Vdot(82)/{dV(85)dV(67)} + HESS(506) = 1.15*D2A(61) +! HESS(507) = d^2 Vdot(82)/{dV(67)dV(86)} = d^2 Vdot(82)/{dV(86)dV(67)} + HESS(507) = 0.15*D2A(182)+D2A(196) +! HESS(508) = d^2 Vdot(82)/{dV(67)dV(90)} = d^2 Vdot(82)/{dV(90)dV(67)} + HESS(508) = 0.575*D2A(108) +! HESS(509) = d^2 Vdot(82)/{dV(70)dV(85)} = d^2 Vdot(82)/{dV(85)dV(70)} + HESS(509) = D2A(41) +! HESS(510) = d^2 Vdot(82)/{dV(72)dV(85)} = d^2 Vdot(82)/{dV(85)dV(72)} + HESS(510) = D2A(43) +! HESS(511) = d^2 Vdot(82)/{dV(74)dV(85)} = d^2 Vdot(82)/{dV(85)dV(74)} + HESS(511) = D2A(37) +! HESS(512) = d^2 Vdot(82)/{dV(78)dV(82)} = d^2 Vdot(82)/{dV(82)dV(78)} + HESS(512) = -D2A(68) +! HESS(513) = d^2 Vdot(82)/{dV(78)dV(85)} = d^2 Vdot(82)/{dV(85)dV(78)} + HESS(513) = D2A(71) +! HESS(514) = d^2 Vdot(82)/{dV(79)dV(85)} = d^2 Vdot(82)/{dV(85)dV(79)} + HESS(514) = 0.9*D2A(48) +! HESS(515) = d^2 Vdot(82)/{dV(81)dV(82)} = d^2 Vdot(82)/{dV(82)dV(81)} + HESS(515) = -D2A(66) +! HESS(516) = d^2 Vdot(82)/{dV(81)dV(85)} = d^2 Vdot(82)/{dV(85)dV(81)} + HESS(516) = D2A(69) +! HESS(517) = d^2 Vdot(82)/{dV(82)dV(83)} = d^2 Vdot(82)/{dV(83)dV(82)} + HESS(517) = -D2A(20) +! HESS(518) = d^2 Vdot(82)/{dV(82)dV(84)} = d^2 Vdot(82)/{dV(84)dV(82)} + HESS(518) = -D2A(24) +! HESS(519) = d^2 Vdot(82)/{dV(82)dV(86)} = d^2 Vdot(82)/{dV(86)dV(82)} + HESS(519) = -D2A(34) +! HESS(520) = d^2 Vdot(82)/{dV(82)dV(87)} = d^2 Vdot(82)/{dV(87)dV(82)} + HESS(520) = -D2A(29) +! HESS(521) = d^2 Vdot(82)/{dV(82)dV(88)} = d^2 Vdot(82)/{dV(88)dV(82)} + HESS(521) = -D2A(67) +! HESS(522) = d^2 Vdot(82)/{dV(82)dV(89)} = d^2 Vdot(82)/{dV(89)dV(82)} + HESS(522) = -D2A(4) +! HESS(523) = d^2 Vdot(82)/{dV(83)dV(87)} = d^2 Vdot(82)/{dV(87)dV(83)} + HESS(523) = D2A(28) +! HESS(524) = d^2 Vdot(82)/{dV(84)dV(85)} = d^2 Vdot(82)/{dV(85)dV(84)} + HESS(524) = D2A(10) +! HESS(525) = d^2 Vdot(82)/{dV(84)dV(87)} = d^2 Vdot(82)/{dV(87)dV(84)} + HESS(525) = D2A(26) +! HESS(526) = d^2 Vdot(82)/{dV(85)dV(86)} = d^2 Vdot(82)/{dV(86)dV(85)} + HESS(526) = D2A(35) +! HESS(527) = d^2 Vdot(82)/{dV(85)dV(87)} = d^2 Vdot(82)/{dV(87)dV(85)} + HESS(527) = 2*D2A(27) +! HESS(528) = d^2 Vdot(82)/{dV(85)dV(88)} = d^2 Vdot(82)/{dV(88)dV(85)} + HESS(528) = D2A(70) +! HESS(529) = d^2 Vdot(82)/{dV(85)dV(89)} = d^2 Vdot(82)/{dV(89)dV(85)} + HESS(529) = D2A(1) +! HESS(530) = d^2 Vdot(82)/{dV(85)dV(90)} = d^2 Vdot(82)/{dV(90)dV(85)} + HESS(530) = D2A(13) +! HESS(531) = d^2 Vdot(82)/{dV(87)dV(87)} = d^2 Vdot(82)/{dV(87)dV(87)} + HESS(531) = 2*D2A(204) +! HESS(532) = d^2 Vdot(83)/{dV(16)dV(83)} = d^2 Vdot(83)/{dV(83)dV(16)} + HESS(532) = -D2A(38)-D2A(39) +! HESS(533) = d^2 Vdot(83)/{dV(17)dV(83)} = d^2 Vdot(83)/{dV(83)dV(17)} + HESS(533) = -D2A(9) +! HESS(534) = d^2 Vdot(83)/{dV(20)dV(83)} = d^2 Vdot(83)/{dV(83)dV(20)} + HESS(534) = -D2A(208) +! HESS(535) = d^2 Vdot(83)/{dV(22)dV(83)} = d^2 Vdot(83)/{dV(83)dV(22)} + HESS(535) = -D2A(42) +! HESS(536) = d^2 Vdot(83)/{dV(23)dV(83)} = d^2 Vdot(83)/{dV(83)dV(23)} + HESS(536) = -D2A(36) +! HESS(537) = d^2 Vdot(83)/{dV(24)dV(83)} = d^2 Vdot(83)/{dV(83)dV(24)} + HESS(537) = -D2A(23) +! HESS(538) = d^2 Vdot(83)/{dV(26)dV(83)} = d^2 Vdot(83)/{dV(83)dV(26)} + HESS(538) = -D2A(161) +! HESS(539) = d^2 Vdot(83)/{dV(27)dV(83)} = d^2 Vdot(83)/{dV(83)dV(27)} + HESS(539) = -0.5*D2A(162) +! HESS(540) = d^2 Vdot(83)/{dV(28)dV(83)} = d^2 Vdot(83)/{dV(83)dV(28)} + HESS(540) = -D2A(17) +! HESS(541) = d^2 Vdot(83)/{dV(29)dV(83)} = d^2 Vdot(83)/{dV(83)dV(29)} + HESS(541) = -D2A(25) +! HESS(542) = d^2 Vdot(83)/{dV(30)dV(83)} = d^2 Vdot(83)/{dV(83)dV(30)} + HESS(542) = -0.5*D2A(152) +! HESS(543) = d^2 Vdot(83)/{dV(31)dV(83)} = d^2 Vdot(83)/{dV(83)dV(31)} + HESS(543) = -0.5*D2A(150) +! HESS(544) = d^2 Vdot(83)/{dV(32)dV(83)} = d^2 Vdot(83)/{dV(83)dV(32)} + HESS(544) = -0.5*D2A(151) +! HESS(545) = d^2 Vdot(83)/{dV(33)dV(83)} = d^2 Vdot(83)/{dV(83)dV(33)} + HESS(545) = -0.5*D2A(153) +! HESS(546) = d^2 Vdot(83)/{dV(34)dV(83)} = d^2 Vdot(83)/{dV(83)dV(34)} + HESS(546) = -D2A(205)-D2A(206) +! HESS(547) = d^2 Vdot(83)/{dV(35)dV(83)} = d^2 Vdot(83)/{dV(83)dV(35)} + HESS(547) = -0.5*D2A(149) +! HESS(548) = d^2 Vdot(83)/{dV(36)dV(83)} = d^2 Vdot(83)/{dV(83)dV(36)} + HESS(548) = -D2A(155) +! HESS(549) = d^2 Vdot(83)/{dV(37)dV(83)} = d^2 Vdot(83)/{dV(83)dV(37)} + HESS(549) = -D2A(154) +! HESS(550) = d^2 Vdot(83)/{dV(38)dV(83)} = d^2 Vdot(83)/{dV(83)dV(38)} + HESS(550) = -D2A(148) +! HESS(551) = d^2 Vdot(83)/{dV(39)dV(83)} = d^2 Vdot(83)/{dV(83)dV(39)} + HESS(551) = -D2A(147) +! HESS(552) = d^2 Vdot(83)/{dV(40)dV(83)} = d^2 Vdot(83)/{dV(83)dV(40)} + HESS(552) = -D2A(160) +! HESS(553) = d^2 Vdot(83)/{dV(41)dV(83)} = d^2 Vdot(83)/{dV(83)dV(41)} + HESS(553) = -D2A(157) +! HESS(554) = d^2 Vdot(83)/{dV(42)dV(83)} = d^2 Vdot(83)/{dV(83)dV(42)} + HESS(554) = -0.5*D2A(159) +! HESS(555) = d^2 Vdot(83)/{dV(43)dV(83)} = d^2 Vdot(83)/{dV(83)dV(43)} + HESS(555) = -0.5*D2A(158) +! HESS(556) = d^2 Vdot(83)/{dV(44)dV(83)} = d^2 Vdot(83)/{dV(83)dV(44)} + HESS(556) = -D2A(121) +! HESS(557) = d^2 Vdot(83)/{dV(45)dV(83)} = d^2 Vdot(83)/{dV(83)dV(45)} + HESS(557) = -0.491*D2A(156) +! HESS(558) = d^2 Vdot(83)/{dV(46)dV(83)} = d^2 Vdot(83)/{dV(83)dV(46)} + HESS(558) = -D2A(127) +! HESS(559) = d^2 Vdot(83)/{dV(46)dV(89)} = d^2 Vdot(83)/{dV(89)dV(46)} + HESS(559) = 0.27*D2A(135) +! HESS(560) = d^2 Vdot(83)/{dV(47)dV(83)} = d^2 Vdot(83)/{dV(83)dV(47)} + HESS(560) = -D2A(12) +! HESS(561) = d^2 Vdot(83)/{dV(48)dV(83)} = d^2 Vdot(83)/{dV(83)dV(48)} + HESS(561) = -D2A(119) +! HESS(562) = d^2 Vdot(83)/{dV(48)dV(89)} = d^2 Vdot(83)/{dV(89)dV(48)} + HESS(562) = 0.135*D2A(120) +! HESS(563) = d^2 Vdot(83)/{dV(49)dV(83)} = d^2 Vdot(83)/{dV(83)dV(49)} + HESS(563) = -D2A(73)-D2A(74) +! HESS(564) = d^2 Vdot(83)/{dV(50)dV(83)} = d^2 Vdot(83)/{dV(83)dV(50)} + HESS(564) = -D2A(123) +! HESS(565) = d^2 Vdot(83)/{dV(56)dV(83)} = d^2 Vdot(83)/{dV(83)dV(56)} + HESS(565) = -D2A(21) +! HESS(566) = d^2 Vdot(83)/{dV(58)dV(83)} = d^2 Vdot(83)/{dV(83)dV(58)} + HESS(566) = -D2A(164) +! HESS(567) = d^2 Vdot(83)/{dV(58)dV(89)} = d^2 Vdot(83)/{dV(89)dV(58)} + HESS(567) = 0.1*D2A(165) +! HESS(568) = d^2 Vdot(83)/{dV(61)dV(83)} = d^2 Vdot(83)/{dV(83)dV(61)} + HESS(568) = -D2A(130) +! HESS(569) = d^2 Vdot(83)/{dV(68)dV(83)} = d^2 Vdot(83)/{dV(83)dV(68)} + HESS(569) = -D2A(65) +! HESS(570) = d^2 Vdot(83)/{dV(69)dV(83)} = d^2 Vdot(83)/{dV(83)dV(69)} + HESS(570) = -D2A(19) +! HESS(571) = d^2 Vdot(83)/{dV(71)dV(83)} = d^2 Vdot(83)/{dV(83)dV(71)} + HESS(571) = -D2A(32) +! HESS(572) = d^2 Vdot(83)/{dV(73)dV(83)} = d^2 Vdot(83)/{dV(83)dV(73)} + HESS(572) = -D2A(64) +! HESS(573) = d^2 Vdot(83)/{dV(75)dV(83)} = d^2 Vdot(83)/{dV(83)dV(75)} + HESS(573) = -D2A(125) +! HESS(574) = d^2 Vdot(83)/{dV(76)dV(83)} = d^2 Vdot(83)/{dV(83)dV(76)} + HESS(574) = -D2A(92) +! HESS(575) = d^2 Vdot(83)/{dV(77)dV(83)} = d^2 Vdot(83)/{dV(83)dV(77)} + HESS(575) = -D2A(128) +! HESS(576) = d^2 Vdot(83)/{dV(77)dV(89)} = d^2 Vdot(83)/{dV(89)dV(77)} + HESS(576) = 0.08*D2A(136) +! HESS(577) = d^2 Vdot(83)/{dV(80)dV(83)} = d^2 Vdot(83)/{dV(83)dV(80)} + HESS(577) = -D2A(129) +! HESS(578) = d^2 Vdot(83)/{dV(80)dV(89)} = d^2 Vdot(83)/{dV(89)dV(80)} + HESS(578) = 0.215*D2A(137) +! HESS(579) = d^2 Vdot(83)/{dV(82)dV(83)} = d^2 Vdot(83)/{dV(83)dV(82)} + HESS(579) = -D2A(20) +! HESS(580) = d^2 Vdot(83)/{dV(83)dV(83)} = d^2 Vdot(83)/{dV(83)dV(83)} + HESS(580) = -2*D2A(6)-2*D2A(7) +! HESS(581) = d^2 Vdot(83)/{dV(83)dV(84)} = d^2 Vdot(83)/{dV(84)dV(83)} + HESS(581) = -D2A(8) +! HESS(582) = d^2 Vdot(83)/{dV(83)dV(85)} = d^2 Vdot(83)/{dV(85)dV(83)} + HESS(582) = -D2A(22) +! HESS(583) = d^2 Vdot(83)/{dV(83)dV(87)} = d^2 Vdot(83)/{dV(87)dV(83)} + HESS(583) = -D2A(28) +! HESS(584) = d^2 Vdot(83)/{dV(83)dV(89)} = d^2 Vdot(83)/{dV(89)dV(83)} + HESS(584) = -D2A(2) +! HESS(585) = d^2 Vdot(83)/{dV(84)dV(85)} = d^2 Vdot(83)/{dV(85)dV(84)} + HESS(585) = D2A(10) +! HESS(586) = d^2 Vdot(83)/{dV(84)dV(86)} = d^2 Vdot(83)/{dV(86)dV(84)} + HESS(586) = 0.44*D2A(115) +! HESS(587) = d^2 Vdot(83)/{dV(84)dV(87)} = d^2 Vdot(83)/{dV(87)dV(84)} + HESS(587) = D2A(26) +! HESS(588) = d^2 Vdot(83)/{dV(84)dV(89)} = d^2 Vdot(83)/{dV(89)dV(84)} + HESS(588) = D2A(3) +! HESS(589) = d^2 Vdot(84)/{dV(17)dV(83)} = d^2 Vdot(84)/{dV(83)dV(17)} + HESS(589) = D2A(9) +! HESS(590) = d^2 Vdot(84)/{dV(20)dV(83)} = d^2 Vdot(84)/{dV(83)dV(20)} + HESS(590) = D2A(208) +! HESS(591) = d^2 Vdot(84)/{dV(44)dV(83)} = d^2 Vdot(84)/{dV(83)dV(44)} + HESS(591) = 2*D2A(121) +! HESS(592) = d^2 Vdot(84)/{dV(44)dV(89)} = d^2 Vdot(84)/{dV(89)dV(44)} + HESS(592) = D2A(122) +! HESS(593) = d^2 Vdot(84)/{dV(46)dV(89)} = d^2 Vdot(84)/{dV(89)dV(46)} + HESS(593) = 0.06*D2A(135) +! HESS(594) = d^2 Vdot(84)/{dV(47)dV(83)} = d^2 Vdot(84)/{dV(83)dV(47)} + HESS(594) = D2A(12) +! HESS(595) = d^2 Vdot(84)/{dV(48)dV(89)} = d^2 Vdot(84)/{dV(89)dV(48)} + HESS(595) = 0.3*D2A(120) +! HESS(596) = d^2 Vdot(84)/{dV(50)dV(83)} = d^2 Vdot(84)/{dV(83)dV(50)} + HESS(596) = 0.2*D2A(123) +! HESS(597) = d^2 Vdot(84)/{dV(51)dV(84)} = d^2 Vdot(84)/{dV(84)dV(51)} + HESS(597) = -D2A(87) +! HESS(598) = d^2 Vdot(84)/{dV(51)dV(85)} = d^2 Vdot(84)/{dV(85)dV(51)} + HESS(598) = 0.3*D2A(58) +! HESS(599) = d^2 Vdot(84)/{dV(51)dV(86)} = d^2 Vdot(84)/{dV(86)dV(51)} + HESS(599) = 0.5*D2A(180) +! HESS(600) = d^2 Vdot(84)/{dV(51)dV(90)} = d^2 Vdot(84)/{dV(90)dV(51)} + HESS(600) = 0.75*D2A(105) +! HESS(601) = d^2 Vdot(84)/{dV(52)dV(84)} = d^2 Vdot(84)/{dV(84)dV(52)} + HESS(601) = -D2A(113) +! HESS(602) = d^2 Vdot(84)/{dV(52)dV(85)} = d^2 Vdot(84)/{dV(85)dV(52)} + HESS(602) = D2A(40) +! HESS(603) = d^2 Vdot(84)/{dV(52)dV(86)} = d^2 Vdot(84)/{dV(86)dV(52)} + HESS(603) = D2A(131) +! HESS(604) = d^2 Vdot(84)/{dV(52)dV(90)} = d^2 Vdot(84)/{dV(90)dV(52)} + HESS(604) = D2A(75) +! HESS(605) = d^2 Vdot(84)/{dV(53)dV(84)} = d^2 Vdot(84)/{dV(84)dV(53)} + HESS(605) = -D2A(89) +! HESS(606) = d^2 Vdot(84)/{dV(53)dV(85)} = d^2 Vdot(84)/{dV(85)dV(53)} + HESS(606) = D2A(60) +! HESS(607) = d^2 Vdot(84)/{dV(53)dV(86)} = d^2 Vdot(84)/{dV(86)dV(53)} + HESS(607) = D2A(178) +! HESS(608) = d^2 Vdot(84)/{dV(53)dV(90)} = d^2 Vdot(84)/{dV(90)dV(53)} + HESS(608) = D2A(107) +! HESS(609) = d^2 Vdot(84)/{dV(54)dV(84)} = d^2 Vdot(84)/{dV(84)dV(54)} + HESS(609) = -D2A(78) +! HESS(610) = d^2 Vdot(84)/{dV(54)dV(90)} = d^2 Vdot(84)/{dV(90)dV(54)} + HESS(610) = 0.5*D2A(96) +! HESS(611) = d^2 Vdot(84)/{dV(55)dV(84)} = d^2 Vdot(84)/{dV(84)dV(55)} + HESS(611) = -D2A(88) +! HESS(612) = d^2 Vdot(84)/{dV(55)dV(90)} = d^2 Vdot(84)/{dV(90)dV(55)} + HESS(612) = 0.5*D2A(106) +! HESS(613) = d^2 Vdot(84)/{dV(57)dV(84)} = d^2 Vdot(84)/{dV(84)dV(57)} + HESS(613) = -D2A(82) +! HESS(614) = d^2 Vdot(84)/{dV(57)dV(85)} = d^2 Vdot(84)/{dV(85)dV(57)} + HESS(614) = D2A(50) +! HESS(615) = d^2 Vdot(84)/{dV(57)dV(86)} = d^2 Vdot(84)/{dV(86)dV(57)} + HESS(615) = D2A(173) +! HESS(616) = d^2 Vdot(84)/{dV(57)dV(90)} = d^2 Vdot(84)/{dV(90)dV(57)} + HESS(616) = D2A(100) +! HESS(617) = d^2 Vdot(84)/{dV(58)dV(83)} = d^2 Vdot(84)/{dV(83)dV(58)} + HESS(617) = 0.15*D2A(164) +! HESS(618) = d^2 Vdot(84)/{dV(59)dV(84)} = d^2 Vdot(84)/{dV(84)dV(59)} + HESS(618) = -D2A(86) +! HESS(619) = d^2 Vdot(84)/{dV(59)dV(85)} = d^2 Vdot(84)/{dV(85)dV(59)} + HESS(619) = D2A(56) +! HESS(620) = d^2 Vdot(84)/{dV(59)dV(86)} = d^2 Vdot(84)/{dV(86)dV(59)} + HESS(620) = D2A(177) +! HESS(621) = d^2 Vdot(84)/{dV(59)dV(90)} = d^2 Vdot(84)/{dV(90)dV(59)} + HESS(621) = 1.15*D2A(104) +! HESS(622) = d^2 Vdot(84)/{dV(60)dV(84)} = d^2 Vdot(84)/{dV(84)dV(60)} + HESS(622) = -D2A(80) +! HESS(623) = d^2 Vdot(84)/{dV(60)dV(90)} = d^2 Vdot(84)/{dV(90)dV(60)} + HESS(623) = 0.5*D2A(98) +! HESS(624) = d^2 Vdot(84)/{dV(61)dV(83)} = d^2 Vdot(84)/{dV(83)dV(61)} + HESS(624) = D2A(130) +! HESS(625) = d^2 Vdot(84)/{dV(62)dV(84)} = d^2 Vdot(84)/{dV(84)dV(62)} + HESS(625) = -D2A(79) +! HESS(626) = d^2 Vdot(84)/{dV(62)dV(86)} = d^2 Vdot(84)/{dV(86)dV(62)} + HESS(626) = 0.8*D2A(170) +! HESS(627) = d^2 Vdot(84)/{dV(62)dV(90)} = d^2 Vdot(84)/{dV(90)dV(62)} + HESS(627) = 0.3*D2A(97) +! HESS(628) = d^2 Vdot(84)/{dV(63)dV(84)} = d^2 Vdot(84)/{dV(84)dV(63)} + HESS(628) = -D2A(91) +! HESS(629) = d^2 Vdot(84)/{dV(63)dV(90)} = d^2 Vdot(84)/{dV(90)dV(63)} + HESS(629) = 0.5*D2A(109) +! HESS(630) = d^2 Vdot(84)/{dV(64)dV(84)} = d^2 Vdot(84)/{dV(84)dV(64)} + HESS(630) = -D2A(85) +! HESS(631) = d^2 Vdot(84)/{dV(64)dV(85)} = d^2 Vdot(84)/{dV(85)dV(64)} + HESS(631) = 0.28*D2A(54) +! HESS(632) = d^2 Vdot(84)/{dV(64)dV(86)} = d^2 Vdot(84)/{dV(86)dV(64)} + HESS(632) = 0.28*D2A(176) +! HESS(633) = d^2 Vdot(84)/{dV(64)dV(90)} = d^2 Vdot(84)/{dV(90)dV(64)} + HESS(633) = 0.64*D2A(103) +! HESS(634) = d^2 Vdot(84)/{dV(65)dV(84)} = d^2 Vdot(84)/{dV(84)dV(65)} + HESS(634) = -D2A(84) +! HESS(635) = d^2 Vdot(84)/{dV(65)dV(85)} = d^2 Vdot(84)/{dV(85)dV(65)} + HESS(635) = 0.05*D2A(53) +! HESS(636) = d^2 Vdot(84)/{dV(65)dV(90)} = d^2 Vdot(84)/{dV(90)dV(65)} + HESS(636) = 0.5*D2A(102) +! HESS(637) = d^2 Vdot(84)/{dV(66)dV(84)} = d^2 Vdot(84)/{dV(84)dV(66)} + HESS(637) = -D2A(83) +! HESS(638) = d^2 Vdot(84)/{dV(66)dV(85)} = d^2 Vdot(84)/{dV(85)dV(66)} + HESS(638) = 0.92*D2A(52) +! HESS(639) = d^2 Vdot(84)/{dV(66)dV(86)} = d^2 Vdot(84)/{dV(86)dV(66)} + HESS(639) = D2A(174) +! HESS(640) = d^2 Vdot(84)/{dV(66)dV(90)} = d^2 Vdot(84)/{dV(90)dV(66)} + HESS(640) = D2A(101) +! HESS(641) = d^2 Vdot(84)/{dV(67)dV(84)} = d^2 Vdot(84)/{dV(84)dV(67)} + HESS(641) = -D2A(90) +! HESS(642) = d^2 Vdot(84)/{dV(67)dV(85)} = d^2 Vdot(84)/{dV(85)dV(67)} + HESS(642) = 0.8*D2A(61) +! HESS(643) = d^2 Vdot(84)/{dV(67)dV(86)} = d^2 Vdot(84)/{dV(86)dV(67)} + HESS(643) = 0.8*D2A(182) +! HESS(644) = d^2 Vdot(84)/{dV(67)dV(90)} = d^2 Vdot(84)/{dV(90)dV(67)} + HESS(644) = 0.45*D2A(108) +! HESS(645) = d^2 Vdot(84)/{dV(69)dV(83)} = d^2 Vdot(84)/{dV(83)dV(69)} + HESS(645) = D2A(19) +! HESS(646) = d^2 Vdot(84)/{dV(69)dV(87)} = d^2 Vdot(84)/{dV(87)dV(69)} + HESS(646) = D2A(31) +! HESS(647) = d^2 Vdot(84)/{dV(70)dV(84)} = d^2 Vdot(84)/{dV(84)dV(70)} + HESS(647) = -D2A(114) +! HESS(648) = d^2 Vdot(84)/{dV(70)dV(85)} = d^2 Vdot(84)/{dV(85)dV(70)} + HESS(648) = D2A(41) +! HESS(649) = d^2 Vdot(84)/{dV(70)dV(86)} = d^2 Vdot(84)/{dV(86)dV(70)} + HESS(649) = D2A(132) +! HESS(650) = d^2 Vdot(84)/{dV(70)dV(90)} = d^2 Vdot(84)/{dV(90)dV(70)} + HESS(650) = D2A(76) +! HESS(651) = d^2 Vdot(84)/{dV(71)dV(83)} = d^2 Vdot(84)/{dV(83)dV(71)} + HESS(651) = 0.05*D2A(32) +! HESS(652) = d^2 Vdot(84)/{dV(72)dV(84)} = d^2 Vdot(84)/{dV(84)dV(72)} + HESS(652) = -D2A(77) +! HESS(653) = d^2 Vdot(84)/{dV(72)dV(85)} = d^2 Vdot(84)/{dV(85)dV(72)} + HESS(653) = 0.27*D2A(43) +! HESS(654) = d^2 Vdot(84)/{dV(72)dV(86)} = d^2 Vdot(84)/{dV(86)dV(72)} + HESS(654) = 0.27*D2A(169) +! HESS(655) = d^2 Vdot(84)/{dV(72)dV(90)} = d^2 Vdot(84)/{dV(90)dV(72)} + HESS(655) = 0.64*D2A(95) +! HESS(656) = d^2 Vdot(84)/{dV(74)dV(74)} = d^2 Vdot(84)/{dV(74)dV(74)} + HESS(656) = 2*D2A(110) +! HESS(657) = d^2 Vdot(84)/{dV(74)dV(84)} = d^2 Vdot(84)/{dV(84)dV(74)} + HESS(657) = -D2A(112) +! HESS(658) = d^2 Vdot(84)/{dV(74)dV(85)} = d^2 Vdot(84)/{dV(85)dV(74)} + HESS(658) = D2A(37) +! HESS(659) = d^2 Vdot(84)/{dV(74)dV(86)} = d^2 Vdot(84)/{dV(86)dV(74)} + HESS(659) = D2A(199) +! HESS(660) = d^2 Vdot(84)/{dV(74)dV(90)} = d^2 Vdot(84)/{dV(90)dV(74)} + HESS(660) = D2A(93) +! HESS(661) = d^2 Vdot(84)/{dV(77)dV(89)} = d^2 Vdot(84)/{dV(89)dV(77)} + HESS(661) = 0.06*D2A(136) +! HESS(662) = d^2 Vdot(84)/{dV(78)dV(84)} = d^2 Vdot(84)/{dV(84)dV(78)} + HESS(662) = -D2A(118) +! HESS(663) = d^2 Vdot(84)/{dV(78)dV(90)} = d^2 Vdot(84)/{dV(90)dV(78)} + HESS(663) = D2A(143) +! HESS(664) = d^2 Vdot(84)/{dV(79)dV(84)} = d^2 Vdot(84)/{dV(84)dV(79)} + HESS(664) = -D2A(81) +! HESS(665) = d^2 Vdot(84)/{dV(79)dV(85)} = d^2 Vdot(84)/{dV(85)dV(79)} + HESS(665) = 0.9*D2A(48) +! HESS(666) = d^2 Vdot(84)/{dV(79)dV(86)} = d^2 Vdot(84)/{dV(86)dV(79)} + HESS(666) = 0.864*D2A(172) +! HESS(667) = d^2 Vdot(84)/{dV(79)dV(90)} = d^2 Vdot(84)/{dV(90)dV(79)} + HESS(667) = 0.92*D2A(99) +! HESS(668) = d^2 Vdot(84)/{dV(80)dV(89)} = d^2 Vdot(84)/{dV(89)dV(80)} + HESS(668) = 0.275*D2A(137) +! HESS(669) = d^2 Vdot(84)/{dV(81)dV(84)} = d^2 Vdot(84)/{dV(84)dV(81)} + HESS(669) = -D2A(116) +! HESS(670) = d^2 Vdot(84)/{dV(81)dV(90)} = d^2 Vdot(84)/{dV(90)dV(81)} + HESS(670) = D2A(141) +! HESS(671) = d^2 Vdot(84)/{dV(82)dV(84)} = d^2 Vdot(84)/{dV(84)dV(82)} + HESS(671) = -D2A(24) +! HESS(672) = d^2 Vdot(84)/{dV(83)dV(84)} = d^2 Vdot(84)/{dV(84)dV(83)} + HESS(672) = -D2A(8) +! HESS(673) = d^2 Vdot(84)/{dV(83)dV(87)} = d^2 Vdot(84)/{dV(87)dV(83)} + HESS(673) = D2A(28) +! HESS(674) = d^2 Vdot(84)/{dV(83)dV(89)} = d^2 Vdot(84)/{dV(89)dV(83)} + HESS(674) = D2A(2) +! HESS(675) = d^2 Vdot(84)/{dV(84)dV(84)} = d^2 Vdot(84)/{dV(84)dV(84)} + HESS(675) = -2*D2A(11) +! HESS(676) = d^2 Vdot(84)/{dV(84)dV(85)} = d^2 Vdot(84)/{dV(85)dV(84)} + HESS(676) = -D2A(10) +! HESS(677) = d^2 Vdot(84)/{dV(84)dV(86)} = d^2 Vdot(84)/{dV(86)dV(84)} + HESS(677) = -D2A(115) +! HESS(678) = d^2 Vdot(84)/{dV(84)dV(87)} = d^2 Vdot(84)/{dV(87)dV(84)} + HESS(678) = -D2A(26) +! HESS(679) = d^2 Vdot(84)/{dV(84)dV(88)} = d^2 Vdot(84)/{dV(88)dV(84)} + HESS(679) = -D2A(117) +! HESS(680) = d^2 Vdot(84)/{dV(84)dV(89)} = d^2 Vdot(84)/{dV(89)dV(84)} + HESS(680) = -D2A(3) +! HESS(681) = d^2 Vdot(84)/{dV(84)dV(90)} = d^2 Vdot(84)/{dV(90)dV(84)} + HESS(681) = -D2A(14) +! HESS(682) = d^2 Vdot(84)/{dV(85)dV(88)} = d^2 Vdot(84)/{dV(88)dV(85)} + HESS(682) = D2A(70) +! HESS(683) = d^2 Vdot(84)/{dV(85)dV(90)} = d^2 Vdot(84)/{dV(90)dV(85)} + HESS(683) = D2A(13) +! HESS(684) = d^2 Vdot(84)/{dV(86)dV(88)} = d^2 Vdot(84)/{dV(88)dV(86)} + HESS(684) = D2A(202) +! HESS(685) = d^2 Vdot(84)/{dV(86)dV(90)} = d^2 Vdot(84)/{dV(90)dV(86)} + HESS(685) = D2A(167) +! HESS(686) = d^2 Vdot(84)/{dV(88)dV(90)} = d^2 Vdot(84)/{dV(90)dV(88)} + HESS(686) = 2*D2A(142) +! HESS(687) = d^2 Vdot(84)/{dV(89)dV(90)} = d^2 Vdot(84)/{dV(90)dV(89)} + HESS(687) = D2A(5) +! HESS(688) = d^2 Vdot(84)/{dV(90)dV(90)} = d^2 Vdot(84)/{dV(90)dV(90)} + HESS(688) = 2*D2A(16) +! HESS(689) = d^2 Vdot(85)/{dV(51)dV(85)} = d^2 Vdot(85)/{dV(85)dV(51)} + HESS(689) = -D2A(58) +! HESS(690) = d^2 Vdot(85)/{dV(52)dV(85)} = d^2 Vdot(85)/{dV(85)dV(52)} + HESS(690) = -D2A(40) +! HESS(691) = d^2 Vdot(85)/{dV(53)dV(85)} = d^2 Vdot(85)/{dV(85)dV(53)} + HESS(691) = -D2A(60) +! HESS(692) = d^2 Vdot(85)/{dV(54)dV(85)} = d^2 Vdot(85)/{dV(85)dV(54)} + HESS(692) = -D2A(45) +! HESS(693) = d^2 Vdot(85)/{dV(55)dV(85)} = d^2 Vdot(85)/{dV(85)dV(55)} + HESS(693) = -D2A(59) +! HESS(694) = d^2 Vdot(85)/{dV(57)dV(85)} = d^2 Vdot(85)/{dV(85)dV(57)} + HESS(694) = -D2A(50)-D2A(51) +! HESS(695) = d^2 Vdot(85)/{dV(59)dV(85)} = d^2 Vdot(85)/{dV(85)dV(59)} + HESS(695) = -D2A(56)-D2A(57) +! HESS(696) = d^2 Vdot(85)/{dV(60)dV(85)} = d^2 Vdot(85)/{dV(85)dV(60)} + HESS(696) = -D2A(47) +! HESS(697) = d^2 Vdot(85)/{dV(62)dV(85)} = d^2 Vdot(85)/{dV(85)dV(62)} + HESS(697) = -D2A(46) +! HESS(698) = d^2 Vdot(85)/{dV(63)dV(85)} = d^2 Vdot(85)/{dV(85)dV(63)} + HESS(698) = -D2A(62) +! HESS(699) = d^2 Vdot(85)/{dV(64)dV(85)} = d^2 Vdot(85)/{dV(85)dV(64)} + HESS(699) = -D2A(54)-D2A(55) +! HESS(700) = d^2 Vdot(85)/{dV(65)dV(85)} = d^2 Vdot(85)/{dV(85)dV(65)} + HESS(700) = -D2A(53) +! HESS(701) = d^2 Vdot(85)/{dV(66)dV(85)} = d^2 Vdot(85)/{dV(85)dV(66)} + HESS(701) = -D2A(52) +! HESS(702) = d^2 Vdot(85)/{dV(67)dV(85)} = d^2 Vdot(85)/{dV(85)dV(67)} + HESS(702) = -D2A(61) +! HESS(703) = d^2 Vdot(85)/{dV(70)dV(85)} = d^2 Vdot(85)/{dV(85)dV(70)} + HESS(703) = -D2A(41) +! HESS(704) = d^2 Vdot(85)/{dV(72)dV(85)} = d^2 Vdot(85)/{dV(85)dV(72)} + HESS(704) = -D2A(43)-D2A(44) +! HESS(705) = d^2 Vdot(85)/{dV(74)dV(85)} = d^2 Vdot(85)/{dV(85)dV(74)} + HESS(705) = -D2A(37) +! HESS(706) = d^2 Vdot(85)/{dV(78)dV(85)} = d^2 Vdot(85)/{dV(85)dV(78)} + HESS(706) = -D2A(71) +! HESS(707) = d^2 Vdot(85)/{dV(79)dV(85)} = d^2 Vdot(85)/{dV(85)dV(79)} + HESS(707) = -D2A(48)-D2A(49) +! HESS(708) = d^2 Vdot(85)/{dV(81)dV(85)} = d^2 Vdot(85)/{dV(85)dV(81)} + HESS(708) = -D2A(69) +! HESS(709) = d^2 Vdot(85)/{dV(82)dV(87)} = d^2 Vdot(85)/{dV(87)dV(82)} + HESS(709) = D2A(30) +! HESS(710) = d^2 Vdot(85)/{dV(83)dV(85)} = d^2 Vdot(85)/{dV(85)dV(83)} + HESS(710) = -D2A(22) +! HESS(711) = d^2 Vdot(85)/{dV(84)dV(85)} = d^2 Vdot(85)/{dV(85)dV(84)} + HESS(711) = -D2A(10) +! HESS(712) = d^2 Vdot(85)/{dV(85)dV(86)} = d^2 Vdot(85)/{dV(86)dV(85)} + HESS(712) = -D2A(35) +! HESS(713) = d^2 Vdot(85)/{dV(85)dV(87)} = d^2 Vdot(85)/{dV(87)dV(85)} + HESS(713) = -D2A(27) +! HESS(714) = d^2 Vdot(85)/{dV(85)dV(88)} = d^2 Vdot(85)/{dV(88)dV(85)} + HESS(714) = -D2A(70) +! HESS(715) = d^2 Vdot(85)/{dV(85)dV(89)} = d^2 Vdot(85)/{dV(89)dV(85)} + HESS(715) = -D2A(1) +! HESS(716) = d^2 Vdot(85)/{dV(85)dV(90)} = d^2 Vdot(85)/{dV(90)dV(85)} + HESS(716) = -D2A(13) +! HESS(717) = d^2 Vdot(86)/{dV(27)dV(83)} = d^2 Vdot(86)/{dV(83)dV(27)} + HESS(717) = 0.5*D2A(162) +! HESS(718) = d^2 Vdot(86)/{dV(51)dV(85)} = d^2 Vdot(86)/{dV(85)dV(51)} + HESS(718) = 0.6*D2A(58) +! HESS(719) = d^2 Vdot(86)/{dV(51)dV(86)} = d^2 Vdot(86)/{dV(86)dV(51)} + HESS(719) = -0.5*D2A(180)-D2A(194) +! HESS(720) = d^2 Vdot(86)/{dV(51)dV(90)} = d^2 Vdot(86)/{dV(90)dV(51)} + HESS(720) = 0.25*D2A(105) +! HESS(721) = d^2 Vdot(86)/{dV(52)dV(86)} = d^2 Vdot(86)/{dV(86)dV(52)} + HESS(721) = -D2A(131)-D2A(133) +! HESS(722) = d^2 Vdot(86)/{dV(53)dV(86)} = d^2 Vdot(86)/{dV(86)dV(53)} + HESS(722) = -D2A(178)-D2A(198) +! HESS(723) = d^2 Vdot(86)/{dV(54)dV(86)} = d^2 Vdot(86)/{dV(86)dV(54)} + HESS(723) = -D2A(179)-D2A(192) +! HESS(724) = d^2 Vdot(86)/{dV(55)dV(86)} = d^2 Vdot(86)/{dV(86)dV(55)} + HESS(724) = -D2A(181)-D2A(195) +! HESS(725) = d^2 Vdot(86)/{dV(57)dV(86)} = d^2 Vdot(86)/{dV(86)dV(57)} + HESS(725) = -D2A(173)-D2A(188) +! HESS(726) = d^2 Vdot(86)/{dV(59)dV(86)} = d^2 Vdot(86)/{dV(86)dV(59)} + HESS(726) = -D2A(177)-D2A(191) +! HESS(727) = d^2 Vdot(86)/{dV(60)dV(85)} = d^2 Vdot(86)/{dV(85)dV(60)} + HESS(727) = 0.93*D2A(47) +! HESS(728) = d^2 Vdot(86)/{dV(60)dV(86)} = d^2 Vdot(86)/{dV(86)dV(60)} + HESS(728) = -D2A(186) +! HESS(729) = d^2 Vdot(86)/{dV(60)dV(90)} = d^2 Vdot(86)/{dV(90)dV(60)} + HESS(729) = 0.5*D2A(98) +! HESS(730) = d^2 Vdot(86)/{dV(62)dV(84)} = d^2 Vdot(86)/{dV(84)dV(62)} + HESS(730) = D2A(79) +! HESS(731) = d^2 Vdot(86)/{dV(62)dV(85)} = d^2 Vdot(86)/{dV(85)dV(62)} + HESS(731) = 0.96*D2A(46) +! HESS(732) = d^2 Vdot(86)/{dV(62)dV(86)} = d^2 Vdot(86)/{dV(86)dV(62)} + HESS(732) = -0.8*D2A(170)-D2A(185) +! HESS(733) = d^2 Vdot(86)/{dV(62)dV(90)} = d^2 Vdot(86)/{dV(90)dV(62)} + HESS(733) = 0.3*D2A(97) +! HESS(734) = d^2 Vdot(86)/{dV(63)dV(86)} = d^2 Vdot(86)/{dV(86)dV(63)} + HESS(734) = -D2A(183)-D2A(197) +! HESS(735) = d^2 Vdot(86)/{dV(64)dV(85)} = d^2 Vdot(86)/{dV(85)dV(64)} + HESS(735) = 0.72*D2A(54) +! HESS(736) = d^2 Vdot(86)/{dV(64)dV(86)} = d^2 Vdot(86)/{dV(86)dV(64)} + HESS(736) = -0.28*D2A(176)-D2A(190) +! HESS(737) = d^2 Vdot(86)/{dV(64)dV(90)} = d^2 Vdot(86)/{dV(90)dV(64)} + HESS(737) = 0.36*D2A(103) +! HESS(738) = d^2 Vdot(86)/{dV(65)dV(86)} = d^2 Vdot(86)/{dV(86)dV(65)} + HESS(738) = -D2A(175)-D2A(193) +! HESS(739) = d^2 Vdot(86)/{dV(66)dV(86)} = d^2 Vdot(86)/{dV(86)dV(66)} + HESS(739) = -D2A(174)-D2A(189) +! HESS(740) = d^2 Vdot(86)/{dV(67)dV(86)} = d^2 Vdot(86)/{dV(86)dV(67)} + HESS(740) = -D2A(182)-D2A(196) +! HESS(741) = d^2 Vdot(86)/{dV(70)dV(86)} = d^2 Vdot(86)/{dV(86)dV(70)} + HESS(741) = -D2A(132)-D2A(134) +! HESS(742) = d^2 Vdot(86)/{dV(71)dV(83)} = d^2 Vdot(86)/{dV(83)dV(71)} + HESS(742) = 0.95*D2A(32) +! HESS(743) = d^2 Vdot(86)/{dV(71)dV(87)} = d^2 Vdot(86)/{dV(87)dV(71)} + HESS(743) = D2A(33) +! HESS(744) = d^2 Vdot(86)/{dV(72)dV(86)} = d^2 Vdot(86)/{dV(86)dV(72)} + HESS(744) = -D2A(169)-D2A(184) +! HESS(745) = d^2 Vdot(86)/{dV(74)dV(86)} = d^2 Vdot(86)/{dV(86)dV(74)} + HESS(745) = -D2A(199)-D2A(200) +! HESS(746) = d^2 Vdot(86)/{dV(75)dV(83)} = d^2 Vdot(86)/{dV(83)dV(75)} + HESS(746) = D2A(125) +! HESS(747) = d^2 Vdot(86)/{dV(75)dV(87)} = d^2 Vdot(86)/{dV(87)dV(75)} + HESS(747) = D2A(126) +! HESS(748) = d^2 Vdot(86)/{dV(78)dV(85)} = d^2 Vdot(86)/{dV(85)dV(78)} + HESS(748) = D2A(71) +! HESS(749) = d^2 Vdot(86)/{dV(78)dV(90)} = d^2 Vdot(86)/{dV(90)dV(78)} + HESS(749) = D2A(143) +! HESS(750) = d^2 Vdot(86)/{dV(79)dV(86)} = d^2 Vdot(86)/{dV(86)dV(79)} + HESS(750) = -D2A(172)-D2A(187) +! HESS(751) = d^2 Vdot(86)/{dV(81)dV(86)} = d^2 Vdot(86)/{dV(86)dV(81)} + HESS(751) = -D2A(201) +! HESS(752) = d^2 Vdot(86)/{dV(82)dV(86)} = d^2 Vdot(86)/{dV(86)dV(82)} + HESS(752) = -D2A(34) +! HESS(753) = d^2 Vdot(86)/{dV(84)dV(86)} = d^2 Vdot(86)/{dV(86)dV(84)} + HESS(753) = -D2A(115) +! HESS(754) = d^2 Vdot(86)/{dV(85)dV(86)} = d^2 Vdot(86)/{dV(86)dV(85)} + HESS(754) = -D2A(35) +! HESS(755) = d^2 Vdot(86)/{dV(86)dV(86)} = d^2 Vdot(86)/{dV(86)dV(86)} + HESS(755) = -2*D2A(166) +! HESS(756) = d^2 Vdot(86)/{dV(86)dV(88)} = d^2 Vdot(86)/{dV(88)dV(86)} + HESS(756) = -D2A(202) +! HESS(757) = d^2 Vdot(86)/{dV(86)dV(90)} = d^2 Vdot(86)/{dV(90)dV(86)} + HESS(757) = -D2A(167)-D2A(168) +! HESS(758) = d^2 Vdot(87)/{dV(22)dV(87)} = d^2 Vdot(87)/{dV(87)dV(22)} + HESS(758) = -D2A(63) +! HESS(759) = d^2 Vdot(87)/{dV(23)dV(87)} = d^2 Vdot(87)/{dV(87)dV(23)} + HESS(759) = -D2A(163) +! HESS(760) = d^2 Vdot(87)/{dV(34)dV(87)} = d^2 Vdot(87)/{dV(87)dV(34)} + HESS(760) = -D2A(207) +! HESS(761) = d^2 Vdot(87)/{dV(46)dV(87)} = d^2 Vdot(87)/{dV(87)dV(46)} + HESS(761) = -D2A(138) +! HESS(762) = d^2 Vdot(87)/{dV(48)dV(87)} = d^2 Vdot(87)/{dV(87)dV(48)} + HESS(762) = -D2A(124) +! HESS(763) = d^2 Vdot(87)/{dV(56)dV(83)} = d^2 Vdot(87)/{dV(83)dV(56)} + HESS(763) = D2A(21) +! HESS(764) = d^2 Vdot(87)/{dV(68)dV(87)} = d^2 Vdot(87)/{dV(87)dV(68)} + HESS(764) = -D2A(72) +! HESS(765) = d^2 Vdot(87)/{dV(69)dV(87)} = d^2 Vdot(87)/{dV(87)dV(69)} + HESS(765) = -D2A(31) +! HESS(766) = d^2 Vdot(87)/{dV(71)dV(87)} = d^2 Vdot(87)/{dV(87)dV(71)} + HESS(766) = -D2A(33) +! HESS(767) = d^2 Vdot(87)/{dV(75)dV(87)} = d^2 Vdot(87)/{dV(87)dV(75)} + HESS(767) = -D2A(126) +! HESS(768) = d^2 Vdot(87)/{dV(76)dV(87)} = d^2 Vdot(87)/{dV(87)dV(76)} + HESS(768) = -D2A(94) +! HESS(769) = d^2 Vdot(87)/{dV(80)dV(87)} = d^2 Vdot(87)/{dV(87)dV(80)} + HESS(769) = -D2A(139)-D2A(140) +! HESS(770) = d^2 Vdot(87)/{dV(82)dV(87)} = d^2 Vdot(87)/{dV(87)dV(82)} + HESS(770) = -D2A(29)-D2A(30) +! HESS(771) = d^2 Vdot(87)/{dV(82)dV(89)} = d^2 Vdot(87)/{dV(89)dV(82)} + HESS(771) = D2A(4) +! HESS(772) = d^2 Vdot(87)/{dV(83)dV(87)} = d^2 Vdot(87)/{dV(87)dV(83)} + HESS(772) = -D2A(28) +! HESS(773) = d^2 Vdot(87)/{dV(84)dV(87)} = d^2 Vdot(87)/{dV(87)dV(84)} + HESS(773) = -D2A(26) +! HESS(774) = d^2 Vdot(87)/{dV(85)dV(87)} = d^2 Vdot(87)/{dV(87)dV(85)} + HESS(774) = -D2A(27) +! HESS(775) = d^2 Vdot(87)/{dV(87)dV(87)} = d^2 Vdot(87)/{dV(87)dV(87)} + HESS(775) = -2*D2A(204) +! HESS(776) = d^2 Vdot(88)/{dV(36)dV(83)} = d^2 Vdot(88)/{dV(83)dV(36)} + HESS(776) = D2A(155) +! HESS(777) = d^2 Vdot(88)/{dV(50)dV(83)} = d^2 Vdot(88)/{dV(83)dV(50)} + HESS(777) = 0.8*D2A(123) +! HESS(778) = d^2 Vdot(88)/{dV(82)dV(88)} = d^2 Vdot(88)/{dV(88)dV(82)} + HESS(778) = -D2A(67) +! HESS(779) = d^2 Vdot(88)/{dV(84)dV(88)} = d^2 Vdot(88)/{dV(88)dV(84)} + HESS(779) = -D2A(117) +! HESS(780) = d^2 Vdot(88)/{dV(85)dV(88)} = d^2 Vdot(88)/{dV(88)dV(85)} + HESS(780) = -D2A(70) +! HESS(781) = d^2 Vdot(88)/{dV(86)dV(88)} = d^2 Vdot(88)/{dV(88)dV(86)} + HESS(781) = -D2A(202) +! HESS(782) = d^2 Vdot(88)/{dV(88)dV(90)} = d^2 Vdot(88)/{dV(90)dV(88)} + HESS(782) = -D2A(142)-D2A(145) +! HESS(783) = d^2 Vdot(89)/{dV(44)dV(89)} = d^2 Vdot(89)/{dV(89)dV(44)} + HESS(783) = -D2A(122) +! HESS(784) = d^2 Vdot(89)/{dV(46)dV(89)} = d^2 Vdot(89)/{dV(89)dV(46)} + HESS(784) = -0.9*D2A(135) +! HESS(785) = d^2 Vdot(89)/{dV(48)dV(89)} = d^2 Vdot(89)/{dV(89)dV(48)} + HESS(785) = -D2A(120) +! HESS(786) = d^2 Vdot(89)/{dV(58)dV(89)} = d^2 Vdot(89)/{dV(89)dV(58)} + HESS(786) = -0.7*D2A(165) +! HESS(787) = d^2 Vdot(89)/{dV(77)dV(89)} = d^2 Vdot(89)/{dV(89)dV(77)} + HESS(787) = -0.8*D2A(136) +! HESS(788) = d^2 Vdot(89)/{dV(78)dV(84)} = d^2 Vdot(89)/{dV(84)dV(78)} + HESS(788) = 0.3*D2A(118) +! HESS(789) = d^2 Vdot(89)/{dV(80)dV(89)} = d^2 Vdot(89)/{dV(89)dV(80)} + HESS(789) = -0.8*D2A(137) +! HESS(790) = d^2 Vdot(89)/{dV(81)dV(84)} = d^2 Vdot(89)/{dV(84)dV(81)} + HESS(790) = 0.3*D2A(116) +! HESS(791) = d^2 Vdot(89)/{dV(82)dV(89)} = d^2 Vdot(89)/{dV(89)dV(82)} + HESS(791) = -D2A(4) +! HESS(792) = d^2 Vdot(89)/{dV(83)dV(83)} = d^2 Vdot(89)/{dV(83)dV(83)} + HESS(792) = D2A(6) +! HESS(793) = d^2 Vdot(89)/{dV(83)dV(89)} = d^2 Vdot(89)/{dV(89)dV(83)} + HESS(793) = -D2A(2) +! HESS(794) = d^2 Vdot(89)/{dV(84)dV(86)} = d^2 Vdot(89)/{dV(86)dV(84)} + HESS(794) = 0.15*D2A(115) +! HESS(795) = d^2 Vdot(89)/{dV(84)dV(88)} = d^2 Vdot(89)/{dV(88)dV(84)} + HESS(795) = 0.29*D2A(117) +! HESS(796) = d^2 Vdot(89)/{dV(84)dV(89)} = d^2 Vdot(89)/{dV(89)dV(84)} + HESS(796) = -D2A(3) +! HESS(797) = d^2 Vdot(89)/{dV(85)dV(89)} = d^2 Vdot(89)/{dV(89)dV(85)} + HESS(797) = -D2A(1) +! HESS(798) = d^2 Vdot(89)/{dV(89)dV(90)} = d^2 Vdot(89)/{dV(90)dV(89)} + HESS(798) = -D2A(5) +! HESS(799) = d^2 Vdot(90)/{dV(28)dV(83)} = d^2 Vdot(90)/{dV(83)dV(28)} + HESS(799) = D2A(17) +! HESS(800) = d^2 Vdot(90)/{dV(34)dV(83)} = d^2 Vdot(90)/{dV(83)dV(34)} + HESS(800) = D2A(205)+D2A(206) +! HESS(801) = d^2 Vdot(90)/{dV(34)dV(87)} = d^2 Vdot(90)/{dV(87)dV(34)} + HESS(801) = D2A(207) +! HESS(802) = d^2 Vdot(90)/{dV(48)dV(89)} = d^2 Vdot(90)/{dV(89)dV(48)} + HESS(802) = 0.305*D2A(120) +! HESS(803) = d^2 Vdot(90)/{dV(51)dV(86)} = d^2 Vdot(90)/{dV(86)dV(51)} + HESS(803) = D2A(180) +! HESS(804) = d^2 Vdot(90)/{dV(51)dV(90)} = d^2 Vdot(90)/{dV(90)dV(51)} + HESS(804) = -D2A(105) +! HESS(805) = d^2 Vdot(90)/{dV(52)dV(86)} = d^2 Vdot(90)/{dV(86)dV(52)} + HESS(805) = D2A(131) +! HESS(806) = d^2 Vdot(90)/{dV(52)dV(90)} = d^2 Vdot(90)/{dV(90)dV(52)} + HESS(806) = -D2A(75) +! HESS(807) = d^2 Vdot(90)/{dV(53)dV(86)} = d^2 Vdot(90)/{dV(86)dV(53)} + HESS(807) = D2A(178) +! HESS(808) = d^2 Vdot(90)/{dV(53)dV(90)} = d^2 Vdot(90)/{dV(90)dV(53)} + HESS(808) = -D2A(107) +! HESS(809) = d^2 Vdot(90)/{dV(54)dV(86)} = d^2 Vdot(90)/{dV(86)dV(54)} + HESS(809) = D2A(179) +! HESS(810) = d^2 Vdot(90)/{dV(54)dV(90)} = d^2 Vdot(90)/{dV(90)dV(54)} + HESS(810) = -D2A(96) +! HESS(811) = d^2 Vdot(90)/{dV(55)dV(86)} = d^2 Vdot(90)/{dV(86)dV(55)} + HESS(811) = D2A(181) +! HESS(812) = d^2 Vdot(90)/{dV(55)dV(90)} = d^2 Vdot(90)/{dV(90)dV(55)} + HESS(812) = -D2A(106) +! HESS(813) = d^2 Vdot(90)/{dV(57)dV(86)} = d^2 Vdot(90)/{dV(86)dV(57)} + HESS(813) = D2A(173) +! HESS(814) = d^2 Vdot(90)/{dV(57)dV(90)} = d^2 Vdot(90)/{dV(90)dV(57)} + HESS(814) = -D2A(100) +! HESS(815) = d^2 Vdot(90)/{dV(59)dV(86)} = d^2 Vdot(90)/{dV(86)dV(59)} + HESS(815) = D2A(177) +! HESS(816) = d^2 Vdot(90)/{dV(59)dV(90)} = d^2 Vdot(90)/{dV(90)dV(59)} + HESS(816) = -D2A(104) +! HESS(817) = d^2 Vdot(90)/{dV(60)dV(84)} = d^2 Vdot(90)/{dV(84)dV(60)} + HESS(817) = D2A(80) +! HESS(818) = d^2 Vdot(90)/{dV(60)dV(86)} = d^2 Vdot(90)/{dV(86)dV(60)} + HESS(818) = D2A(171) +! HESS(819) = d^2 Vdot(90)/{dV(60)dV(90)} = d^2 Vdot(90)/{dV(90)dV(60)} + HESS(819) = -D2A(98) +! HESS(820) = d^2 Vdot(90)/{dV(62)dV(84)} = d^2 Vdot(90)/{dV(84)dV(62)} + HESS(820) = D2A(79) +! HESS(821) = d^2 Vdot(90)/{dV(62)dV(86)} = d^2 Vdot(90)/{dV(86)dV(62)} + HESS(821) = D2A(170) +! HESS(822) = d^2 Vdot(90)/{dV(62)dV(90)} = d^2 Vdot(90)/{dV(90)dV(62)} + HESS(822) = -D2A(97) +! HESS(823) = d^2 Vdot(90)/{dV(63)dV(86)} = d^2 Vdot(90)/{dV(86)dV(63)} + HESS(823) = D2A(183) +! HESS(824) = d^2 Vdot(90)/{dV(63)dV(90)} = d^2 Vdot(90)/{dV(90)dV(63)} + HESS(824) = -D2A(109) +! HESS(825) = d^2 Vdot(90)/{dV(64)dV(86)} = d^2 Vdot(90)/{dV(86)dV(64)} + HESS(825) = D2A(176) +! HESS(826) = d^2 Vdot(90)/{dV(64)dV(90)} = d^2 Vdot(90)/{dV(90)dV(64)} + HESS(826) = -D2A(103) +! HESS(827) = d^2 Vdot(90)/{dV(65)dV(86)} = d^2 Vdot(90)/{dV(86)dV(65)} + HESS(827) = D2A(175) +! HESS(828) = d^2 Vdot(90)/{dV(65)dV(90)} = d^2 Vdot(90)/{dV(90)dV(65)} + HESS(828) = -D2A(102) +! HESS(829) = d^2 Vdot(90)/{dV(66)dV(86)} = d^2 Vdot(90)/{dV(86)dV(66)} + HESS(829) = D2A(174) +! HESS(830) = d^2 Vdot(90)/{dV(66)dV(90)} = d^2 Vdot(90)/{dV(90)dV(66)} + HESS(830) = -D2A(101) +! HESS(831) = d^2 Vdot(90)/{dV(67)dV(86)} = d^2 Vdot(90)/{dV(86)dV(67)} + HESS(831) = D2A(182) +! HESS(832) = d^2 Vdot(90)/{dV(67)dV(90)} = d^2 Vdot(90)/{dV(90)dV(67)} + HESS(832) = -D2A(108) +! HESS(833) = d^2 Vdot(90)/{dV(70)dV(86)} = d^2 Vdot(90)/{dV(86)dV(70)} + HESS(833) = D2A(132) +! HESS(834) = d^2 Vdot(90)/{dV(70)dV(90)} = d^2 Vdot(90)/{dV(90)dV(70)} + HESS(834) = -D2A(76) +! HESS(835) = d^2 Vdot(90)/{dV(72)dV(85)} = d^2 Vdot(90)/{dV(85)dV(72)} + HESS(835) = 0.18*D2A(43) +! HESS(836) = d^2 Vdot(90)/{dV(72)dV(86)} = d^2 Vdot(90)/{dV(86)dV(72)} + HESS(836) = 1.18*D2A(169) +! HESS(837) = d^2 Vdot(90)/{dV(72)dV(90)} = d^2 Vdot(90)/{dV(90)dV(72)} + HESS(837) = -0.91*D2A(95) +! HESS(838) = d^2 Vdot(90)/{dV(74)dV(86)} = d^2 Vdot(90)/{dV(86)dV(74)} + HESS(838) = D2A(199) +! HESS(839) = d^2 Vdot(90)/{dV(74)dV(90)} = d^2 Vdot(90)/{dV(90)dV(74)} + HESS(839) = -D2A(93) +! HESS(840) = d^2 Vdot(90)/{dV(78)dV(86)} = d^2 Vdot(90)/{dV(86)dV(78)} + HESS(840) = D2A(203) +! HESS(841) = d^2 Vdot(90)/{dV(78)dV(90)} = d^2 Vdot(90)/{dV(90)dV(78)} + HESS(841) = -D2A(143)-D2A(146) +! HESS(842) = d^2 Vdot(90)/{dV(79)dV(86)} = d^2 Vdot(90)/{dV(86)dV(79)} + HESS(842) = D2A(172) +! HESS(843) = d^2 Vdot(90)/{dV(79)dV(90)} = d^2 Vdot(90)/{dV(90)dV(79)} + HESS(843) = -D2A(99) +! HESS(844) = d^2 Vdot(90)/{dV(81)dV(86)} = d^2 Vdot(90)/{dV(86)dV(81)} + HESS(844) = D2A(201) +! HESS(845) = d^2 Vdot(90)/{dV(81)dV(90)} = d^2 Vdot(90)/{dV(90)dV(81)} + HESS(845) = -D2A(141)-D2A(144) +! HESS(846) = d^2 Vdot(90)/{dV(84)dV(86)} = d^2 Vdot(90)/{dV(86)dV(84)} + HESS(846) = 0.44*D2A(115) +! HESS(847) = d^2 Vdot(90)/{dV(84)dV(90)} = d^2 Vdot(90)/{dV(90)dV(84)} + HESS(847) = -D2A(14) +! HESS(848) = d^2 Vdot(90)/{dV(85)dV(86)} = d^2 Vdot(90)/{dV(86)dV(85)} + HESS(848) = D2A(35) +! HESS(849) = d^2 Vdot(90)/{dV(85)dV(90)} = d^2 Vdot(90)/{dV(90)dV(85)} + HESS(849) = -D2A(13) +! HESS(850) = d^2 Vdot(90)/{dV(86)dV(86)} = d^2 Vdot(90)/{dV(86)dV(86)} + HESS(850) = 2*D2A(166) +! HESS(851) = d^2 Vdot(90)/{dV(86)dV(88)} = d^2 Vdot(90)/{dV(88)dV(86)} + HESS(851) = D2A(202) +! HESS(852) = d^2 Vdot(90)/{dV(86)dV(90)} = d^2 Vdot(90)/{dV(90)dV(86)} + HESS(852) = -D2A(168) +! HESS(853) = d^2 Vdot(90)/{dV(88)dV(90)} = d^2 Vdot(90)/{dV(90)dV(88)} + HESS(853) = -D2A(142)-D2A(145) +! HESS(854) = d^2 Vdot(90)/{dV(89)dV(90)} = d^2 Vdot(90)/{dV(90)dV(89)} + HESS(854) = -D2A(5) +! HESS(855) = d^2 Vdot(90)/{dV(90)dV(90)} = d^2 Vdot(90)/{dV(90)dV(90)} + HESS(855) = -2*D2A(15)-2*D2A(16) + +END SUBROUTINE Hessian + +! End of Hessian function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! HessTR_Vec - Hessian transposed times user vectors +! Arguments : +! HESS - Hessian of Var (i.e. the 3-tensor d Jac / d Var) +! U1 - User vector +! U2 - User vector +! HTU - Transposed Hessian times user vectors: (Hess x U2)^T * U1 = [d (Jac^T*U1)/d Var] * U2 +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE HessTR_Vec ( HESS, U1, U2, HTU ) + +! HESS - Hessian of Var (i.e. the 3-tensor d Jac / d Var) + REAL(kind=dp) :: HESS(NHESS) +! U1 - User vector + REAL(kind=dp) :: U1(NVAR) +! U2 - User vector + REAL(kind=dp) :: U2(NVAR) +! HTU - Transposed Hessian times user vectors: (Hess x U2)^T * U1 = [d (Jac^T*U1)/d Var] * U2 + REAL(kind=dp) :: HTU(NVAR) + +! Compute the vector HTU =(Hess x U2)^T * U1 = d (Jac^T*U1)/d Var * U2 + HTU(1) = 0 + HTU(2) = 0 + HTU(3) = 0 + HTU(4) = 0 + HTU(5) = 0 + HTU(6) = 0 + HTU(7) = 0 + HTU(8) = 0 + HTU(9) = 0 + HTU(10) = 0 + HTU(11) = 0 + HTU(12) = 0 + HTU(13) = 0 + HTU(14) = 0 + HTU(15) = 0 + HTU(16) = HESS(8)*(U1(16)*U2(83))+HESS(117)*(U1(52)*U2(83))+HESS(126)*(U1(53)*U2(83))+HESS(532)*(U1(83)*U2(83)) + HTU(17) = HESS(9)*(U1(17)*U2(83))+HESS(533)*(U1(83)*U2(83))+HESS(589)*(U1(84)*U2(83)) + HTU(18) = 0 + HTU(19) = 0 + HTU(20) = HESS(1)*(U1(11)*U2(83))+HESS(14)*(U1(20)*U2(83))+HESS(534)*(U1(83)*U2(83))+HESS(590)*(U1(84)*U2(83)) + HTU(21) = 0 + HTU(22) = HESS(18)*(U1(22)*U2(83))+HESS(19)*(U1(22)*U2(87))+HESS(145)*(U1(56)*U2(87))+HESS(368)*(U1(72)*U2(83))& + &+HESS(369)*(U1(72)*U2(87))+HESS(535)*(U1(83)*U2(83))+HESS(758)*(U1(87)*U2(87)) + HTU(23) = HESS(20)*(U1(23)*U2(83))+HESS(21)*(U1(23)*U2(87))+HESS(146)*(U1(56)*U2(87))+HESS(383)*(U1(74)*U2(83))& + &+HESS(384)*(U1(74)*U2(87))+HESS(536)*(U1(83)*U2(83))+HESS(759)*(U1(87)*U2(87)) + HTU(24) = HESS(22)*(U1(24)*U2(83))+HESS(478)*(U1(82)*U2(83))+HESS(537)*(U1(83)*U2(83)) + HTU(25) = 0 + HTU(26) = HESS(25)*(U1(26)*U2(83))+HESS(445)*(U1(78)*U2(83))+HESS(538)*(U1(83)*U2(83)) + HTU(27) = HESS(27)*(U1(27)*U2(83))+HESS(269)*(U1(69)*U2(83))+HESS(539)*(U1(83)*U2(83))+HESS(717)*(U1(86)*U2(83)) + HTU(28) = HESS(29)*(U1(28)*U2(83))+HESS(270)*(U1(69)*U2(83))+HESS(540)*(U1(83)*U2(83))+HESS(799)*(U1(90)*U2(83)) + HTU(29) = HESS(31)*(U1(29)*U2(83))+HESS(479)*(U1(82)*U2(83))+HESS(541)*(U1(83)*U2(83)) + HTU(30) = HESS(33)*(U1(30)*U2(83))+HESS(242)*(U1(68)*U2(83))+HESS(370)*(U1(72)*U2(83))+HESS(542)*(U1(83)*U2(83)) + HTU(31) = HESS(35)*(U1(31)*U2(83))+HESS(118)*(U1(52)*U2(83))+HESS(243)*(U1(68)*U2(83))+HESS(543)*(U1(83)*U2(83)) + HTU(32) = HESS(37)*(U1(32)*U2(83))+HESS(93)*(U1(49)*U2(83))+HESS(127)*(U1(53)*U2(83))+HESS(544)*(U1(83)*U2(83)) + HTU(33) = HESS(39)*(U1(33)*U2(83))+HESS(343)*(U1(71)*U2(83))+HESS(470)*(U1(81)*U2(83))+HESS(545)*(U1(83)*U2(83)) + HTU(34) = HESS(2)*(U1(12)*U2(83))+HESS(15)*(U1(20)*U2(83))+HESS(16)*(U1(20)*U2(87))+HESS(41)*(U1(34)*U2(83))+HESS(42)& + &*(U1(34)*U2(87))+HESS(147)*(U1(56)*U2(87))+HESS(271)*(U1(69)*U2(83))+HESS(272)*(U1(69)*U2(87))+HESS(546)& + &*(U1(83)*U2(83))+HESS(760)*(U1(87)*U2(87))+HESS(800)*(U1(90)*U2(83))+HESS(801)*(U1(90)*U2(87)) + HTU(35) = HESS(43)*(U1(35)*U2(83))+HESS(344)*(U1(71)*U2(83))+HESS(385)*(U1(74)*U2(83))+HESS(547)*(U1(83)*U2(83)) + HTU(36) = HESS(45)*(U1(36)*U2(83))+HESS(548)*(U1(83)*U2(83))+HESS(776)*(U1(88)*U2(83)) + HTU(37) = HESS(47)*(U1(37)*U2(83))+HESS(337)*(U1(70)*U2(83))+HESS(549)*(U1(83)*U2(83)) + HTU(38) = HESS(49)*(U1(38)*U2(83))+HESS(213)*(U1(63)*U2(83))+HESS(550)*(U1(83)*U2(83)) + HTU(39) = HESS(51)*(U1(39)*U2(83))+HESS(236)*(U1(67)*U2(83))+HESS(551)*(U1(83)*U2(83)) + HTU(40) = HESS(53)*(U1(40)*U2(83))+HESS(181)*(U1(59)*U2(83))+HESS(552)*(U1(83)*U2(83)) + HTU(41) = HESS(55)*(U1(41)*U2(83))+HESS(230)*(U1(66)*U2(83))+HESS(553)*(U1(83)*U2(83)) + HTU(42) = HESS(57)*(U1(42)*U2(83))+HESS(219)*(U1(64)*U2(83))+HESS(244)*(U1(68)*U2(83))+HESS(554)*(U1(83)*U2(83)) + HTU(43) = HESS(59)*(U1(43)*U2(83))+HESS(225)*(U1(65)*U2(83))+HESS(245)*(U1(68)*U2(83))+HESS(480)*(U1(82)*U2(83))& + &+HESS(555)*(U1(83)*U2(83)) + HTU(44) = HESS(63)*(U1(44)*U2(83))+HESS(64)*(U1(44)*U2(89))+HESS(193)*(U1(61)*U2(83))+HESS(273)*(U1(69)*U2(83))& + &+HESS(274)*(U1(69)*U2(89))+HESS(481)*(U1(82)*U2(83))+HESS(482)*(U1(82)*U2(89))+HESS(556)*(U1(83)*U2(83))& + &+HESS(591)*(U1(84)*U2(83))+HESS(592)*(U1(84)*U2(89))+HESS(783)*(U1(89)*U2(89)) + HTU(45) = HESS(66)*(U1(45)*U2(83))+HESS(172)*(U1(58)*U2(83))+HESS(454)*(U1(79)*U2(83))+HESS(557)*(U1(83)*U2(83)) + HTU(46) = HESS(3)*(U1(13)*U2(89))+HESS(7)*(U1(15)*U2(83))+HESS(69)*(U1(46)*U2(83))+HESS(70)*(U1(46)*U2(87))+HESS(71)& + &*(U1(46)*U2(89))+HESS(72)*(U1(47)*U2(89))+HESS(89)*(U1(48)*U2(89))+HESS(237)*(U1(67)*U2(87))+HESS(275)& + &*(U1(69)*U2(89))+HESS(436)*(U1(77)*U2(89))+HESS(455)*(U1(79)*U2(83))+HESS(460)*(U1(80)*U2(89))+HESS(558)& + &*(U1(83)*U2(83))+HESS(559)*(U1(83)*U2(89))+HESS(593)*(U1(84)*U2(89))+HESS(761)*(U1(87)*U2(87))+HESS(784)& + &*(U1(89)*U2(89)) + HTU(47) = HESS(4)*(U1(13)*U2(83))+HESS(73)*(U1(47)*U2(83))+HESS(560)*(U1(83)*U2(83))+HESS(594)*(U1(84)*U2(83)) + HTU(48) = HESS(74)*(U1(47)*U2(89))+HESS(90)*(U1(48)*U2(83))+HESS(91)*(U1(48)*U2(87))+HESS(92)*(U1(48)*U2(89))& + &+HESS(214)*(U1(63)*U2(87))+HESS(276)*(U1(69)*U2(89))+HESS(338)*(U1(70)*U2(83))+HESS(345)*(U1(71)*U2(89))& + &+HESS(561)*(U1(83)*U2(83))+HESS(562)*(U1(83)*U2(89))+HESS(595)*(U1(84)*U2(89))+HESS(762)*(U1(87)*U2(87))& + &+HESS(785)*(U1(89)*U2(89))+HESS(802)*(U1(90)*U2(89)) + HTU(49) = HESS(94)*(U1(49)*U2(83))+HESS(208)*(U1(62)*U2(83))+HESS(563)*(U1(83)*U2(83)) + HTU(50) = HESS(75)*(U1(47)*U2(83))+HESS(101)*(U1(50)*U2(83))+HESS(564)*(U1(83)*U2(83))+HESS(596)*(U1(84)*U2(83))& + &+HESS(777)*(U1(88)*U2(83)) + HTU(51) = HESS(60)*(U1(43)*U2(84))+HESS(102)*(U1(50)*U2(85))+HESS(113)*(U1(51)*U2(84))+HESS(114)*(U1(51)*U2(85))& + &+HESS(115)*(U1(51)*U2(86))+HESS(116)*(U1(51)*U2(90))+HESS(148)*(U1(56)*U2(85))+HESS(246)*(U1(68)*U2(86))& + &+HESS(247)*(U1(68)*U2(90))+HESS(277)*(U1(69)*U2(85))+HESS(278)*(U1(69)*U2(86))+HESS(279)*(U1(69)*U2(90))& + &+HESS(397)*(U1(75)*U2(85))+HESS(398)*(U1(75)*U2(86))+HESS(399)*(U1(75)*U2(90))+HESS(483)*(U1(82)*U2(85))& + &+HESS(484)*(U1(82)*U2(86))+HESS(485)*(U1(82)*U2(90))+HESS(597)*(U1(84)*U2(84))+HESS(598)*(U1(84)*U2(85))& + &+HESS(599)*(U1(84)*U2(86))+HESS(600)*(U1(84)*U2(90))+HESS(689)*(U1(85)*U2(85))+HESS(718)*(U1(86)*U2(85))& + &+HESS(719)*(U1(86)*U2(86))+HESS(720)*(U1(86)*U2(90))+HESS(803)*(U1(90)*U2(86))+HESS(804)*(U1(90)*U2(90)) + HTU(52) = HESS(36)*(U1(31)*U2(84))+HESS(119)*(U1(52)*U2(84))+HESS(120)*(U1(52)*U2(85))+HESS(121)*(U1(52)*U2(86))& + &+HESS(122)*(U1(52)*U2(90))+HESS(248)*(U1(68)*U2(85))+HESS(249)*(U1(68)*U2(86))+HESS(250)*(U1(68)*U2(90))& + &+HESS(280)*(U1(69)*U2(90))+HESS(486)*(U1(82)*U2(85))+HESS(601)*(U1(84)*U2(84))+HESS(602)*(U1(84)*U2(85))& + &+HESS(603)*(U1(84)*U2(86))+HESS(604)*(U1(84)*U2(90))+HESS(690)*(U1(85)*U2(85))+HESS(721)*(U1(86)*U2(86))& + &+HESS(805)*(U1(90)*U2(86))+HESS(806)*(U1(90)*U2(90)) + HTU(53) = HESS(38)*(U1(32)*U2(84))+HESS(95)*(U1(49)*U2(85))+HESS(96)*(U1(49)*U2(86))+HESS(97)*(U1(49)*U2(90))& + &+HESS(128)*(U1(53)*U2(84))+HESS(129)*(U1(53)*U2(85))+HESS(130)*(U1(53)*U2(86))+HESS(131)*(U1(53)*U2(90))& + &+HESS(281)*(U1(69)*U2(90))+HESS(487)*(U1(82)*U2(85))+HESS(605)*(U1(84)*U2(84))+HESS(606)*(U1(84)*U2(85))& + &+HESS(607)*(U1(84)*U2(86))+HESS(608)*(U1(84)*U2(90))+HESS(691)*(U1(85)*U2(85))+HESS(722)*(U1(86)*U2(86))& + &+HESS(807)*(U1(90)*U2(86))+HESS(808)*(U1(90)*U2(90)) + HTU(54) = HESS(135)*(U1(54)*U2(84))+HESS(136)*(U1(54)*U2(85))+HESS(137)*(U1(54)*U2(86))+HESS(138)*(U1(54)*U2(90))& + &+HESS(251)*(U1(68)*U2(85))+HESS(252)*(U1(68)*U2(86))+HESS(253)*(U1(68)*U2(90))+HESS(282)*(U1(69)*U2(85))& + &+HESS(283)*(U1(69)*U2(86))+HESS(284)*(U1(69)*U2(90))+HESS(346)*(U1(71)*U2(85))+HESS(347)*(U1(71)*U2(86))& + &+HESS(348)*(U1(71)*U2(90))+HESS(371)*(U1(72)*U2(85))+HESS(372)*(U1(72)*U2(86))+HESS(373)*(U1(72)*U2(90))& + &+HESS(378)*(U1(73)*U2(84))+HESS(488)*(U1(82)*U2(85))+HESS(489)*(U1(82)*U2(86))+HESS(490)*(U1(82)*U2(90))& + &+HESS(609)*(U1(84)*U2(84))+HESS(610)*(U1(84)*U2(90))+HESS(692)*(U1(85)*U2(85))+HESS(723)*(U1(86)*U2(86))& + &+HESS(809)*(U1(90)*U2(86))+HESS(810)*(U1(90)*U2(90)) + HTU(55) = HESS(61)*(U1(43)*U2(84))+HESS(140)*(U1(55)*U2(84))+HESS(141)*(U1(55)*U2(85))+HESS(142)*(U1(55)*U2(86))& + &+HESS(143)*(U1(55)*U2(90))+HESS(254)*(U1(68)*U2(86))+HESS(255)*(U1(68)*U2(90))+HESS(285)*(U1(69)*U2(85))& + &+HESS(286)*(U1(69)*U2(86))+HESS(287)*(U1(69)*U2(90))+HESS(400)*(U1(75)*U2(85))+HESS(401)*(U1(75)*U2(86))& + &+HESS(402)*(U1(75)*U2(90))+HESS(491)*(U1(82)*U2(85))+HESS(492)*(U1(82)*U2(86))+HESS(493)*(U1(82)*U2(90))& + &+HESS(611)*(U1(84)*U2(84))+HESS(612)*(U1(84)*U2(90))+HESS(693)*(U1(85)*U2(85))+HESS(724)*(U1(86)*U2(86))& + &+HESS(811)*(U1(90)*U2(86))+HESS(812)*(U1(90)*U2(90)) + HTU(56) = HESS(149)*(U1(56)*U2(83))+HESS(565)*(U1(83)*U2(83))+HESS(763)*(U1(87)*U2(83)) + HTU(57) = HESS(67)*(U1(45)*U2(84))+HESS(150)*(U1(56)*U2(85))+HESS(166)*(U1(57)*U2(84))+HESS(167)*(U1(57)*U2(85))& + &+HESS(168)*(U1(57)*U2(86))+HESS(169)*(U1(57)*U2(90))+HESS(173)*(U1(58)*U2(85))+HESS(174)*(U1(58)*U2(86))& + &+HESS(175)*(U1(58)*U2(90))+HESS(288)*(U1(69)*U2(85))+HESS(289)*(U1(69)*U2(86))+HESS(290)*(U1(69)*U2(90))& + &+HESS(419)*(U1(76)*U2(86))+HESS(420)*(U1(76)*U2(90))+HESS(494)*(U1(82)*U2(85))+HESS(613)*(U1(84)*U2(84))& + &+HESS(614)*(U1(84)*U2(85))+HESS(615)*(U1(84)*U2(86))+HESS(616)*(U1(84)*U2(90))+HESS(694)*(U1(85)*U2(85))& + &+HESS(725)*(U1(86)*U2(86))+HESS(813)*(U1(90)*U2(86))+HESS(814)*(U1(90)*U2(90)) + HTU(58) = HESS(76)*(U1(47)*U2(89))+HESS(103)*(U1(50)*U2(89))+HESS(176)*(U1(58)*U2(83))+HESS(177)*(U1(58)*U2(89))& + &+HESS(194)*(U1(61)*U2(89))+HESS(231)*(U1(66)*U2(83))+HESS(291)*(U1(69)*U2(89))+HESS(403)*(U1(75)*U2(89))& + &+HESS(446)*(U1(78)*U2(83))+HESS(566)*(U1(83)*U2(83))+HESS(567)*(U1(83)*U2(89))+HESS(617)*(U1(84)*U2(83))& + &+HESS(786)*(U1(89)*U2(89)) + HTU(59) = HESS(54)*(U1(40)*U2(84))+HESS(77)*(U1(47)*U2(86))+HESS(78)*(U1(47)*U2(90))+HESS(151)*(U1(56)*U2(85))& + &+HESS(182)*(U1(59)*U2(84))+HESS(183)*(U1(59)*U2(85))+HESS(184)*(U1(59)*U2(86))+HESS(185)*(U1(59)*U2(90))& + &+HESS(195)*(U1(61)*U2(85))+HESS(196)*(U1(61)*U2(86))+HESS(197)*(U1(61)*U2(90))+HESS(292)*(U1(69)*U2(85))& + &+HESS(293)*(U1(69)*U2(86))+HESS(294)*(U1(69)*U2(90))+HESS(404)*(U1(75)*U2(86))+HESS(421)*(U1(76)*U2(86))& + &+HESS(495)*(U1(82)*U2(85))+HESS(618)*(U1(84)*U2(84))+HESS(619)*(U1(84)*U2(85))+HESS(620)*(U1(84)*U2(86))& + &+HESS(621)*(U1(84)*U2(90))+HESS(695)*(U1(85)*U2(85))+HESS(726)*(U1(86)*U2(86))+HESS(815)*(U1(90)*U2(86))& + &+HESS(816)*(U1(90)*U2(90)) + HTU(60) = HESS(187)*(U1(60)*U2(84))+HESS(188)*(U1(60)*U2(85))+HESS(189)*(U1(60)*U2(86))+HESS(190)*(U1(60)*U2(90))& + &+HESS(295)*(U1(69)*U2(90))+HESS(349)*(U1(71)*U2(85))+HESS(350)*(U1(71)*U2(86))+HESS(351)*(U1(71)*U2(90))& + &+HESS(379)*(U1(73)*U2(85))+HESS(405)*(U1(75)*U2(84))+HESS(422)*(U1(76)*U2(86))+HESS(423)*(U1(76)*U2(90))& + &+HESS(496)*(U1(82)*U2(85))+HESS(622)*(U1(84)*U2(84))+HESS(623)*(U1(84)*U2(90))+HESS(696)*(U1(85)*U2(85))& + &+HESS(727)*(U1(86)*U2(85))+HESS(728)*(U1(86)*U2(86))+HESS(729)*(U1(86)*U2(90))+HESS(817)*(U1(90)*U2(84))& + &+HESS(818)*(U1(90)*U2(86))+HESS(819)*(U1(90)*U2(90)) + HTU(61) = HESS(198)*(U1(61)*U2(83))+HESS(406)*(U1(75)*U2(83))+HESS(568)*(U1(83)*U2(83))+HESS(624)*(U1(84)*U2(83)) + HTU(62) = HESS(199)*(U1(61)*U2(90))+HESS(209)*(U1(62)*U2(84))+HESS(210)*(U1(62)*U2(85))+HESS(211)*(U1(62)*U2(86))& + &+HESS(212)*(U1(62)*U2(90))+HESS(296)*(U1(69)*U2(85))+HESS(297)*(U1(69)*U2(86))+HESS(298)*(U1(69)*U2(90))& + &+HESS(380)*(U1(73)*U2(85))+HESS(407)*(U1(75)*U2(86))+HESS(408)*(U1(75)*U2(90))+HESS(424)*(U1(76)*U2(86))& + &+HESS(497)*(U1(82)*U2(85))+HESS(625)*(U1(84)*U2(84))+HESS(626)*(U1(84)*U2(86))+HESS(627)*(U1(84)*U2(90))& + &+HESS(697)*(U1(85)*U2(85))+HESS(730)*(U1(86)*U2(84))+HESS(731)*(U1(86)*U2(85))+HESS(732)*(U1(86)*U2(86))& + &+HESS(733)*(U1(86)*U2(90))+HESS(820)*(U1(90)*U2(84))+HESS(821)*(U1(90)*U2(86))+HESS(822)*(U1(90)*U2(90)) + HTU(63) = HESS(50)*(U1(38)*U2(84))+HESS(215)*(U1(63)*U2(84))+HESS(216)*(U1(63)*U2(85))+HESS(217)*(U1(63)*U2(86))& + &+HESS(218)*(U1(63)*U2(90))+HESS(256)*(U1(68)*U2(86))+HESS(257)*(U1(68)*U2(90))+HESS(299)*(U1(69)*U2(85))& + &+HESS(300)*(U1(69)*U2(86))+HESS(301)*(U1(69)*U2(90))+HESS(352)*(U1(71)*U2(85))+HESS(353)*(U1(71)*U2(86))& + &+HESS(354)*(U1(71)*U2(90))+HESS(498)*(U1(82)*U2(85))+HESS(499)*(U1(82)*U2(86))+HESS(500)*(U1(82)*U2(90))& + &+HESS(628)*(U1(84)*U2(84))+HESS(629)*(U1(84)*U2(90))+HESS(698)*(U1(85)*U2(85))+HESS(734)*(U1(86)*U2(86))& + &+HESS(823)*(U1(90)*U2(86))+HESS(824)*(U1(90)*U2(90)) + HTU(64) = HESS(58)*(U1(42)*U2(84))+HESS(104)*(U1(50)*U2(85))+HESS(105)*(U1(50)*U2(86))+HESS(106)*(U1(50)*U2(90))& + &+HESS(152)*(U1(56)*U2(85))+HESS(220)*(U1(64)*U2(84))+HESS(221)*(U1(64)*U2(85))+HESS(222)*(U1(64)*U2(86))& + &+HESS(223)*(U1(64)*U2(90))+HESS(302)*(U1(69)*U2(85))+HESS(303)*(U1(69)*U2(86))+HESS(304)*(U1(69)*U2(90))& + &+HESS(409)*(U1(75)*U2(85))+HESS(410)*(U1(75)*U2(86))+HESS(411)*(U1(75)*U2(90))+HESS(425)*(U1(76)*U2(86))& + &+HESS(426)*(U1(76)*U2(90))+HESS(501)*(U1(82)*U2(85))+HESS(630)*(U1(84)*U2(84))+HESS(631)*(U1(84)*U2(85))& + &+HESS(632)*(U1(84)*U2(86))+HESS(633)*(U1(84)*U2(90))+HESS(699)*(U1(85)*U2(85))+HESS(735)*(U1(86)*U2(85))& + &+HESS(736)*(U1(86)*U2(86))+HESS(737)*(U1(86)*U2(90))+HESS(825)*(U1(90)*U2(86))+HESS(826)*(U1(90)*U2(90)) + HTU(65) = HESS(62)*(U1(43)*U2(84))+HESS(107)*(U1(50)*U2(85))+HESS(108)*(U1(50)*U2(86))+HESS(109)*(U1(50)*U2(90))& + &+HESS(153)*(U1(56)*U2(85))+HESS(200)*(U1(61)*U2(85))+HESS(201)*(U1(61)*U2(86))+HESS(202)*(U1(61)*U2(90))& + &+HESS(226)*(U1(65)*U2(84))+HESS(227)*(U1(65)*U2(85))+HESS(228)*(U1(65)*U2(86))+HESS(229)*(U1(65)*U2(90))& + &+HESS(258)*(U1(68)*U2(86))+HESS(259)*(U1(68)*U2(90))+HESS(305)*(U1(69)*U2(90))+HESS(502)*(U1(82)*U2(85))& + &+HESS(503)*(U1(82)*U2(86))+HESS(504)*(U1(82)*U2(90))+HESS(634)*(U1(84)*U2(84))+HESS(635)*(U1(84)*U2(85))& + &+HESS(636)*(U1(84)*U2(90))+HESS(700)*(U1(85)*U2(85))+HESS(738)*(U1(86)*U2(86))+HESS(827)*(U1(90)*U2(86))& + &+HESS(828)*(U1(90)*U2(90)) + HTU(66) = HESS(56)*(U1(41)*U2(84))+HESS(79)*(U1(47)*U2(85))+HESS(80)*(U1(47)*U2(86))+HESS(81)*(U1(47)*U2(90))& + &+HESS(110)*(U1(50)*U2(85))+HESS(111)*(U1(50)*U2(86))+HESS(112)*(U1(50)*U2(90))+HESS(154)*(U1(56)*U2(85))& + &+HESS(203)*(U1(61)*U2(85))+HESS(204)*(U1(61)*U2(86))+HESS(205)*(U1(61)*U2(90))+HESS(232)*(U1(66)*U2(84))& + &+HESS(233)*(U1(66)*U2(85))+HESS(234)*(U1(66)*U2(86))+HESS(235)*(U1(66)*U2(90))+HESS(306)*(U1(69)*U2(85))& + &+HESS(307)*(U1(69)*U2(86))+HESS(308)*(U1(69)*U2(90))+HESS(412)*(U1(75)*U2(85))+HESS(413)*(U1(75)*U2(86))& + &+HESS(414)*(U1(75)*U2(90))+HESS(427)*(U1(76)*U2(86))+HESS(428)*(U1(76)*U2(90))+HESS(505)*(U1(82)*U2(85))& + &+HESS(637)*(U1(84)*U2(84))+HESS(638)*(U1(84)*U2(85))+HESS(639)*(U1(84)*U2(86))+HESS(640)*(U1(84)*U2(90))& + &+HESS(701)*(U1(85)*U2(85))+HESS(739)*(U1(86)*U2(86))+HESS(829)*(U1(90)*U2(86))+HESS(830)*(U1(90)*U2(90)) + HTU(67) = HESS(52)*(U1(39)*U2(84))+HESS(155)*(U1(56)*U2(85))+HESS(156)*(U1(56)*U2(86))+HESS(157)*(U1(56)*U2(90))& + &+HESS(238)*(U1(67)*U2(84))+HESS(239)*(U1(67)*U2(85))+HESS(240)*(U1(67)*U2(86))+HESS(241)*(U1(67)*U2(90))& + &+HESS(260)*(U1(68)*U2(86))+HESS(261)*(U1(68)*U2(90))+HESS(309)*(U1(69)*U2(85))+HESS(310)*(U1(69)*U2(86))& + &+HESS(311)*(U1(69)*U2(90))+HESS(437)*(U1(77)*U2(85))+HESS(438)*(U1(77)*U2(86))+HESS(439)*(U1(77)*U2(90))& + &+HESS(461)*(U1(80)*U2(85))+HESS(462)*(U1(80)*U2(86))+HESS(463)*(U1(80)*U2(90))+HESS(506)*(U1(82)*U2(85))& + &+HESS(507)*(U1(82)*U2(86))+HESS(508)*(U1(82)*U2(90))+HESS(641)*(U1(84)*U2(84))+HESS(642)*(U1(84)*U2(85))& + &+HESS(643)*(U1(84)*U2(86))+HESS(644)*(U1(84)*U2(90))+HESS(702)*(U1(85)*U2(85))+HESS(740)*(U1(86)*U2(86))& + &+HESS(831)*(U1(90)*U2(86))+HESS(832)*(U1(90)*U2(90)) + HTU(68) = HESS(158)*(U1(56)*U2(87))+HESS(262)*(U1(68)*U2(83))+HESS(263)*(U1(68)*U2(87))+HESS(471)*(U1(81)*U2(83))& + &+HESS(472)*(U1(81)*U2(87))+HESS(569)*(U1(83)*U2(83))+HESS(764)*(U1(87)*U2(87)) + HTU(69) = HESS(82)*(U1(47)*U2(83))+HESS(83)*(U1(47)*U2(87))+HESS(159)*(U1(56)*U2(87))+HESS(312)*(U1(69)*U2(83))& + &+HESS(313)*(U1(69)*U2(87))+HESS(570)*(U1(83)*U2(83))+HESS(645)*(U1(84)*U2(83))+HESS(646)*(U1(84)*U2(87))& + &+HESS(765)*(U1(87)*U2(87)) + HTU(70) = HESS(48)*(U1(37)*U2(84))+HESS(206)*(U1(61)*U2(86))+HESS(207)*(U1(61)*U2(90))+HESS(264)*(U1(68)*U2(86))& + &+HESS(265)*(U1(68)*U2(90))+HESS(314)*(U1(69)*U2(85))+HESS(315)*(U1(69)*U2(86))+HESS(316)*(U1(69)*U2(90))& + &+HESS(339)*(U1(70)*U2(84))+HESS(340)*(U1(70)*U2(85))+HESS(341)*(U1(70)*U2(86))+HESS(342)*(U1(70)*U2(90))& + &+HESS(355)*(U1(71)*U2(85))+HESS(356)*(U1(71)*U2(86))+HESS(357)*(U1(71)*U2(90))+HESS(509)*(U1(82)*U2(85))& + &+HESS(647)*(U1(84)*U2(84))+HESS(648)*(U1(84)*U2(85))+HESS(649)*(U1(84)*U2(86))+HESS(650)*(U1(84)*U2(90))& + &+HESS(703)*(U1(85)*U2(85))+HESS(741)*(U1(86)*U2(86))+HESS(833)*(U1(90)*U2(86))+HESS(834)*(U1(90)*U2(90)) + HTU(71) = HESS(84)*(U1(47)*U2(83))+HESS(160)*(U1(56)*U2(87))+HESS(317)*(U1(69)*U2(83))+HESS(358)*(U1(71)*U2(83))& + &+HESS(359)*(U1(71)*U2(87))+HESS(571)*(U1(83)*U2(83))+HESS(651)*(U1(84)*U2(83))+HESS(742)*(U1(86)*U2(83))& + &+HESS(743)*(U1(86)*U2(87))+HESS(766)*(U1(87)*U2(87)) + HTU(72) = HESS(34)*(U1(30)*U2(84))+HESS(98)*(U1(49)*U2(85))+HESS(99)*(U1(49)*U2(86))+HESS(100)*(U1(49)*U2(90))& + &+HESS(123)*(U1(52)*U2(85))+HESS(124)*(U1(52)*U2(86))+HESS(125)*(U1(52)*U2(90))+HESS(132)*(U1(53)*U2(85))& + &+HESS(133)*(U1(53)*U2(86))+HESS(134)*(U1(53)*U2(90))+HESS(266)*(U1(68)*U2(85))+HESS(267)*(U1(68)*U2(86))& + &+HESS(268)*(U1(68)*U2(90))+HESS(318)*(U1(69)*U2(90))+HESS(360)*(U1(71)*U2(85))+HESS(361)*(U1(71)*U2(86))& + &+HESS(362)*(U1(71)*U2(90))+HESS(374)*(U1(72)*U2(84))+HESS(375)*(U1(72)*U2(85))+HESS(376)*(U1(72)*U2(86))& + &+HESS(377)*(U1(72)*U2(90))+HESS(381)*(U1(73)*U2(85))+HESS(386)*(U1(74)*U2(85))+HESS(387)*(U1(74)*U2(86))& + &+HESS(388)*(U1(74)*U2(90))+HESS(429)*(U1(76)*U2(85))+HESS(430)*(U1(76)*U2(86))+HESS(431)*(U1(76)*U2(90))& + &+HESS(510)*(U1(82)*U2(85))+HESS(652)*(U1(84)*U2(84))+HESS(653)*(U1(84)*U2(85))+HESS(654)*(U1(84)*U2(86))& + &+HESS(655)*(U1(84)*U2(90))+HESS(704)*(U1(85)*U2(85))+HESS(744)*(U1(86)*U2(86))+HESS(835)*(U1(90)*U2(85))& + &+HESS(836)*(U1(90)*U2(86))+HESS(837)*(U1(90)*U2(90)) + HTU(73) = HESS(139)*(U1(54)*U2(83))+HESS(382)*(U1(73)*U2(83))+HESS(572)*(U1(83)*U2(83)) + HTU(74) = HESS(44)*(U1(35)*U2(84))+HESS(319)*(U1(69)*U2(90))+HESS(363)*(U1(71)*U2(74))+HESS(364)*(U1(71)*U2(85))& + &+HESS(365)*(U1(71)*U2(86))+HESS(366)*(U1(71)*U2(90))+HESS(389)*(U1(74)*U2(74))+HESS(390)*(U1(74)*U2(84))& + &+HESS(391)*(U1(74)*U2(85))+HESS(392)*(U1(74)*U2(86))+HESS(393)*(U1(74)*U2(90))+HESS(511)*(U1(82)*U2(85))& + &+HESS(656)*(U1(84)*U2(74))+HESS(657)*(U1(84)*U2(84))+HESS(658)*(U1(84)*U2(85))+HESS(659)*(U1(84)*U2(86))& + &+HESS(660)*(U1(84)*U2(90))+HESS(705)*(U1(85)*U2(85))+HESS(745)*(U1(86)*U2(86))+HESS(838)*(U1(90)*U2(86))& + &+HESS(839)*(U1(90)*U2(90)) + HTU(75) = HESS(85)*(U1(47)*U2(83))+HESS(86)*(U1(47)*U2(87))+HESS(161)*(U1(56)*U2(87))+HESS(415)*(U1(75)*U2(83))& + &+HESS(416)*(U1(75)*U2(87))+HESS(573)*(U1(83)*U2(83))+HESS(746)*(U1(86)*U2(83))+HESS(747)*(U1(86)*U2(87))& + &+HESS(767)*(U1(87)*U2(87)) + HTU(76) = HESS(162)*(U1(56)*U2(87))+HESS(191)*(U1(60)*U2(83))+HESS(192)*(U1(60)*U2(87))+HESS(432)*(U1(76)*U2(83))& + &+HESS(433)*(U1(76)*U2(87))+HESS(574)*(U1(83)*U2(83))+HESS(768)*(U1(87)*U2(87)) + HTU(77) = HESS(87)*(U1(47)*U2(89))+HESS(224)*(U1(64)*U2(83))+HESS(320)*(U1(69)*U2(89))+HESS(367)*(U1(71)*U2(89))& + &+HESS(417)*(U1(75)*U2(89))+HESS(440)*(U1(77)*U2(83))+HESS(441)*(U1(77)*U2(89))+HESS(575)*(U1(83)*U2(83))& + &+HESS(576)*(U1(83)*U2(89))+HESS(661)*(U1(84)*U2(89))+HESS(787)*(U1(89)*U2(89)) + HTU(78) = HESS(26)*(U1(26)*U2(84))+HESS(65)*(U1(44)*U2(82))+HESS(321)*(U1(69)*U2(85))+HESS(322)*(U1(69)*U2(86))& + &+HESS(323)*(U1(69)*U2(90))+HESS(447)*(U1(78)*U2(82))+HESS(448)*(U1(78)*U2(84))+HESS(449)*(U1(78)*U2(85))& + &+HESS(450)*(U1(78)*U2(86))+HESS(451)*(U1(78)*U2(90))+HESS(512)*(U1(82)*U2(82))+HESS(513)*(U1(82)*U2(85))& + &+HESS(662)*(U1(84)*U2(84))+HESS(663)*(U1(84)*U2(90))+HESS(706)*(U1(85)*U2(85))+HESS(748)*(U1(86)*U2(85))& + &+HESS(749)*(U1(86)*U2(90))+HESS(788)*(U1(89)*U2(84))+HESS(840)*(U1(90)*U2(86))+HESS(841)*(U1(90)*U2(90)) + HTU(79) = HESS(68)*(U1(45)*U2(84))+HESS(163)*(U1(56)*U2(85))+HESS(170)*(U1(57)*U2(86))+HESS(171)*(U1(57)*U2(90))& + &+HESS(178)*(U1(58)*U2(85))+HESS(179)*(U1(58)*U2(86))+HESS(180)*(U1(58)*U2(90))+HESS(324)*(U1(69)*U2(85))& + &+HESS(325)*(U1(69)*U2(86))+HESS(326)*(U1(69)*U2(90))+HESS(434)*(U1(76)*U2(86))+HESS(435)*(U1(76)*U2(90))& + &+HESS(442)*(U1(77)*U2(85))+HESS(443)*(U1(77)*U2(86))+HESS(444)*(U1(77)*U2(90))+HESS(456)*(U1(79)*U2(84))& + &+HESS(457)*(U1(79)*U2(85))+HESS(458)*(U1(79)*U2(86))+HESS(459)*(U1(79)*U2(90))+HESS(464)*(U1(80)*U2(85))& + &+HESS(465)*(U1(80)*U2(86))+HESS(466)*(U1(80)*U2(90))+HESS(514)*(U1(82)*U2(85))+HESS(664)*(U1(84)*U2(84))& + &+HESS(665)*(U1(84)*U2(85))+HESS(666)*(U1(84)*U2(86))+HESS(667)*(U1(84)*U2(90))+HESS(707)*(U1(85)*U2(85))& + &+HESS(750)*(U1(86)*U2(86))+HESS(842)*(U1(90)*U2(86))+HESS(843)*(U1(90)*U2(90)) + HTU(80) = HESS(5)*(U1(13)*U2(89))+HESS(88)*(U1(47)*U2(89))+HESS(144)*(U1(55)*U2(87))+HESS(164)*(U1(56)*U2(87))& + &+HESS(186)*(U1(59)*U2(83))+HESS(327)*(U1(69)*U2(89))+HESS(418)*(U1(75)*U2(89))+HESS(452)*(U1(78)*U2(83))& + &+HESS(453)*(U1(78)*U2(87))+HESS(467)*(U1(80)*U2(83))+HESS(468)*(U1(80)*U2(87))+HESS(469)*(U1(80)*U2(89))& + &+HESS(577)*(U1(83)*U2(83))+HESS(578)*(U1(83)*U2(89))+HESS(668)*(U1(84)*U2(89))+HESS(769)*(U1(87)*U2(87))& + &+HESS(789)*(U1(89)*U2(89)) + HTU(81) = HESS(12)*(U1(18)*U2(82))+HESS(40)*(U1(33)*U2(84))+HESS(328)*(U1(69)*U2(90))+HESS(394)*(U1(74)*U2(85))& + &+HESS(395)*(U1(74)*U2(86))+HESS(396)*(U1(74)*U2(90))+HESS(473)*(U1(81)*U2(82))+HESS(474)*(U1(81)*U2(84))& + &+HESS(475)*(U1(81)*U2(85))+HESS(476)*(U1(81)*U2(86))+HESS(477)*(U1(81)*U2(90))+HESS(515)*(U1(82)*U2(82))& + &+HESS(516)*(U1(82)*U2(85))+HESS(669)*(U1(84)*U2(84))+HESS(670)*(U1(84)*U2(90))+HESS(708)*(U1(85)*U2(85))& + &+HESS(751)*(U1(86)*U2(86))+HESS(790)*(U1(89)*U2(84))+HESS(844)*(U1(90)*U2(86))+HESS(845)*(U1(90)*U2(90)) + HTU(82) = HESS(12)*(U1(18)*U2(81))+HESS(13)*(U1(19)*U2(88))+HESS(17)*(U1(21)*U2(86))+HESS(24)*(U1(25)*U2(87))+HESS(32)& + &*(U1(29)*U2(84))+HESS(65)*(U1(44)*U2(78))+HESS(165)*(U1(56)*U2(83))+HESS(447)*(U1(78)*U2(78))+HESS(473)& + &*(U1(81)*U2(81))+HESS(512)*(U1(82)*U2(78))+HESS(515)*(U1(82)*U2(81))+HESS(517)*(U1(82)*U2(83))+HESS(518)& + &*(U1(82)*U2(84))+HESS(519)*(U1(82)*U2(86))+HESS(520)*(U1(82)*U2(87))+HESS(521)*(U1(82)*U2(88))+HESS(522)& + &*(U1(82)*U2(89))+HESS(579)*(U1(83)*U2(83))+HESS(671)*(U1(84)*U2(84))+HESS(709)*(U1(85)*U2(87))+HESS(752)& + &*(U1(86)*U2(86))+HESS(770)*(U1(87)*U2(87))+HESS(771)*(U1(87)*U2(89))+HESS(778)*(U1(88)*U2(88))+HESS(791)& + &*(U1(89)*U2(89)) + HTU(83) = HESS(1)*(U1(11)*U2(20))+HESS(2)*(U1(12)*U2(34))+HESS(4)*(U1(13)*U2(47))+HESS(7)*(U1(15)*U2(46))+HESS(8)& + &*(U1(16)*U2(16))+HESS(9)*(U1(17)*U2(17))+HESS(10)*(U1(17)*U2(83))+HESS(14)*(U1(20)*U2(20))+HESS(15)*(U1(20)& + &*U2(34))+HESS(18)*(U1(22)*U2(22))+HESS(20)*(U1(23)*U2(23))+HESS(22)*(U1(24)*U2(24))+HESS(23)*(U1(24)*U2(85))& + &+HESS(25)*(U1(26)*U2(26))+HESS(27)*(U1(27)*U2(27))+HESS(29)*(U1(28)*U2(28))+HESS(31)*(U1(29)*U2(29))+HESS(33)& + &*(U1(30)*U2(30))+HESS(35)*(U1(31)*U2(31))+HESS(37)*(U1(32)*U2(32))+HESS(39)*(U1(33)*U2(33))+HESS(41)*(U1(34)& + &*U2(34))+HESS(43)*(U1(35)*U2(35))+HESS(45)*(U1(36)*U2(36))+HESS(47)*(U1(37)*U2(37))+HESS(49)*(U1(38)*U2(38))& + &+HESS(51)*(U1(39)*U2(39))+HESS(53)*(U1(40)*U2(40))+HESS(55)*(U1(41)*U2(41))+HESS(57)*(U1(42)*U2(42))+HESS(59)& + &*(U1(43)*U2(43))+HESS(63)*(U1(44)*U2(44))+HESS(66)*(U1(45)*U2(45))+HESS(69)*(U1(46)*U2(46))+HESS(73)*(U1(47)& + &*U2(47))+HESS(75)*(U1(47)*U2(50))+HESS(82)*(U1(47)*U2(69))+HESS(84)*(U1(47)*U2(71))+HESS(85)*(U1(47)*U2(75))& + &+HESS(90)*(U1(48)*U2(48))+HESS(93)*(U1(49)*U2(32))+HESS(94)*(U1(49)*U2(49))+HESS(101)*(U1(50)*U2(50))& + &+HESS(117)*(U1(52)*U2(16))+HESS(118)*(U1(52)*U2(31))+HESS(126)*(U1(53)*U2(16))+HESS(127)*(U1(53)*U2(32))& + &+HESS(139)*(U1(54)*U2(73))+HESS(149)*(U1(56)*U2(56))+HESS(165)*(U1(56)*U2(82))+HESS(172)*(U1(58)*U2(45))& + &+HESS(176)*(U1(58)*U2(58))+HESS(181)*(U1(59)*U2(40))+HESS(186)*(U1(59)*U2(80))+HESS(191)*(U1(60)*U2(76))& + &+HESS(193)*(U1(61)*U2(44))+HESS(198)*(U1(61)*U2(61))+HESS(208)*(U1(62)*U2(49))+HESS(213)*(U1(63)*U2(38))& + &+HESS(219)*(U1(64)*U2(42))+HESS(224)*(U1(64)*U2(77))+HESS(225)*(U1(65)*U2(43))+HESS(230)*(U1(66)*U2(41))& + &+HESS(231)*(U1(66)*U2(58))+HESS(236)*(U1(67)*U2(39))+HESS(242)*(U1(68)*U2(30))+HESS(243)*(U1(68)*U2(31))& + &+HESS(244)*(U1(68)*U2(42))+HESS(245)*(U1(68)*U2(43))+HESS(262)*(U1(68)*U2(68))+HESS(269)*(U1(69)*U2(27))& + &+HESS(270)*(U1(69)*U2(28))+HESS(271)*(U1(69)*U2(34))+HESS(273)*(U1(69)*U2(44))+HESS(312)*(U1(69)*U2(69))& + &+HESS(317)*(U1(69)*U2(71))+HESS(337)*(U1(70)*U2(37))+HESS(338)*(U1(70)*U2(48))+HESS(343)*(U1(71)*U2(33))& + &+HESS(344)*(U1(71)*U2(35))+HESS(358)*(U1(71)*U2(71))+HESS(368)*(U1(72)*U2(22))+HESS(370)*(U1(72)*U2(30))& + &+HESS(382)*(U1(73)*U2(73))+HESS(383)*(U1(74)*U2(23))+HESS(385)*(U1(74)*U2(35))+HESS(406)*(U1(75)*U2(61))& + &+HESS(415)*(U1(75)*U2(75))+HESS(432)*(U1(76)*U2(76))+HESS(440)*(U1(77)*U2(77))+HESS(445)*(U1(78)*U2(26))& + &+HESS(446)*(U1(78)*U2(58))+HESS(452)*(U1(78)*U2(80))+HESS(454)*(U1(79)*U2(45))+HESS(455)*(U1(79)*U2(46))& + &+HESS(467)*(U1(80)*U2(80))+HESS(470)*(U1(81)*U2(33))+HESS(471)*(U1(81)*U2(68))+HESS(478)*(U1(82)*U2(24))& + &+HESS(479)*(U1(82)*U2(29))+HESS(480)*(U1(82)*U2(43))+HESS(481)*(U1(82)*U2(44))+HESS(517)*(U1(82)*U2(82))& + &+HESS(523)*(U1(82)*U2(87))+HESS(532)*(U1(83)*U2(16))+HESS(533)*(U1(83)*U2(17))+HESS(534)*(U1(83)*U2(20))& + &+HESS(535)*(U1(83)*U2(22))+HESS(536)*(U1(83)*U2(23))+HESS(537)*(U1(83)*U2(24))+HESS(538)*(U1(83)*U2(26))& + &+HESS(539)*(U1(83)*U2(27))+HESS(540)*(U1(83)*U2(28))+HESS(541)*(U1(83)*U2(29))+HESS(542)*(U1(83)*U2(30))& + &+HESS(543)*(U1(83)*U2(31))+HESS(544)*(U1(83)*U2(32))+HESS(545)*(U1(83)*U2(33))+HESS(546)*(U1(83)*U2(34))& + &+HESS(547)*(U1(83)*U2(35))+HESS(548)*(U1(83)*U2(36))+HESS(549)*(U1(83)*U2(37))+HESS(550)*(U1(83)*U2(38))& + &+HESS(551)*(U1(83)*U2(39))+HESS(552)*(U1(83)*U2(40))+HESS(553)*(U1(83)*U2(41))+HESS(554)*(U1(83)*U2(42))& + &+HESS(555)*(U1(83)*U2(43))+HESS(556)*(U1(83)*U2(44))+HESS(557)*(U1(83)*U2(45))+HESS(558)*(U1(83)*U2(46))& + &+HESS(560)*(U1(83)*U2(47))+HESS(561)*(U1(83)*U2(48))+HESS(563)*(U1(83)*U2(49))+HESS(564)*(U1(83)*U2(50))& + &+HESS(565)*(U1(83)*U2(56))+HESS(566)*(U1(83)*U2(58))+HESS(568)*(U1(83)*U2(61))+HESS(569)*(U1(83)*U2(68))& + &+HESS(570)*(U1(83)*U2(69))+HESS(571)*(U1(83)*U2(71))+HESS(572)*(U1(83)*U2(73))+HESS(573)*(U1(83)*U2(75))& + &+HESS(574)*(U1(83)*U2(76))+HESS(575)*(U1(83)*U2(77))+HESS(577)*(U1(83)*U2(80))+HESS(579)*(U1(83)*U2(82)) + HTU(83) = HTU(83)& + &+HESS(580)*(U1(83)*U2(83))+HESS(581)*(U1(83)*U2(84))+HESS(582)*(U1(83)*U2(85))+HESS(583)*(U1(83)*U2(87))& + &+HESS(584)*(U1(83)*U2(89))+HESS(589)*(U1(84)*U2(17))+HESS(590)*(U1(84)*U2(20))+HESS(591)*(U1(84)*U2(44))& + &+HESS(594)*(U1(84)*U2(47))+HESS(596)*(U1(84)*U2(50))+HESS(617)*(U1(84)*U2(58))+HESS(624)*(U1(84)*U2(61))& + &+HESS(645)*(U1(84)*U2(69))+HESS(651)*(U1(84)*U2(71))+HESS(672)*(U1(84)*U2(84))+HESS(673)*(U1(84)*U2(87))& + &+HESS(674)*(U1(84)*U2(89))+HESS(710)*(U1(85)*U2(85))+HESS(717)*(U1(86)*U2(27))+HESS(742)*(U1(86)*U2(71))& + &+HESS(746)*(U1(86)*U2(75))+HESS(763)*(U1(87)*U2(56))+HESS(772)*(U1(87)*U2(87))+HESS(776)*(U1(88)*U2(36))& + &+HESS(777)*(U1(88)*U2(50))+HESS(792)*(U1(89)*U2(83))+HESS(793)*(U1(89)*U2(89))+HESS(799)*(U1(90)*U2(28))& + &+HESS(800)*(U1(90)*U2(34)) + HTU(84) = HESS(11)*(U1(17)*U2(84))+HESS(26)*(U1(26)*U2(78))+HESS(28)*(U1(27)*U2(86))+HESS(30)*(U1(28)*U2(90))+HESS(32)& + &*(U1(29)*U2(82))+HESS(34)*(U1(30)*U2(72))+HESS(36)*(U1(31)*U2(52))+HESS(38)*(U1(32)*U2(53))+HESS(40)*(U1(33)& + &*U2(81))+HESS(44)*(U1(35)*U2(74))+HESS(46)*(U1(36)*U2(88))+HESS(48)*(U1(37)*U2(70))+HESS(50)*(U1(38)*U2(63))& + &+HESS(52)*(U1(39)*U2(67))+HESS(54)*(U1(40)*U2(59))+HESS(56)*(U1(41)*U2(66))+HESS(58)*(U1(42)*U2(64))+HESS(60)& + &*(U1(43)*U2(51))+HESS(61)*(U1(43)*U2(55))+HESS(62)*(U1(43)*U2(65))+HESS(67)*(U1(45)*U2(57))+HESS(68)*(U1(45)& + &*U2(79))+HESS(113)*(U1(51)*U2(51))+HESS(119)*(U1(52)*U2(52))+HESS(128)*(U1(53)*U2(53))+HESS(135)*(U1(54)& + &*U2(54))+HESS(140)*(U1(55)*U2(55))+HESS(166)*(U1(57)*U2(57))+HESS(182)*(U1(59)*U2(59))+HESS(187)*(U1(60)& + &*U2(60))+HESS(209)*(U1(62)*U2(62))+HESS(215)*(U1(63)*U2(63))+HESS(220)*(U1(64)*U2(64))+HESS(226)*(U1(65)& + &*U2(65))+HESS(232)*(U1(66)*U2(66))+HESS(238)*(U1(67)*U2(67))+HESS(329)*(U1(69)*U2(88))+HESS(339)*(U1(70)& + &*U2(70))+HESS(374)*(U1(72)*U2(72))+HESS(378)*(U1(73)*U2(54))+HESS(390)*(U1(74)*U2(74))+HESS(405)*(U1(75)& + &*U2(60))+HESS(448)*(U1(78)*U2(78))+HESS(456)*(U1(79)*U2(79))+HESS(474)*(U1(81)*U2(81))+HESS(518)*(U1(82)& + &*U2(82))+HESS(524)*(U1(82)*U2(85))+HESS(525)*(U1(82)*U2(87))+HESS(581)*(U1(83)*U2(83))+HESS(585)*(U1(83)& + &*U2(85))+HESS(586)*(U1(83)*U2(86))+HESS(587)*(U1(83)*U2(87))+HESS(588)*(U1(83)*U2(89))+HESS(597)*(U1(84)& + &*U2(51))+HESS(601)*(U1(84)*U2(52))+HESS(605)*(U1(84)*U2(53))+HESS(609)*(U1(84)*U2(54))+HESS(611)*(U1(84)& + &*U2(55))+HESS(613)*(U1(84)*U2(57))+HESS(618)*(U1(84)*U2(59))+HESS(622)*(U1(84)*U2(60))+HESS(625)*(U1(84)& + &*U2(62))+HESS(628)*(U1(84)*U2(63))+HESS(630)*(U1(84)*U2(64))+HESS(634)*(U1(84)*U2(65))+HESS(637)*(U1(84)& + &*U2(66))+HESS(641)*(U1(84)*U2(67))+HESS(647)*(U1(84)*U2(70))+HESS(652)*(U1(84)*U2(72))+HESS(657)*(U1(84)& + &*U2(74))+HESS(662)*(U1(84)*U2(78))+HESS(664)*(U1(84)*U2(79))+HESS(669)*(U1(84)*U2(81))+HESS(671)*(U1(84)& + &*U2(82))+HESS(672)*(U1(84)*U2(83))+HESS(675)*(U1(84)*U2(84))+HESS(676)*(U1(84)*U2(85))+HESS(677)*(U1(84)& + &*U2(86))+HESS(678)*(U1(84)*U2(87))+HESS(679)*(U1(84)*U2(88))+HESS(680)*(U1(84)*U2(89))+HESS(681)*(U1(84)& + &*U2(90))+HESS(711)*(U1(85)*U2(85))+HESS(730)*(U1(86)*U2(62))+HESS(753)*(U1(86)*U2(86))+HESS(773)*(U1(87)& + &*U2(87))+HESS(779)*(U1(88)*U2(88))+HESS(788)*(U1(89)*U2(78))+HESS(790)*(U1(89)*U2(81))+HESS(794)*(U1(89)& + &*U2(86))+HESS(795)*(U1(89)*U2(88))+HESS(796)*(U1(89)*U2(89))+HESS(817)*(U1(90)*U2(60))+HESS(820)*(U1(90)& + &*U2(62))+HESS(846)*(U1(90)*U2(86))+HESS(847)*(U1(90)*U2(90)) + HTU(85) = HESS(6)*(U1(13)*U2(86))+HESS(23)*(U1(24)*U2(83))+HESS(79)*(U1(47)*U2(66))+HESS(95)*(U1(49)*U2(53))+HESS(98)& + &*(U1(49)*U2(72))+HESS(102)*(U1(50)*U2(51))+HESS(104)*(U1(50)*U2(64))+HESS(107)*(U1(50)*U2(65))+HESS(110)& + &*(U1(50)*U2(66))+HESS(114)*(U1(51)*U2(51))+HESS(120)*(U1(52)*U2(52))+HESS(123)*(U1(52)*U2(72))+HESS(129)& + &*(U1(53)*U2(53))+HESS(132)*(U1(53)*U2(72))+HESS(136)*(U1(54)*U2(54))+HESS(141)*(U1(55)*U2(55))+HESS(148)& + &*(U1(56)*U2(51))+HESS(150)*(U1(56)*U2(57))+HESS(151)*(U1(56)*U2(59))+HESS(152)*(U1(56)*U2(64))+HESS(153)& + &*(U1(56)*U2(65))+HESS(154)*(U1(56)*U2(66))+HESS(155)*(U1(56)*U2(67))+HESS(163)*(U1(56)*U2(79))+HESS(167)& + &*(U1(57)*U2(57))+HESS(173)*(U1(58)*U2(57))+HESS(178)*(U1(58)*U2(79))+HESS(183)*(U1(59)*U2(59))+HESS(188)& + &*(U1(60)*U2(60))+HESS(195)*(U1(61)*U2(59))+HESS(200)*(U1(61)*U2(65))+HESS(203)*(U1(61)*U2(66))+HESS(210)& + &*(U1(62)*U2(62))+HESS(216)*(U1(63)*U2(63))+HESS(221)*(U1(64)*U2(64))+HESS(227)*(U1(65)*U2(65))+HESS(233)& + &*(U1(66)*U2(66))+HESS(239)*(U1(67)*U2(67))+HESS(248)*(U1(68)*U2(52))+HESS(251)*(U1(68)*U2(54))+HESS(266)& + &*(U1(68)*U2(72))+HESS(277)*(U1(69)*U2(51))+HESS(282)*(U1(69)*U2(54))+HESS(285)*(U1(69)*U2(55))+HESS(288)& + &*(U1(69)*U2(57))+HESS(292)*(U1(69)*U2(59))+HESS(296)*(U1(69)*U2(62))+HESS(299)*(U1(69)*U2(63))+HESS(302)& + &*(U1(69)*U2(64))+HESS(306)*(U1(69)*U2(66))+HESS(309)*(U1(69)*U2(67))+HESS(314)*(U1(69)*U2(70))+HESS(321)& + &*(U1(69)*U2(78))+HESS(324)*(U1(69)*U2(79))+HESS(330)*(U1(69)*U2(88))+HESS(331)*(U1(69)*U2(90))+HESS(340)& + &*(U1(70)*U2(70))+HESS(346)*(U1(71)*U2(54))+HESS(349)*(U1(71)*U2(60))+HESS(352)*(U1(71)*U2(63))+HESS(355)& + &*(U1(71)*U2(70))+HESS(360)*(U1(71)*U2(72))+HESS(364)*(U1(71)*U2(74))+HESS(371)*(U1(72)*U2(54))+HESS(375)& + &*(U1(72)*U2(72))+HESS(379)*(U1(73)*U2(60))+HESS(380)*(U1(73)*U2(62))+HESS(381)*(U1(73)*U2(72))+HESS(386)& + &*(U1(74)*U2(72))+HESS(391)*(U1(74)*U2(74))+HESS(394)*(U1(74)*U2(81))+HESS(397)*(U1(75)*U2(51))+HESS(400)& + &*(U1(75)*U2(55))+HESS(409)*(U1(75)*U2(64))+HESS(412)*(U1(75)*U2(66))+HESS(429)*(U1(76)*U2(72))+HESS(437)& + &*(U1(77)*U2(67))+HESS(442)*(U1(77)*U2(79))+HESS(449)*(U1(78)*U2(78))+HESS(457)*(U1(79)*U2(79))+HESS(461)& + &*(U1(80)*U2(67))+HESS(464)*(U1(80)*U2(79))+HESS(475)*(U1(81)*U2(81))+HESS(483)*(U1(82)*U2(51))+HESS(486)& + &*(U1(82)*U2(52))+HESS(487)*(U1(82)*U2(53))+HESS(488)*(U1(82)*U2(54))+HESS(491)*(U1(82)*U2(55))+HESS(494)& + &*(U1(82)*U2(57))+HESS(495)*(U1(82)*U2(59))+HESS(496)*(U1(82)*U2(60))+HESS(497)*(U1(82)*U2(62))+HESS(498)& + &*(U1(82)*U2(63))+HESS(501)*(U1(82)*U2(64))+HESS(502)*(U1(82)*U2(65))+HESS(505)*(U1(82)*U2(66))+HESS(506)& + &*(U1(82)*U2(67))+HESS(509)*(U1(82)*U2(70))+HESS(510)*(U1(82)*U2(72))+HESS(511)*(U1(82)*U2(74))+HESS(513)& + &*(U1(82)*U2(78))+HESS(514)*(U1(82)*U2(79))+HESS(516)*(U1(82)*U2(81))+HESS(524)*(U1(82)*U2(84))+HESS(526)& + &*(U1(82)*U2(86))+HESS(527)*(U1(82)*U2(87))+HESS(528)*(U1(82)*U2(88))+HESS(529)*(U1(82)*U2(89))+HESS(530)& + &*(U1(82)*U2(90))+HESS(582)*(U1(83)*U2(83))+HESS(585)*(U1(83)*U2(84))+HESS(598)*(U1(84)*U2(51))+HESS(602)& + &*(U1(84)*U2(52))+HESS(606)*(U1(84)*U2(53))+HESS(614)*(U1(84)*U2(57))+HESS(619)*(U1(84)*U2(59))+HESS(631)& + &*(U1(84)*U2(64))+HESS(635)*(U1(84)*U2(65))+HESS(638)*(U1(84)*U2(66))+HESS(642)*(U1(84)*U2(67))+HESS(648)& + &*(U1(84)*U2(70))+HESS(653)*(U1(84)*U2(72))+HESS(658)*(U1(84)*U2(74))+HESS(665)*(U1(84)*U2(79))+HESS(676)& + &*(U1(84)*U2(84))+HESS(682)*(U1(84)*U2(88))+HESS(683)*(U1(84)*U2(90))+HESS(689)*(U1(85)*U2(51))+HESS(690)& + &*(U1(85)*U2(52))+HESS(691)*(U1(85)*U2(53))+HESS(692)*(U1(85)*U2(54))+HESS(693)*(U1(85)*U2(55))+HESS(694)& + &*(U1(85)*U2(57))+HESS(695)*(U1(85)*U2(59))+HESS(696)*(U1(85)*U2(60))+HESS(697)*(U1(85)*U2(62))+HESS(698)& + &*(U1(85)*U2(63))+HESS(699)*(U1(85)*U2(64))+HESS(700)*(U1(85)*U2(65))+HESS(701)*(U1(85)*U2(66))+HESS(702)& + &*(U1(85)*U2(67))+HESS(703)*(U1(85)*U2(70))+HESS(704)*(U1(85)*U2(72))+HESS(705)*(U1(85)*U2(74)) + HTU(85) = HTU(85)& + &+HESS(706)*(U1(85)*U2(78))+HESS(707)*(U1(85)*U2(79))+HESS(708)*(U1(85)*U2(81))+HESS(710)*(U1(85)*U2(83))& + &+HESS(711)*(U1(85)*U2(84))+HESS(712)*(U1(85)*U2(86))+HESS(713)*(U1(85)*U2(87))+HESS(714)*(U1(85)*U2(88))& + &+HESS(715)*(U1(85)*U2(89))+HESS(716)*(U1(85)*U2(90))+HESS(718)*(U1(86)*U2(51))+HESS(727)*(U1(86)*U2(60))& + &+HESS(731)*(U1(86)*U2(62))+HESS(735)*(U1(86)*U2(64))+HESS(748)*(U1(86)*U2(78))+HESS(754)*(U1(86)*U2(86))& + &+HESS(774)*(U1(87)*U2(87))+HESS(780)*(U1(88)*U2(88))+HESS(797)*(U1(89)*U2(89))+HESS(835)*(U1(90)*U2(72))& + &+HESS(848)*(U1(90)*U2(86))+HESS(849)*(U1(90)*U2(90)) + HTU(86) = HESS(6)*(U1(13)*U2(85))+HESS(17)*(U1(21)*U2(82))+HESS(28)*(U1(27)*U2(84))+HESS(77)*(U1(47)*U2(59))+HESS(80)& + &*(U1(47)*U2(66))+HESS(96)*(U1(49)*U2(53))+HESS(99)*(U1(49)*U2(72))+HESS(105)*(U1(50)*U2(64))+HESS(108)& + &*(U1(50)*U2(65))+HESS(111)*(U1(50)*U2(66))+HESS(115)*(U1(51)*U2(51))+HESS(121)*(U1(52)*U2(52))+HESS(124)& + &*(U1(52)*U2(72))+HESS(130)*(U1(53)*U2(53))+HESS(133)*(U1(53)*U2(72))+HESS(137)*(U1(54)*U2(54))+HESS(142)& + &*(U1(55)*U2(55))+HESS(156)*(U1(56)*U2(67))+HESS(168)*(U1(57)*U2(57))+HESS(170)*(U1(57)*U2(79))+HESS(174)& + &*(U1(58)*U2(57))+HESS(179)*(U1(58)*U2(79))+HESS(184)*(U1(59)*U2(59))+HESS(189)*(U1(60)*U2(60))+HESS(196)& + &*(U1(61)*U2(59))+HESS(201)*(U1(61)*U2(65))+HESS(204)*(U1(61)*U2(66))+HESS(206)*(U1(61)*U2(70))+HESS(211)& + &*(U1(62)*U2(62))+HESS(217)*(U1(63)*U2(63))+HESS(222)*(U1(64)*U2(64))+HESS(228)*(U1(65)*U2(65))+HESS(234)& + &*(U1(66)*U2(66))+HESS(240)*(U1(67)*U2(67))+HESS(246)*(U1(68)*U2(51))+HESS(249)*(U1(68)*U2(52))+HESS(252)& + &*(U1(68)*U2(54))+HESS(254)*(U1(68)*U2(55))+HESS(256)*(U1(68)*U2(63))+HESS(258)*(U1(68)*U2(65))+HESS(260)& + &*(U1(68)*U2(67))+HESS(264)*(U1(68)*U2(70))+HESS(267)*(U1(68)*U2(72))+HESS(278)*(U1(69)*U2(51))+HESS(283)& + &*(U1(69)*U2(54))+HESS(286)*(U1(69)*U2(55))+HESS(289)*(U1(69)*U2(57))+HESS(293)*(U1(69)*U2(59))+HESS(297)& + &*(U1(69)*U2(62))+HESS(300)*(U1(69)*U2(63))+HESS(303)*(U1(69)*U2(64))+HESS(307)*(U1(69)*U2(66))+HESS(310)& + &*(U1(69)*U2(67))+HESS(315)*(U1(69)*U2(70))+HESS(322)*(U1(69)*U2(78))+HESS(325)*(U1(69)*U2(79))+HESS(332)& + &*(U1(69)*U2(88))+HESS(333)*(U1(69)*U2(90))+HESS(341)*(U1(70)*U2(70))+HESS(347)*(U1(71)*U2(54))+HESS(350)& + &*(U1(71)*U2(60))+HESS(353)*(U1(71)*U2(63))+HESS(356)*(U1(71)*U2(70))+HESS(361)*(U1(71)*U2(72))+HESS(365)& + &*(U1(71)*U2(74))+HESS(372)*(U1(72)*U2(54))+HESS(376)*(U1(72)*U2(72))+HESS(387)*(U1(74)*U2(72))+HESS(392)& + &*(U1(74)*U2(74))+HESS(395)*(U1(74)*U2(81))+HESS(398)*(U1(75)*U2(51))+HESS(401)*(U1(75)*U2(55))+HESS(404)& + &*(U1(75)*U2(59))+HESS(407)*(U1(75)*U2(62))+HESS(410)*(U1(75)*U2(64))+HESS(413)*(U1(75)*U2(66))+HESS(419)& + &*(U1(76)*U2(57))+HESS(421)*(U1(76)*U2(59))+HESS(422)*(U1(76)*U2(60))+HESS(424)*(U1(76)*U2(62))+HESS(425)& + &*(U1(76)*U2(64))+HESS(427)*(U1(76)*U2(66))+HESS(430)*(U1(76)*U2(72))+HESS(434)*(U1(76)*U2(79))+HESS(438)& + &*(U1(77)*U2(67))+HESS(443)*(U1(77)*U2(79))+HESS(450)*(U1(78)*U2(78))+HESS(458)*(U1(79)*U2(79))+HESS(462)& + &*(U1(80)*U2(67))+HESS(465)*(U1(80)*U2(79))+HESS(476)*(U1(81)*U2(81))+HESS(484)*(U1(82)*U2(51))+HESS(489)& + &*(U1(82)*U2(54))+HESS(492)*(U1(82)*U2(55))+HESS(499)*(U1(82)*U2(63))+HESS(503)*(U1(82)*U2(65))+HESS(507)& + &*(U1(82)*U2(67))+HESS(519)*(U1(82)*U2(82))+HESS(526)*(U1(82)*U2(85))+HESS(586)*(U1(83)*U2(84))+HESS(599)& + &*(U1(84)*U2(51))+HESS(603)*(U1(84)*U2(52))+HESS(607)*(U1(84)*U2(53))+HESS(615)*(U1(84)*U2(57))+HESS(620)& + &*(U1(84)*U2(59))+HESS(626)*(U1(84)*U2(62))+HESS(632)*(U1(84)*U2(64))+HESS(639)*(U1(84)*U2(66))+HESS(643)& + &*(U1(84)*U2(67))+HESS(649)*(U1(84)*U2(70))+HESS(654)*(U1(84)*U2(72))+HESS(659)*(U1(84)*U2(74))+HESS(666)& + &*(U1(84)*U2(79))+HESS(677)*(U1(84)*U2(84))+HESS(684)*(U1(84)*U2(88))+HESS(685)*(U1(84)*U2(90))+HESS(712)& + &*(U1(85)*U2(85))+HESS(719)*(U1(86)*U2(51))+HESS(721)*(U1(86)*U2(52))+HESS(722)*(U1(86)*U2(53))+HESS(723)& + &*(U1(86)*U2(54))+HESS(724)*(U1(86)*U2(55))+HESS(725)*(U1(86)*U2(57))+HESS(726)*(U1(86)*U2(59))+HESS(728)& + &*(U1(86)*U2(60))+HESS(732)*(U1(86)*U2(62))+HESS(734)*(U1(86)*U2(63))+HESS(736)*(U1(86)*U2(64))+HESS(738)& + &*(U1(86)*U2(65))+HESS(739)*(U1(86)*U2(66))+HESS(740)*(U1(86)*U2(67))+HESS(741)*(U1(86)*U2(70))+HESS(744)& + &*(U1(86)*U2(72))+HESS(745)*(U1(86)*U2(74))+HESS(750)*(U1(86)*U2(79))+HESS(751)*(U1(86)*U2(81))+HESS(752)& + &*(U1(86)*U2(82))+HESS(753)*(U1(86)*U2(84))+HESS(754)*(U1(86)*U2(85))+HESS(755)*(U1(86)*U2(86))+HESS(756)& + &*(U1(86)*U2(88))+HESS(757)*(U1(86)*U2(90))+HESS(781)*(U1(88)*U2(88))+HESS(794)*(U1(89)*U2(84)) + HTU(86) = HTU(86)& + &+HESS(803)*(U1(90)*U2(51))+HESS(805)*(U1(90)*U2(52))+HESS(807)*(U1(90)*U2(53))+HESS(809)*(U1(90)*U2(54))& + &+HESS(811)*(U1(90)*U2(55))+HESS(813)*(U1(90)*U2(57))+HESS(815)*(U1(90)*U2(59))+HESS(818)*(U1(90)*U2(60))& + &+HESS(821)*(U1(90)*U2(62))+HESS(823)*(U1(90)*U2(63))+HESS(825)*(U1(90)*U2(64))+HESS(827)*(U1(90)*U2(65))& + &+HESS(829)*(U1(90)*U2(66))+HESS(831)*(U1(90)*U2(67))+HESS(833)*(U1(90)*U2(70))+HESS(836)*(U1(90)*U2(72))& + &+HESS(838)*(U1(90)*U2(74))+HESS(840)*(U1(90)*U2(78))+HESS(842)*(U1(90)*U2(79))+HESS(844)*(U1(90)*U2(81))& + &+HESS(846)*(U1(90)*U2(84))+HESS(848)*(U1(90)*U2(85))+HESS(850)*(U1(90)*U2(86))+HESS(851)*(U1(90)*U2(88))& + &+HESS(852)*(U1(90)*U2(90)) + HTU(87) = HESS(16)*(U1(20)*U2(34))+HESS(19)*(U1(22)*U2(22))+HESS(21)*(U1(23)*U2(23))+HESS(24)*(U1(25)*U2(82))+HESS(42)& + &*(U1(34)*U2(34))+HESS(70)*(U1(46)*U2(46))+HESS(83)*(U1(47)*U2(69))+HESS(86)*(U1(47)*U2(75))+HESS(91)*(U1(48)& + &*U2(48))+HESS(144)*(U1(55)*U2(80))+HESS(145)*(U1(56)*U2(22))+HESS(146)*(U1(56)*U2(23))+HESS(147)*(U1(56)& + &*U2(34))+HESS(158)*(U1(56)*U2(68))+HESS(159)*(U1(56)*U2(69))+HESS(160)*(U1(56)*U2(71))+HESS(161)*(U1(56)& + &*U2(75))+HESS(162)*(U1(56)*U2(76))+HESS(164)*(U1(56)*U2(80))+HESS(192)*(U1(60)*U2(76))+HESS(214)*(U1(63)& + &*U2(48))+HESS(237)*(U1(67)*U2(46))+HESS(263)*(U1(68)*U2(68))+HESS(272)*(U1(69)*U2(34))+HESS(313)*(U1(69)& + &*U2(69))+HESS(359)*(U1(71)*U2(71))+HESS(369)*(U1(72)*U2(22))+HESS(384)*(U1(74)*U2(23))+HESS(416)*(U1(75)& + &*U2(75))+HESS(433)*(U1(76)*U2(76))+HESS(453)*(U1(78)*U2(80))+HESS(468)*(U1(80)*U2(80))+HESS(472)*(U1(81)& + &*U2(68))+HESS(520)*(U1(82)*U2(82))+HESS(523)*(U1(82)*U2(83))+HESS(525)*(U1(82)*U2(84))+HESS(527)*(U1(82)& + &*U2(85))+HESS(531)*(U1(82)*U2(87))+HESS(583)*(U1(83)*U2(83))+HESS(587)*(U1(83)*U2(84))+HESS(646)*(U1(84)& + &*U2(69))+HESS(673)*(U1(84)*U2(83))+HESS(678)*(U1(84)*U2(84))+HESS(709)*(U1(85)*U2(82))+HESS(713)*(U1(85)& + &*U2(85))+HESS(743)*(U1(86)*U2(71))+HESS(747)*(U1(86)*U2(75))+HESS(758)*(U1(87)*U2(22))+HESS(759)*(U1(87)& + &*U2(23))+HESS(760)*(U1(87)*U2(34))+HESS(761)*(U1(87)*U2(46))+HESS(762)*(U1(87)*U2(48))+HESS(764)*(U1(87)& + &*U2(68))+HESS(765)*(U1(87)*U2(69))+HESS(766)*(U1(87)*U2(71))+HESS(767)*(U1(87)*U2(75))+HESS(768)*(U1(87)& + &*U2(76))+HESS(769)*(U1(87)*U2(80))+HESS(770)*(U1(87)*U2(82))+HESS(772)*(U1(87)*U2(83))+HESS(773)*(U1(87)& + &*U2(84))+HESS(774)*(U1(87)*U2(85))+HESS(775)*(U1(87)*U2(87))+HESS(801)*(U1(90)*U2(34)) + HTU(88) = HESS(13)*(U1(19)*U2(82))+HESS(46)*(U1(36)*U2(84))+HESS(329)*(U1(69)*U2(84))+HESS(330)*(U1(69)*U2(85))& + &+HESS(332)*(U1(69)*U2(86))+HESS(334)*(U1(69)*U2(90))+HESS(521)*(U1(82)*U2(82))+HESS(528)*(U1(82)*U2(85))& + &+HESS(679)*(U1(84)*U2(84))+HESS(682)*(U1(84)*U2(85))+HESS(684)*(U1(84)*U2(86))+HESS(686)*(U1(84)*U2(90))& + &+HESS(714)*(U1(85)*U2(85))+HESS(756)*(U1(86)*U2(86))+HESS(778)*(U1(88)*U2(82))+HESS(779)*(U1(88)*U2(84))& + &+HESS(780)*(U1(88)*U2(85))+HESS(781)*(U1(88)*U2(86))+HESS(782)*(U1(88)*U2(90))+HESS(795)*(U1(89)*U2(84))& + &+HESS(851)*(U1(90)*U2(86))+HESS(853)*(U1(90)*U2(90)) + HTU(89) = HESS(3)*(U1(13)*U2(46))+HESS(5)*(U1(13)*U2(80))+HESS(64)*(U1(44)*U2(44))+HESS(71)*(U1(46)*U2(46))+HESS(72)& + &*(U1(47)*U2(46))+HESS(74)*(U1(47)*U2(48))+HESS(76)*(U1(47)*U2(58))+HESS(87)*(U1(47)*U2(77))+HESS(88)*(U1(47)& + &*U2(80))+HESS(89)*(U1(48)*U2(46))+HESS(92)*(U1(48)*U2(48))+HESS(103)*(U1(50)*U2(58))+HESS(177)*(U1(58)& + &*U2(58))+HESS(194)*(U1(61)*U2(58))+HESS(274)*(U1(69)*U2(44))+HESS(275)*(U1(69)*U2(46))+HESS(276)*(U1(69)& + &*U2(48))+HESS(291)*(U1(69)*U2(58))+HESS(320)*(U1(69)*U2(77))+HESS(327)*(U1(69)*U2(80))+HESS(335)*(U1(69)& + &*U2(90))+HESS(345)*(U1(71)*U2(48))+HESS(367)*(U1(71)*U2(77))+HESS(403)*(U1(75)*U2(58))+HESS(417)*(U1(75)& + &*U2(77))+HESS(418)*(U1(75)*U2(80))+HESS(436)*(U1(77)*U2(46))+HESS(441)*(U1(77)*U2(77))+HESS(460)*(U1(80)& + &*U2(46))+HESS(469)*(U1(80)*U2(80))+HESS(482)*(U1(82)*U2(44))+HESS(522)*(U1(82)*U2(82))+HESS(529)*(U1(82)& + &*U2(85))+HESS(559)*(U1(83)*U2(46))+HESS(562)*(U1(83)*U2(48))+HESS(567)*(U1(83)*U2(58))+HESS(576)*(U1(83)& + &*U2(77))+HESS(578)*(U1(83)*U2(80))+HESS(584)*(U1(83)*U2(83))+HESS(588)*(U1(83)*U2(84))+HESS(592)*(U1(84)& + &*U2(44))+HESS(593)*(U1(84)*U2(46))+HESS(595)*(U1(84)*U2(48))+HESS(661)*(U1(84)*U2(77))+HESS(668)*(U1(84)& + &*U2(80))+HESS(674)*(U1(84)*U2(83))+HESS(680)*(U1(84)*U2(84))+HESS(687)*(U1(84)*U2(90))+HESS(715)*(U1(85)& + &*U2(85))+HESS(771)*(U1(87)*U2(82))+HESS(783)*(U1(89)*U2(44))+HESS(784)*(U1(89)*U2(46))+HESS(785)*(U1(89)& + &*U2(48))+HESS(786)*(U1(89)*U2(58))+HESS(787)*(U1(89)*U2(77))+HESS(789)*(U1(89)*U2(80))+HESS(791)*(U1(89)& + &*U2(82))+HESS(793)*(U1(89)*U2(83))+HESS(796)*(U1(89)*U2(84))+HESS(797)*(U1(89)*U2(85))+HESS(798)*(U1(89)& + &*U2(90))+HESS(802)*(U1(90)*U2(48))+HESS(854)*(U1(90)*U2(90)) + HTU(90) = HESS(30)*(U1(28)*U2(84))+HESS(78)*(U1(47)*U2(59))+HESS(81)*(U1(47)*U2(66))+HESS(97)*(U1(49)*U2(53))& + &+HESS(100)*(U1(49)*U2(72))+HESS(106)*(U1(50)*U2(64))+HESS(109)*(U1(50)*U2(65))+HESS(112)*(U1(50)*U2(66))& + &+HESS(116)*(U1(51)*U2(51))+HESS(122)*(U1(52)*U2(52))+HESS(125)*(U1(52)*U2(72))+HESS(131)*(U1(53)*U2(53))& + &+HESS(134)*(U1(53)*U2(72))+HESS(138)*(U1(54)*U2(54))+HESS(143)*(U1(55)*U2(55))+HESS(157)*(U1(56)*U2(67))& + &+HESS(169)*(U1(57)*U2(57))+HESS(171)*(U1(57)*U2(79))+HESS(175)*(U1(58)*U2(57))+HESS(180)*(U1(58)*U2(79))& + &+HESS(185)*(U1(59)*U2(59))+HESS(190)*(U1(60)*U2(60))+HESS(197)*(U1(61)*U2(59))+HESS(199)*(U1(61)*U2(62))& + &+HESS(202)*(U1(61)*U2(65))+HESS(205)*(U1(61)*U2(66))+HESS(207)*(U1(61)*U2(70))+HESS(212)*(U1(62)*U2(62))& + &+HESS(218)*(U1(63)*U2(63))+HESS(223)*(U1(64)*U2(64))+HESS(229)*(U1(65)*U2(65))+HESS(235)*(U1(66)*U2(66))& + &+HESS(241)*(U1(67)*U2(67))+HESS(247)*(U1(68)*U2(51))+HESS(250)*(U1(68)*U2(52))+HESS(253)*(U1(68)*U2(54))& + &+HESS(255)*(U1(68)*U2(55))+HESS(257)*(U1(68)*U2(63))+HESS(259)*(U1(68)*U2(65))+HESS(261)*(U1(68)*U2(67))& + &+HESS(265)*(U1(68)*U2(70))+HESS(268)*(U1(68)*U2(72))+HESS(279)*(U1(69)*U2(51))+HESS(280)*(U1(69)*U2(52))& + &+HESS(281)*(U1(69)*U2(53))+HESS(284)*(U1(69)*U2(54))+HESS(287)*(U1(69)*U2(55))+HESS(290)*(U1(69)*U2(57))& + &+HESS(294)*(U1(69)*U2(59))+HESS(295)*(U1(69)*U2(60))+HESS(298)*(U1(69)*U2(62))+HESS(301)*(U1(69)*U2(63))& + &+HESS(304)*(U1(69)*U2(64))+HESS(305)*(U1(69)*U2(65))+HESS(308)*(U1(69)*U2(66))+HESS(311)*(U1(69)*U2(67))& + &+HESS(316)*(U1(69)*U2(70))+HESS(318)*(U1(69)*U2(72))+HESS(319)*(U1(69)*U2(74))+HESS(323)*(U1(69)*U2(78))& + &+HESS(326)*(U1(69)*U2(79))+HESS(328)*(U1(69)*U2(81))+HESS(331)*(U1(69)*U2(85))+HESS(333)*(U1(69)*U2(86))& + &+HESS(334)*(U1(69)*U2(88))+HESS(335)*(U1(69)*U2(89))+HESS(336)*(U1(69)*U2(90))+HESS(342)*(U1(70)*U2(70))& + &+HESS(348)*(U1(71)*U2(54))+HESS(351)*(U1(71)*U2(60))+HESS(354)*(U1(71)*U2(63))+HESS(357)*(U1(71)*U2(70))& + &+HESS(362)*(U1(71)*U2(72))+HESS(366)*(U1(71)*U2(74))+HESS(373)*(U1(72)*U2(54))+HESS(377)*(U1(72)*U2(72))& + &+HESS(388)*(U1(74)*U2(72))+HESS(393)*(U1(74)*U2(74))+HESS(396)*(U1(74)*U2(81))+HESS(399)*(U1(75)*U2(51))& + &+HESS(402)*(U1(75)*U2(55))+HESS(408)*(U1(75)*U2(62))+HESS(411)*(U1(75)*U2(64))+HESS(414)*(U1(75)*U2(66))& + &+HESS(420)*(U1(76)*U2(57))+HESS(423)*(U1(76)*U2(60))+HESS(426)*(U1(76)*U2(64))+HESS(428)*(U1(76)*U2(66))& + &+HESS(431)*(U1(76)*U2(72))+HESS(435)*(U1(76)*U2(79))+HESS(439)*(U1(77)*U2(67))+HESS(444)*(U1(77)*U2(79))& + &+HESS(451)*(U1(78)*U2(78))+HESS(459)*(U1(79)*U2(79))+HESS(463)*(U1(80)*U2(67))+HESS(466)*(U1(80)*U2(79))& + &+HESS(477)*(U1(81)*U2(81))+HESS(485)*(U1(82)*U2(51))+HESS(490)*(U1(82)*U2(54))+HESS(493)*(U1(82)*U2(55))& + &+HESS(500)*(U1(82)*U2(63))+HESS(504)*(U1(82)*U2(65))+HESS(508)*(U1(82)*U2(67))+HESS(530)*(U1(82)*U2(85))& + &+HESS(600)*(U1(84)*U2(51))+HESS(604)*(U1(84)*U2(52))+HESS(608)*(U1(84)*U2(53))+HESS(610)*(U1(84)*U2(54))& + &+HESS(612)*(U1(84)*U2(55))+HESS(616)*(U1(84)*U2(57))+HESS(621)*(U1(84)*U2(59))+HESS(623)*(U1(84)*U2(60))& + &+HESS(627)*(U1(84)*U2(62))+HESS(629)*(U1(84)*U2(63))+HESS(633)*(U1(84)*U2(64))+HESS(636)*(U1(84)*U2(65))& + &+HESS(640)*(U1(84)*U2(66))+HESS(644)*(U1(84)*U2(67))+HESS(650)*(U1(84)*U2(70))+HESS(655)*(U1(84)*U2(72))& + &+HESS(660)*(U1(84)*U2(74))+HESS(663)*(U1(84)*U2(78))+HESS(667)*(U1(84)*U2(79))+HESS(670)*(U1(84)*U2(81))& + &+HESS(681)*(U1(84)*U2(84))+HESS(683)*(U1(84)*U2(85))+HESS(685)*(U1(84)*U2(86))+HESS(686)*(U1(84)*U2(88))& + &+HESS(687)*(U1(84)*U2(89))+HESS(688)*(U1(84)*U2(90))+HESS(716)*(U1(85)*U2(85))+HESS(720)*(U1(86)*U2(51))& + &+HESS(729)*(U1(86)*U2(60))+HESS(733)*(U1(86)*U2(62))+HESS(737)*(U1(86)*U2(64))+HESS(749)*(U1(86)*U2(78))& + &+HESS(757)*(U1(86)*U2(86))+HESS(782)*(U1(88)*U2(88))+HESS(798)*(U1(89)*U2(89))+HESS(804)*(U1(90)*U2(51))& + &+HESS(806)*(U1(90)*U2(52))+HESS(808)*(U1(90)*U2(53))+HESS(810)*(U1(90)*U2(54))+HESS(812)*(U1(90)*U2(55)) + HTU(90) = HTU(90)& + &+HESS(814)*(U1(90)*U2(57))+HESS(816)*(U1(90)*U2(59))+HESS(819)*(U1(90)*U2(60))+HESS(822)*(U1(90)*U2(62))& + &+HESS(824)*(U1(90)*U2(63))+HESS(826)*(U1(90)*U2(64))+HESS(828)*(U1(90)*U2(65))+HESS(830)*(U1(90)*U2(66))& + &+HESS(832)*(U1(90)*U2(67))+HESS(834)*(U1(90)*U2(70))+HESS(837)*(U1(90)*U2(72))+HESS(839)*(U1(90)*U2(74))& + &+HESS(841)*(U1(90)*U2(78))+HESS(843)*(U1(90)*U2(79))+HESS(845)*(U1(90)*U2(81))+HESS(847)*(U1(90)*U2(84))& + &+HESS(849)*(U1(90)*U2(85))+HESS(852)*(U1(90)*U2(86))+HESS(853)*(U1(90)*U2(88))+HESS(854)*(U1(90)*U2(89))& + &+HESS(855)*(U1(90)*U2(90)) + +END SUBROUTINE HessTR_Vec + +! End of HessTR_Vec function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Hess_Vec - Hessian times user vectors +! Arguments : +! HESS - Hessian of Var (i.e. the 3-tensor d Jac / d Var) +! U1 - User vector +! U2 - User vector +! HU - Hessian times user vectors: (Hess x U2) * U1 = [d (Jac*U1)/d Var] * U2 +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE Hess_Vec ( HESS, U1, U2, HU ) + +! HESS - Hessian of Var (i.e. the 3-tensor d Jac / d Var) + REAL(kind=dp) :: HESS(NHESS) +! U1 - User vector + REAL(kind=dp) :: U1(NVAR) +! U2 - User vector + REAL(kind=dp) :: U2(NVAR) +! HU - Hessian times user vectors: (Hess x U2) * U1 = [d (Jac*U1)/d Var] * U2 + REAL(kind=dp) :: HU(NVAR) + +! Compute the vector HU =(Hess x U2) * U1 = d (Jac*U1)/d Var * U2 + HU(1) = 0 + HU(2) = 0 + HU(3) = 0 + HU(4) = 0 + HU(5) = 0 + HU(6) = 0 + HU(7) = 0 + HU(8) = 0 + HU(9) = 0 + HU(10) = 0 + HU(11) = HESS(1)*(U1(20)*U2(83))+HESS(1)*(U1(83)*U2(20)) + HU(12) = HESS(2)*(U1(34)*U2(83))+HESS(2)*(U1(83)*U2(34)) + HU(13) = HESS(3)*(U1(46)*U2(89))+HESS(3)*(U1(89)*U2(46))+HESS(4)*(U1(47)*U2(83))+HESS(4)*(U1(83)*U2(47))+HESS(5)& + &*(U1(80)*U2(89))+HESS(5)*(U1(89)*U2(80))+HESS(6)*(U1(85)*U2(86))+HESS(6)*(U1(86)*U2(85)) + HU(14) = 0 + HU(15) = HESS(7)*(U1(46)*U2(83))+HESS(7)*(U1(83)*U2(46)) + HU(16) = HESS(8)*(U1(16)*U2(83))+HESS(8)*(U1(83)*U2(16)) + HU(17) = HESS(9)*(U1(17)*U2(83))+HESS(9)*(U1(83)*U2(17))+HESS(10)*(U1(83)*U2(83))+HESS(11)*(U1(84)*U2(84)) + HU(18) = HESS(12)*(U1(81)*U2(82))+HESS(12)*(U1(82)*U2(81)) + HU(19) = HESS(13)*(U1(82)*U2(88))+HESS(13)*(U1(88)*U2(82)) + HU(20) = HESS(14)*(U1(20)*U2(83))+HESS(14)*(U1(83)*U2(20))+HESS(15)*(U1(34)*U2(83))+HESS(15)*(U1(83)*U2(34))+HESS(16)& + &*(U1(34)*U2(87))+HESS(16)*(U1(87)*U2(34)) + HU(21) = HESS(17)*(U1(82)*U2(86))+HESS(17)*(U1(86)*U2(82)) + HU(22) = HESS(18)*(U1(22)*U2(83))+HESS(18)*(U1(83)*U2(22))+HESS(19)*(U1(22)*U2(87))+HESS(19)*(U1(87)*U2(22)) + HU(23) = HESS(20)*(U1(23)*U2(83))+HESS(20)*(U1(83)*U2(23))+HESS(21)*(U1(23)*U2(87))+HESS(21)*(U1(87)*U2(23)) + HU(24) = HESS(22)*(U1(24)*U2(83))+HESS(22)*(U1(83)*U2(24))+HESS(23)*(U1(83)*U2(85))+HESS(23)*(U1(85)*U2(83)) + HU(25) = HESS(24)*(U1(82)*U2(87))+HESS(24)*(U1(87)*U2(82)) + HU(26) = HESS(25)*(U1(26)*U2(83))+HESS(25)*(U1(83)*U2(26))+HESS(26)*(U1(78)*U2(84))+HESS(26)*(U1(84)*U2(78)) + HU(27) = HESS(27)*(U1(27)*U2(83))+HESS(27)*(U1(83)*U2(27))+HESS(28)*(U1(84)*U2(86))+HESS(28)*(U1(86)*U2(84)) + HU(28) = HESS(29)*(U1(28)*U2(83))+HESS(29)*(U1(83)*U2(28))+HESS(30)*(U1(84)*U2(90))+HESS(30)*(U1(90)*U2(84)) + HU(29) = HESS(31)*(U1(29)*U2(83))+HESS(31)*(U1(83)*U2(29))+HESS(32)*(U1(82)*U2(84))+HESS(32)*(U1(84)*U2(82)) + HU(30) = HESS(33)*(U1(30)*U2(83))+HESS(33)*(U1(83)*U2(30))+HESS(34)*(U1(72)*U2(84))+HESS(34)*(U1(84)*U2(72)) + HU(31) = HESS(35)*(U1(31)*U2(83))+HESS(35)*(U1(83)*U2(31))+HESS(36)*(U1(52)*U2(84))+HESS(36)*(U1(84)*U2(52)) + HU(32) = HESS(37)*(U1(32)*U2(83))+HESS(37)*(U1(83)*U2(32))+HESS(38)*(U1(53)*U2(84))+HESS(38)*(U1(84)*U2(53)) + HU(33) = HESS(39)*(U1(33)*U2(83))+HESS(39)*(U1(83)*U2(33))+HESS(40)*(U1(81)*U2(84))+HESS(40)*(U1(84)*U2(81)) + HU(34) = HESS(41)*(U1(34)*U2(83))+HESS(41)*(U1(83)*U2(34))+HESS(42)*(U1(34)*U2(87))+HESS(42)*(U1(87)*U2(34)) + HU(35) = HESS(43)*(U1(35)*U2(83))+HESS(43)*(U1(83)*U2(35))+HESS(44)*(U1(74)*U2(84))+HESS(44)*(U1(84)*U2(74)) + HU(36) = HESS(45)*(U1(36)*U2(83))+HESS(45)*(U1(83)*U2(36))+HESS(46)*(U1(84)*U2(88))+HESS(46)*(U1(88)*U2(84)) + HU(37) = HESS(47)*(U1(37)*U2(83))+HESS(47)*(U1(83)*U2(37))+HESS(48)*(U1(70)*U2(84))+HESS(48)*(U1(84)*U2(70)) + HU(38) = HESS(49)*(U1(38)*U2(83))+HESS(49)*(U1(83)*U2(38))+HESS(50)*(U1(63)*U2(84))+HESS(50)*(U1(84)*U2(63)) + HU(39) = HESS(51)*(U1(39)*U2(83))+HESS(51)*(U1(83)*U2(39))+HESS(52)*(U1(67)*U2(84))+HESS(52)*(U1(84)*U2(67)) + HU(40) = HESS(53)*(U1(40)*U2(83))+HESS(53)*(U1(83)*U2(40))+HESS(54)*(U1(59)*U2(84))+HESS(54)*(U1(84)*U2(59)) + HU(41) = HESS(55)*(U1(41)*U2(83))+HESS(55)*(U1(83)*U2(41))+HESS(56)*(U1(66)*U2(84))+HESS(56)*(U1(84)*U2(66)) + HU(42) = HESS(57)*(U1(42)*U2(83))+HESS(57)*(U1(83)*U2(42))+HESS(58)*(U1(64)*U2(84))+HESS(58)*(U1(84)*U2(64)) + HU(43) = HESS(59)*(U1(43)*U2(83))+HESS(59)*(U1(83)*U2(43))+HESS(60)*(U1(51)*U2(84))+HESS(60)*(U1(84)*U2(51))+HESS(61)& + &*(U1(55)*U2(84))+HESS(61)*(U1(84)*U2(55))+HESS(62)*(U1(65)*U2(84))+HESS(62)*(U1(84)*U2(65)) + HU(44) = HESS(63)*(U1(44)*U2(83))+HESS(63)*(U1(83)*U2(44))+HESS(64)*(U1(44)*U2(89))+HESS(64)*(U1(89)*U2(44))+HESS(65)& + &*(U1(78)*U2(82))+HESS(65)*(U1(82)*U2(78)) + HU(45) = HESS(66)*(U1(45)*U2(83))+HESS(66)*(U1(83)*U2(45))+HESS(67)*(U1(57)*U2(84))+HESS(67)*(U1(84)*U2(57))+HESS(68)& + &*(U1(79)*U2(84))+HESS(68)*(U1(84)*U2(79)) + HU(46) = HESS(69)*(U1(46)*U2(83))+HESS(69)*(U1(83)*U2(46))+HESS(70)*(U1(46)*U2(87))+HESS(70)*(U1(87)*U2(46))+HESS(71)& + &*(U1(46)*U2(89))+HESS(71)*(U1(89)*U2(46)) + HU(47) = HESS(72)*(U1(46)*U2(89))+HESS(72)*(U1(89)*U2(46))+HESS(73)*(U1(47)*U2(83))+HESS(73)*(U1(83)*U2(47))+HESS(74)& + &*(U1(48)*U2(89))+HESS(74)*(U1(89)*U2(48))+HESS(75)*(U1(50)*U2(83))+HESS(75)*(U1(83)*U2(50))+HESS(76)*(U1(58)& + &*U2(89))+HESS(76)*(U1(89)*U2(58))+HESS(77)*(U1(59)*U2(86))+HESS(77)*(U1(86)*U2(59))+HESS(78)*(U1(59)*U2(90))& + &+HESS(78)*(U1(90)*U2(59))+HESS(79)*(U1(66)*U2(85))+HESS(79)*(U1(85)*U2(66))+HESS(80)*(U1(66)*U2(86))+HESS(80)& + &*(U1(86)*U2(66))+HESS(81)*(U1(66)*U2(90))+HESS(81)*(U1(90)*U2(66))+HESS(82)*(U1(69)*U2(83))+HESS(82)*(U1(83)& + &*U2(69))+HESS(83)*(U1(69)*U2(87))+HESS(83)*(U1(87)*U2(69))+HESS(84)*(U1(71)*U2(83))+HESS(84)*(U1(83)*U2(71))& + &+HESS(85)*(U1(75)*U2(83))+HESS(85)*(U1(83)*U2(75))+HESS(86)*(U1(75)*U2(87))+HESS(86)*(U1(87)*U2(75))+HESS(87)& + &*(U1(77)*U2(89))+HESS(87)*(U1(89)*U2(77))+HESS(88)*(U1(80)*U2(89))+HESS(88)*(U1(89)*U2(80)) + HU(48) = HESS(89)*(U1(46)*U2(89))+HESS(89)*(U1(89)*U2(46))+HESS(90)*(U1(48)*U2(83))+HESS(90)*(U1(83)*U2(48))+HESS(91)& + &*(U1(48)*U2(87))+HESS(91)*(U1(87)*U2(48))+HESS(92)*(U1(48)*U2(89))+HESS(92)*(U1(89)*U2(48)) + HU(49) = HESS(93)*(U1(32)*U2(83))+HESS(93)*(U1(83)*U2(32))+HESS(94)*(U1(49)*U2(83))+HESS(94)*(U1(83)*U2(49))+HESS(95)& + &*(U1(53)*U2(85))+HESS(95)*(U1(85)*U2(53))+HESS(96)*(U1(53)*U2(86))+HESS(96)*(U1(86)*U2(53))+HESS(97)*(U1(53)& + &*U2(90))+HESS(97)*(U1(90)*U2(53))+HESS(98)*(U1(72)*U2(85))+HESS(98)*(U1(85)*U2(72))+HESS(99)*(U1(72)*U2(86))& + &+HESS(99)*(U1(86)*U2(72))+HESS(100)*(U1(72)*U2(90))+HESS(100)*(U1(90)*U2(72)) + HU(50) = HESS(101)*(U1(50)*U2(83))+HESS(101)*(U1(83)*U2(50))+HESS(102)*(U1(51)*U2(85))+HESS(102)*(U1(85)*U2(51))& + &+HESS(103)*(U1(58)*U2(89))+HESS(103)*(U1(89)*U2(58))+HESS(104)*(U1(64)*U2(85))+HESS(104)*(U1(85)*U2(64))& + &+HESS(105)*(U1(64)*U2(86))+HESS(105)*(U1(86)*U2(64))+HESS(106)*(U1(64)*U2(90))+HESS(106)*(U1(90)*U2(64))& + &+HESS(107)*(U1(65)*U2(85))+HESS(107)*(U1(85)*U2(65))+HESS(108)*(U1(65)*U2(86))+HESS(108)*(U1(86)*U2(65))& + &+HESS(109)*(U1(65)*U2(90))+HESS(109)*(U1(90)*U2(65))+HESS(110)*(U1(66)*U2(85))+HESS(110)*(U1(85)*U2(66))& + &+HESS(111)*(U1(66)*U2(86))+HESS(111)*(U1(86)*U2(66))+HESS(112)*(U1(66)*U2(90))+HESS(112)*(U1(90)*U2(66)) + HU(51) = HESS(113)*(U1(51)*U2(84))+HESS(113)*(U1(84)*U2(51))+HESS(114)*(U1(51)*U2(85))+HESS(114)*(U1(85)*U2(51))& + &+HESS(115)*(U1(51)*U2(86))+HESS(115)*(U1(86)*U2(51))+HESS(116)*(U1(51)*U2(90))+HESS(116)*(U1(90)*U2(51)) + HU(52) = HESS(117)*(U1(16)*U2(83))+HESS(117)*(U1(83)*U2(16))+HESS(118)*(U1(31)*U2(83))+HESS(118)*(U1(83)*U2(31))& + &+HESS(119)*(U1(52)*U2(84))+HESS(119)*(U1(84)*U2(52))+HESS(120)*(U1(52)*U2(85))+HESS(120)*(U1(85)*U2(52))& + &+HESS(121)*(U1(52)*U2(86))+HESS(121)*(U1(86)*U2(52))+HESS(122)*(U1(52)*U2(90))+HESS(122)*(U1(90)*U2(52))& + &+HESS(123)*(U1(72)*U2(85))+HESS(123)*(U1(85)*U2(72))+HESS(124)*(U1(72)*U2(86))+HESS(124)*(U1(86)*U2(72))& + &+HESS(125)*(U1(72)*U2(90))+HESS(125)*(U1(90)*U2(72)) + HU(53) = HESS(126)*(U1(16)*U2(83))+HESS(126)*(U1(83)*U2(16))+HESS(127)*(U1(32)*U2(83))+HESS(127)*(U1(83)*U2(32))& + &+HESS(128)*(U1(53)*U2(84))+HESS(128)*(U1(84)*U2(53))+HESS(129)*(U1(53)*U2(85))+HESS(129)*(U1(85)*U2(53))& + &+HESS(130)*(U1(53)*U2(86))+HESS(130)*(U1(86)*U2(53))+HESS(131)*(U1(53)*U2(90))+HESS(131)*(U1(90)*U2(53))& + &+HESS(132)*(U1(72)*U2(85))+HESS(132)*(U1(85)*U2(72))+HESS(133)*(U1(72)*U2(86))+HESS(133)*(U1(86)*U2(72))& + &+HESS(134)*(U1(72)*U2(90))+HESS(134)*(U1(90)*U2(72)) + HU(54) = HESS(135)*(U1(54)*U2(84))+HESS(135)*(U1(84)*U2(54))+HESS(136)*(U1(54)*U2(85))+HESS(136)*(U1(85)*U2(54))& + &+HESS(137)*(U1(54)*U2(86))+HESS(137)*(U1(86)*U2(54))+HESS(138)*(U1(54)*U2(90))+HESS(138)*(U1(90)*U2(54))& + &+HESS(139)*(U1(73)*U2(83))+HESS(139)*(U1(83)*U2(73)) + HU(55) = HESS(140)*(U1(55)*U2(84))+HESS(140)*(U1(84)*U2(55))+HESS(141)*(U1(55)*U2(85))+HESS(141)*(U1(85)*U2(55))& + &+HESS(142)*(U1(55)*U2(86))+HESS(142)*(U1(86)*U2(55))+HESS(143)*(U1(55)*U2(90))+HESS(143)*(U1(90)*U2(55))& + &+HESS(144)*(U1(80)*U2(87))+HESS(144)*(U1(87)*U2(80)) + HU(56) = HESS(145)*(U1(22)*U2(87))+HESS(145)*(U1(87)*U2(22))+HESS(146)*(U1(23)*U2(87))+HESS(146)*(U1(87)*U2(23))& + &+HESS(147)*(U1(34)*U2(87))+HESS(147)*(U1(87)*U2(34))+HESS(148)*(U1(51)*U2(85))+HESS(148)*(U1(85)*U2(51))& + &+HESS(149)*(U1(56)*U2(83))+HESS(149)*(U1(83)*U2(56))+HESS(150)*(U1(57)*U2(85))+HESS(150)*(U1(85)*U2(57))& + &+HESS(151)*(U1(59)*U2(85))+HESS(151)*(U1(85)*U2(59))+HESS(152)*(U1(64)*U2(85))+HESS(152)*(U1(85)*U2(64))& + &+HESS(153)*(U1(65)*U2(85))+HESS(153)*(U1(85)*U2(65))+HESS(154)*(U1(66)*U2(85))+HESS(154)*(U1(85)*U2(66))& + &+HESS(155)*(U1(67)*U2(85))+HESS(155)*(U1(85)*U2(67))+HESS(156)*(U1(67)*U2(86))+HESS(156)*(U1(86)*U2(67))& + &+HESS(157)*(U1(67)*U2(90))+HESS(157)*(U1(90)*U2(67))+HESS(158)*(U1(68)*U2(87))+HESS(158)*(U1(87)*U2(68))& + &+HESS(159)*(U1(69)*U2(87))+HESS(159)*(U1(87)*U2(69))+HESS(160)*(U1(71)*U2(87))+HESS(160)*(U1(87)*U2(71))& + &+HESS(161)*(U1(75)*U2(87))+HESS(161)*(U1(87)*U2(75))+HESS(162)*(U1(76)*U2(87))+HESS(162)*(U1(87)*U2(76))& + &+HESS(163)*(U1(79)*U2(85))+HESS(163)*(U1(85)*U2(79))+HESS(164)*(U1(80)*U2(87))+HESS(164)*(U1(87)*U2(80))& + &+HESS(165)*(U1(82)*U2(83))+HESS(165)*(U1(83)*U2(82)) + HU(57) = HESS(166)*(U1(57)*U2(84))+HESS(166)*(U1(84)*U2(57))+HESS(167)*(U1(57)*U2(85))+HESS(167)*(U1(85)*U2(57))& + &+HESS(168)*(U1(57)*U2(86))+HESS(168)*(U1(86)*U2(57))+HESS(169)*(U1(57)*U2(90))+HESS(169)*(U1(90)*U2(57))& + &+HESS(170)*(U1(79)*U2(86))+HESS(170)*(U1(86)*U2(79))+HESS(171)*(U1(79)*U2(90))+HESS(171)*(U1(90)*U2(79)) + HU(58) = HESS(172)*(U1(45)*U2(83))+HESS(172)*(U1(83)*U2(45))+HESS(173)*(U1(57)*U2(85))+HESS(173)*(U1(85)*U2(57))& + &+HESS(174)*(U1(57)*U2(86))+HESS(174)*(U1(86)*U2(57))+HESS(175)*(U1(57)*U2(90))+HESS(175)*(U1(90)*U2(57))& + &+HESS(176)*(U1(58)*U2(83))+HESS(176)*(U1(83)*U2(58))+HESS(177)*(U1(58)*U2(89))+HESS(177)*(U1(89)*U2(58))& + &+HESS(178)*(U1(79)*U2(85))+HESS(178)*(U1(85)*U2(79))+HESS(179)*(U1(79)*U2(86))+HESS(179)*(U1(86)*U2(79))& + &+HESS(180)*(U1(79)*U2(90))+HESS(180)*(U1(90)*U2(79)) + HU(59) = HESS(181)*(U1(40)*U2(83))+HESS(181)*(U1(83)*U2(40))+HESS(182)*(U1(59)*U2(84))+HESS(182)*(U1(84)*U2(59))& + &+HESS(183)*(U1(59)*U2(85))+HESS(183)*(U1(85)*U2(59))+HESS(184)*(U1(59)*U2(86))+HESS(184)*(U1(86)*U2(59))& + &+HESS(185)*(U1(59)*U2(90))+HESS(185)*(U1(90)*U2(59))+HESS(186)*(U1(80)*U2(83))+HESS(186)*(U1(83)*U2(80)) + HU(60) = HESS(187)*(U1(60)*U2(84))+HESS(187)*(U1(84)*U2(60))+HESS(188)*(U1(60)*U2(85))+HESS(188)*(U1(85)*U2(60))& + &+HESS(189)*(U1(60)*U2(86))+HESS(189)*(U1(86)*U2(60))+HESS(190)*(U1(60)*U2(90))+HESS(190)*(U1(90)*U2(60))& + &+HESS(191)*(U1(76)*U2(83))+HESS(191)*(U1(83)*U2(76))+HESS(192)*(U1(76)*U2(87))+HESS(192)*(U1(87)*U2(76)) + HU(61) = HESS(193)*(U1(44)*U2(83))+HESS(193)*(U1(83)*U2(44))+HESS(194)*(U1(58)*U2(89))+HESS(194)*(U1(89)*U2(58))& + &+HESS(195)*(U1(59)*U2(85))+HESS(195)*(U1(85)*U2(59))+HESS(196)*(U1(59)*U2(86))+HESS(196)*(U1(86)*U2(59))& + &+HESS(197)*(U1(59)*U2(90))+HESS(197)*(U1(90)*U2(59))+HESS(198)*(U1(61)*U2(83))+HESS(198)*(U1(83)*U2(61))& + &+HESS(199)*(U1(62)*U2(90))+HESS(199)*(U1(90)*U2(62))+HESS(200)*(U1(65)*U2(85))+HESS(200)*(U1(85)*U2(65))& + &+HESS(201)*(U1(65)*U2(86))+HESS(201)*(U1(86)*U2(65))+HESS(202)*(U1(65)*U2(90))+HESS(202)*(U1(90)*U2(65))& + &+HESS(203)*(U1(66)*U2(85))+HESS(203)*(U1(85)*U2(66))+HESS(204)*(U1(66)*U2(86))+HESS(204)*(U1(86)*U2(66))& + &+HESS(205)*(U1(66)*U2(90))+HESS(205)*(U1(90)*U2(66))+HESS(206)*(U1(70)*U2(86))+HESS(206)*(U1(86)*U2(70))& + &+HESS(207)*(U1(70)*U2(90))+HESS(207)*(U1(90)*U2(70)) + HU(62) = HESS(208)*(U1(49)*U2(83))+HESS(208)*(U1(83)*U2(49))+HESS(209)*(U1(62)*U2(84))+HESS(209)*(U1(84)*U2(62))& + &+HESS(210)*(U1(62)*U2(85))+HESS(210)*(U1(85)*U2(62))+HESS(211)*(U1(62)*U2(86))+HESS(211)*(U1(86)*U2(62))& + &+HESS(212)*(U1(62)*U2(90))+HESS(212)*(U1(90)*U2(62)) + HU(63) = HESS(213)*(U1(38)*U2(83))+HESS(213)*(U1(83)*U2(38))+HESS(214)*(U1(48)*U2(87))+HESS(214)*(U1(87)*U2(48))& + &+HESS(215)*(U1(63)*U2(84))+HESS(215)*(U1(84)*U2(63))+HESS(216)*(U1(63)*U2(85))+HESS(216)*(U1(85)*U2(63))& + &+HESS(217)*(U1(63)*U2(86))+HESS(217)*(U1(86)*U2(63))+HESS(218)*(U1(63)*U2(90))+HESS(218)*(U1(90)*U2(63)) + HU(64) = HESS(219)*(U1(42)*U2(83))+HESS(219)*(U1(83)*U2(42))+HESS(220)*(U1(64)*U2(84))+HESS(220)*(U1(84)*U2(64))& + &+HESS(221)*(U1(64)*U2(85))+HESS(221)*(U1(85)*U2(64))+HESS(222)*(U1(64)*U2(86))+HESS(222)*(U1(86)*U2(64))& + &+HESS(223)*(U1(64)*U2(90))+HESS(223)*(U1(90)*U2(64))+HESS(224)*(U1(77)*U2(83))+HESS(224)*(U1(83)*U2(77)) + HU(65) = HESS(225)*(U1(43)*U2(83))+HESS(225)*(U1(83)*U2(43))+HESS(226)*(U1(65)*U2(84))+HESS(226)*(U1(84)*U2(65))& + &+HESS(227)*(U1(65)*U2(85))+HESS(227)*(U1(85)*U2(65))+HESS(228)*(U1(65)*U2(86))+HESS(228)*(U1(86)*U2(65))& + &+HESS(229)*(U1(65)*U2(90))+HESS(229)*(U1(90)*U2(65)) + HU(66) = HESS(230)*(U1(41)*U2(83))+HESS(230)*(U1(83)*U2(41))+HESS(231)*(U1(58)*U2(83))+HESS(231)*(U1(83)*U2(58))& + &+HESS(232)*(U1(66)*U2(84))+HESS(232)*(U1(84)*U2(66))+HESS(233)*(U1(66)*U2(85))+HESS(233)*(U1(85)*U2(66))& + &+HESS(234)*(U1(66)*U2(86))+HESS(234)*(U1(86)*U2(66))+HESS(235)*(U1(66)*U2(90))+HESS(235)*(U1(90)*U2(66)) + HU(67) = HESS(236)*(U1(39)*U2(83))+HESS(236)*(U1(83)*U2(39))+HESS(237)*(U1(46)*U2(87))+HESS(237)*(U1(87)*U2(46))& + &+HESS(238)*(U1(67)*U2(84))+HESS(238)*(U1(84)*U2(67))+HESS(239)*(U1(67)*U2(85))+HESS(239)*(U1(85)*U2(67))& + &+HESS(240)*(U1(67)*U2(86))+HESS(240)*(U1(86)*U2(67))+HESS(241)*(U1(67)*U2(90))+HESS(241)*(U1(90)*U2(67)) + HU(68) = HESS(242)*(U1(30)*U2(83))+HESS(242)*(U1(83)*U2(30))+HESS(243)*(U1(31)*U2(83))+HESS(243)*(U1(83)*U2(31))& + &+HESS(244)*(U1(42)*U2(83))+HESS(244)*(U1(83)*U2(42))+HESS(245)*(U1(43)*U2(83))+HESS(245)*(U1(83)*U2(43))& + &+HESS(246)*(U1(51)*U2(86))+HESS(246)*(U1(86)*U2(51))+HESS(247)*(U1(51)*U2(90))+HESS(247)*(U1(90)*U2(51))& + &+HESS(248)*(U1(52)*U2(85))+HESS(248)*(U1(85)*U2(52))+HESS(249)*(U1(52)*U2(86))+HESS(249)*(U1(86)*U2(52))& + &+HESS(250)*(U1(52)*U2(90))+HESS(250)*(U1(90)*U2(52))+HESS(251)*(U1(54)*U2(85))+HESS(251)*(U1(85)*U2(54))& + &+HESS(252)*(U1(54)*U2(86))+HESS(252)*(U1(86)*U2(54))+HESS(253)*(U1(54)*U2(90))+HESS(253)*(U1(90)*U2(54))& + &+HESS(254)*(U1(55)*U2(86))+HESS(254)*(U1(86)*U2(55))+HESS(255)*(U1(55)*U2(90))+HESS(255)*(U1(90)*U2(55))& + &+HESS(256)*(U1(63)*U2(86))+HESS(256)*(U1(86)*U2(63))+HESS(257)*(U1(63)*U2(90))+HESS(257)*(U1(90)*U2(63))& + &+HESS(258)*(U1(65)*U2(86))+HESS(258)*(U1(86)*U2(65))+HESS(259)*(U1(65)*U2(90))+HESS(259)*(U1(90)*U2(65))& + &+HESS(260)*(U1(67)*U2(86))+HESS(260)*(U1(86)*U2(67))+HESS(261)*(U1(67)*U2(90))+HESS(261)*(U1(90)*U2(67))& + &+HESS(262)*(U1(68)*U2(83))+HESS(262)*(U1(83)*U2(68))+HESS(263)*(U1(68)*U2(87))+HESS(263)*(U1(87)*U2(68))& + &+HESS(264)*(U1(70)*U2(86))+HESS(264)*(U1(86)*U2(70))+HESS(265)*(U1(70)*U2(90))+HESS(265)*(U1(90)*U2(70))& + &+HESS(266)*(U1(72)*U2(85))+HESS(266)*(U1(85)*U2(72))+HESS(267)*(U1(72)*U2(86))+HESS(267)*(U1(86)*U2(72))& + &+HESS(268)*(U1(72)*U2(90))+HESS(268)*(U1(90)*U2(72)) + HU(69) = HESS(269)*(U1(27)*U2(83))+HESS(269)*(U1(83)*U2(27))+HESS(270)*(U1(28)*U2(83))+HESS(270)*(U1(83)*U2(28))& + &+HESS(271)*(U1(34)*U2(83))+HESS(271)*(U1(83)*U2(34))+HESS(272)*(U1(34)*U2(87))+HESS(272)*(U1(87)*U2(34))& + &+HESS(273)*(U1(44)*U2(83))+HESS(273)*(U1(83)*U2(44))+HESS(274)*(U1(44)*U2(89))+HESS(274)*(U1(89)*U2(44))& + &+HESS(275)*(U1(46)*U2(89))+HESS(275)*(U1(89)*U2(46))+HESS(276)*(U1(48)*U2(89))+HESS(276)*(U1(89)*U2(48))& + &+HESS(277)*(U1(51)*U2(85))+HESS(277)*(U1(85)*U2(51))+HESS(278)*(U1(51)*U2(86))+HESS(278)*(U1(86)*U2(51))& + &+HESS(279)*(U1(51)*U2(90))+HESS(279)*(U1(90)*U2(51))+HESS(280)*(U1(52)*U2(90))+HESS(280)*(U1(90)*U2(52))& + &+HESS(281)*(U1(53)*U2(90))+HESS(281)*(U1(90)*U2(53))+HESS(282)*(U1(54)*U2(85))+HESS(282)*(U1(85)*U2(54))& + &+HESS(283)*(U1(54)*U2(86))+HESS(283)*(U1(86)*U2(54))+HESS(284)*(U1(54)*U2(90))+HESS(284)*(U1(90)*U2(54))& + &+HESS(285)*(U1(55)*U2(85))+HESS(285)*(U1(85)*U2(55))+HESS(286)*(U1(55)*U2(86))+HESS(286)*(U1(86)*U2(55))& + &+HESS(287)*(U1(55)*U2(90))+HESS(287)*(U1(90)*U2(55))+HESS(288)*(U1(57)*U2(85))+HESS(288)*(U1(85)*U2(57))& + &+HESS(289)*(U1(57)*U2(86))+HESS(289)*(U1(86)*U2(57))+HESS(290)*(U1(57)*U2(90))+HESS(290)*(U1(90)*U2(57))& + &+HESS(291)*(U1(58)*U2(89))+HESS(291)*(U1(89)*U2(58))+HESS(292)*(U1(59)*U2(85))+HESS(292)*(U1(85)*U2(59))& + &+HESS(293)*(U1(59)*U2(86))+HESS(293)*(U1(86)*U2(59))+HESS(294)*(U1(59)*U2(90))+HESS(294)*(U1(90)*U2(59))& + &+HESS(295)*(U1(60)*U2(90))+HESS(295)*(U1(90)*U2(60))+HESS(296)*(U1(62)*U2(85))+HESS(296)*(U1(85)*U2(62))& + &+HESS(297)*(U1(62)*U2(86))+HESS(297)*(U1(86)*U2(62))+HESS(298)*(U1(62)*U2(90))+HESS(298)*(U1(90)*U2(62))& + &+HESS(299)*(U1(63)*U2(85))+HESS(299)*(U1(85)*U2(63))+HESS(300)*(U1(63)*U2(86))+HESS(300)*(U1(86)*U2(63))& + &+HESS(301)*(U1(63)*U2(90))+HESS(301)*(U1(90)*U2(63))+HESS(302)*(U1(64)*U2(85))+HESS(302)*(U1(85)*U2(64))& + &+HESS(303)*(U1(64)*U2(86))+HESS(303)*(U1(86)*U2(64))+HESS(304)*(U1(64)*U2(90))+HESS(304)*(U1(90)*U2(64))& + &+HESS(305)*(U1(65)*U2(90))+HESS(305)*(U1(90)*U2(65))+HESS(306)*(U1(66)*U2(85))+HESS(306)*(U1(85)*U2(66))& + &+HESS(307)*(U1(66)*U2(86))+HESS(307)*(U1(86)*U2(66))+HESS(308)*(U1(66)*U2(90))+HESS(308)*(U1(90)*U2(66))& + &+HESS(309)*(U1(67)*U2(85))+HESS(309)*(U1(85)*U2(67))+HESS(310)*(U1(67)*U2(86))+HESS(310)*(U1(86)*U2(67))& + &+HESS(311)*(U1(67)*U2(90))+HESS(311)*(U1(90)*U2(67))+HESS(312)*(U1(69)*U2(83))+HESS(312)*(U1(83)*U2(69))& + &+HESS(313)*(U1(69)*U2(87))+HESS(313)*(U1(87)*U2(69))+HESS(314)*(U1(70)*U2(85))+HESS(314)*(U1(85)*U2(70))& + &+HESS(315)*(U1(70)*U2(86))+HESS(315)*(U1(86)*U2(70))+HESS(316)*(U1(70)*U2(90))+HESS(316)*(U1(90)*U2(70))& + &+HESS(317)*(U1(71)*U2(83))+HESS(317)*(U1(83)*U2(71))+HESS(318)*(U1(72)*U2(90))+HESS(318)*(U1(90)*U2(72))& + &+HESS(319)*(U1(74)*U2(90))+HESS(319)*(U1(90)*U2(74))+HESS(320)*(U1(77)*U2(89))+HESS(320)*(U1(89)*U2(77))& + &+HESS(321)*(U1(78)*U2(85))+HESS(321)*(U1(85)*U2(78))+HESS(322)*(U1(78)*U2(86))+HESS(322)*(U1(86)*U2(78))& + &+HESS(323)*(U1(78)*U2(90))+HESS(323)*(U1(90)*U2(78))+HESS(324)*(U1(79)*U2(85))+HESS(324)*(U1(85)*U2(79))& + &+HESS(325)*(U1(79)*U2(86))+HESS(325)*(U1(86)*U2(79))+HESS(326)*(U1(79)*U2(90))+HESS(326)*(U1(90)*U2(79))& + &+HESS(327)*(U1(80)*U2(89))+HESS(327)*(U1(89)*U2(80))+HESS(328)*(U1(81)*U2(90))+HESS(328)*(U1(90)*U2(81))& + &+HESS(329)*(U1(84)*U2(88))+HESS(329)*(U1(88)*U2(84))+HESS(330)*(U1(85)*U2(88))+HESS(330)*(U1(88)*U2(85))& + &+HESS(331)*(U1(85)*U2(90))+HESS(331)*(U1(90)*U2(85))+HESS(332)*(U1(86)*U2(88))+HESS(332)*(U1(88)*U2(86))& + &+HESS(333)*(U1(86)*U2(90))+HESS(333)*(U1(90)*U2(86))+HESS(334)*(U1(88)*U2(90))+HESS(334)*(U1(90)*U2(88))& + &+HESS(335)*(U1(89)*U2(90))+HESS(335)*(U1(90)*U2(89))+HESS(336)*(U1(90)*U2(90)) + HU(70) = HESS(337)*(U1(37)*U2(83))+HESS(337)*(U1(83)*U2(37))+HESS(338)*(U1(48)*U2(83))+HESS(338)*(U1(83)*U2(48))& + &+HESS(339)*(U1(70)*U2(84))+HESS(339)*(U1(84)*U2(70))+HESS(340)*(U1(70)*U2(85))+HESS(340)*(U1(85)*U2(70))& + &+HESS(341)*(U1(70)*U2(86))+HESS(341)*(U1(86)*U2(70))+HESS(342)*(U1(70)*U2(90))+HESS(342)*(U1(90)*U2(70)) + HU(71) = HESS(343)*(U1(33)*U2(83))+HESS(343)*(U1(83)*U2(33))+HESS(344)*(U1(35)*U2(83))+HESS(344)*(U1(83)*U2(35))& + &+HESS(345)*(U1(48)*U2(89))+HESS(345)*(U1(89)*U2(48))+HESS(346)*(U1(54)*U2(85))+HESS(346)*(U1(85)*U2(54))& + &+HESS(347)*(U1(54)*U2(86))+HESS(347)*(U1(86)*U2(54))+HESS(348)*(U1(54)*U2(90))+HESS(348)*(U1(90)*U2(54))& + &+HESS(349)*(U1(60)*U2(85))+HESS(349)*(U1(85)*U2(60))+HESS(350)*(U1(60)*U2(86))+HESS(350)*(U1(86)*U2(60))& + &+HESS(351)*(U1(60)*U2(90))+HESS(351)*(U1(90)*U2(60))+HESS(352)*(U1(63)*U2(85))+HESS(352)*(U1(85)*U2(63))& + &+HESS(353)*(U1(63)*U2(86))+HESS(353)*(U1(86)*U2(63))+HESS(354)*(U1(63)*U2(90))+HESS(354)*(U1(90)*U2(63))& + &+HESS(355)*(U1(70)*U2(85))+HESS(355)*(U1(85)*U2(70))+HESS(356)*(U1(70)*U2(86))+HESS(356)*(U1(86)*U2(70))& + &+HESS(357)*(U1(70)*U2(90))+HESS(357)*(U1(90)*U2(70))+HESS(358)*(U1(71)*U2(83))+HESS(358)*(U1(83)*U2(71))& + &+HESS(359)*(U1(71)*U2(87))+HESS(359)*(U1(87)*U2(71))+HESS(360)*(U1(72)*U2(85))+HESS(360)*(U1(85)*U2(72))& + &+HESS(361)*(U1(72)*U2(86))+HESS(361)*(U1(86)*U2(72))+HESS(362)*(U1(72)*U2(90))+HESS(362)*(U1(90)*U2(72))& + &+HESS(363)*(U1(74)*U2(74))+HESS(364)*(U1(74)*U2(85))+HESS(364)*(U1(85)*U2(74))+HESS(365)*(U1(74)*U2(86))& + &+HESS(365)*(U1(86)*U2(74))+HESS(366)*(U1(74)*U2(90))+HESS(366)*(U1(90)*U2(74))+HESS(367)*(U1(77)*U2(89))& + &+HESS(367)*(U1(89)*U2(77)) + HU(72) = HESS(368)*(U1(22)*U2(83))+HESS(368)*(U1(83)*U2(22))+HESS(369)*(U1(22)*U2(87))+HESS(369)*(U1(87)*U2(22))& + &+HESS(370)*(U1(30)*U2(83))+HESS(370)*(U1(83)*U2(30))+HESS(371)*(U1(54)*U2(85))+HESS(371)*(U1(85)*U2(54))& + &+HESS(372)*(U1(54)*U2(86))+HESS(372)*(U1(86)*U2(54))+HESS(373)*(U1(54)*U2(90))+HESS(373)*(U1(90)*U2(54))& + &+HESS(374)*(U1(72)*U2(84))+HESS(374)*(U1(84)*U2(72))+HESS(375)*(U1(72)*U2(85))+HESS(375)*(U1(85)*U2(72))& + &+HESS(376)*(U1(72)*U2(86))+HESS(376)*(U1(86)*U2(72))+HESS(377)*(U1(72)*U2(90))+HESS(377)*(U1(90)*U2(72)) + HU(73) = HESS(378)*(U1(54)*U2(84))+HESS(378)*(U1(84)*U2(54))+HESS(379)*(U1(60)*U2(85))+HESS(379)*(U1(85)*U2(60))& + &+HESS(380)*(U1(62)*U2(85))+HESS(380)*(U1(85)*U2(62))+HESS(381)*(U1(72)*U2(85))+HESS(381)*(U1(85)*U2(72))& + &+HESS(382)*(U1(73)*U2(83))+HESS(382)*(U1(83)*U2(73)) + HU(74) = HESS(383)*(U1(23)*U2(83))+HESS(383)*(U1(83)*U2(23))+HESS(384)*(U1(23)*U2(87))+HESS(384)*(U1(87)*U2(23))& + &+HESS(385)*(U1(35)*U2(83))+HESS(385)*(U1(83)*U2(35))+HESS(386)*(U1(72)*U2(85))+HESS(386)*(U1(85)*U2(72))& + &+HESS(387)*(U1(72)*U2(86))+HESS(387)*(U1(86)*U2(72))+HESS(388)*(U1(72)*U2(90))+HESS(388)*(U1(90)*U2(72))& + &+HESS(389)*(U1(74)*U2(74))+HESS(390)*(U1(74)*U2(84))+HESS(390)*(U1(84)*U2(74))+HESS(391)*(U1(74)*U2(85))& + &+HESS(391)*(U1(85)*U2(74))+HESS(392)*(U1(74)*U2(86))+HESS(392)*(U1(86)*U2(74))+HESS(393)*(U1(74)*U2(90))& + &+HESS(393)*(U1(90)*U2(74))+HESS(394)*(U1(81)*U2(85))+HESS(394)*(U1(85)*U2(81))+HESS(395)*(U1(81)*U2(86))& + &+HESS(395)*(U1(86)*U2(81))+HESS(396)*(U1(81)*U2(90))+HESS(396)*(U1(90)*U2(81)) + HU(75) = HESS(397)*(U1(51)*U2(85))+HESS(397)*(U1(85)*U2(51))+HESS(398)*(U1(51)*U2(86))+HESS(398)*(U1(86)*U2(51))& + &+HESS(399)*(U1(51)*U2(90))+HESS(399)*(U1(90)*U2(51))+HESS(400)*(U1(55)*U2(85))+HESS(400)*(U1(85)*U2(55))& + &+HESS(401)*(U1(55)*U2(86))+HESS(401)*(U1(86)*U2(55))+HESS(402)*(U1(55)*U2(90))+HESS(402)*(U1(90)*U2(55))& + &+HESS(403)*(U1(58)*U2(89))+HESS(403)*(U1(89)*U2(58))+HESS(404)*(U1(59)*U2(86))+HESS(404)*(U1(86)*U2(59))& + &+HESS(405)*(U1(60)*U2(84))+HESS(405)*(U1(84)*U2(60))+HESS(406)*(U1(61)*U2(83))+HESS(406)*(U1(83)*U2(61))& + &+HESS(407)*(U1(62)*U2(86))+HESS(407)*(U1(86)*U2(62))+HESS(408)*(U1(62)*U2(90))+HESS(408)*(U1(90)*U2(62))& + &+HESS(409)*(U1(64)*U2(85))+HESS(409)*(U1(85)*U2(64))+HESS(410)*(U1(64)*U2(86))+HESS(410)*(U1(86)*U2(64))& + &+HESS(411)*(U1(64)*U2(90))+HESS(411)*(U1(90)*U2(64))+HESS(412)*(U1(66)*U2(85))+HESS(412)*(U1(85)*U2(66))& + &+HESS(413)*(U1(66)*U2(86))+HESS(413)*(U1(86)*U2(66))+HESS(414)*(U1(66)*U2(90))+HESS(414)*(U1(90)*U2(66))& + &+HESS(415)*(U1(75)*U2(83))+HESS(415)*(U1(83)*U2(75))+HESS(416)*(U1(75)*U2(87))+HESS(416)*(U1(87)*U2(75))& + &+HESS(417)*(U1(77)*U2(89))+HESS(417)*(U1(89)*U2(77))+HESS(418)*(U1(80)*U2(89))+HESS(418)*(U1(89)*U2(80)) + HU(76) = HESS(419)*(U1(57)*U2(86))+HESS(419)*(U1(86)*U2(57))+HESS(420)*(U1(57)*U2(90))+HESS(420)*(U1(90)*U2(57))& + &+HESS(421)*(U1(59)*U2(86))+HESS(421)*(U1(86)*U2(59))+HESS(422)*(U1(60)*U2(86))+HESS(422)*(U1(86)*U2(60))& + &+HESS(423)*(U1(60)*U2(90))+HESS(423)*(U1(90)*U2(60))+HESS(424)*(U1(62)*U2(86))+HESS(424)*(U1(86)*U2(62))& + &+HESS(425)*(U1(64)*U2(86))+HESS(425)*(U1(86)*U2(64))+HESS(426)*(U1(64)*U2(90))+HESS(426)*(U1(90)*U2(64))& + &+HESS(427)*(U1(66)*U2(86))+HESS(427)*(U1(86)*U2(66))+HESS(428)*(U1(66)*U2(90))+HESS(428)*(U1(90)*U2(66))& + &+HESS(429)*(U1(72)*U2(85))+HESS(429)*(U1(85)*U2(72))+HESS(430)*(U1(72)*U2(86))+HESS(430)*(U1(86)*U2(72))& + &+HESS(431)*(U1(72)*U2(90))+HESS(431)*(U1(90)*U2(72))+HESS(432)*(U1(76)*U2(83))+HESS(432)*(U1(83)*U2(76))& + &+HESS(433)*(U1(76)*U2(87))+HESS(433)*(U1(87)*U2(76))+HESS(434)*(U1(79)*U2(86))+HESS(434)*(U1(86)*U2(79))& + &+HESS(435)*(U1(79)*U2(90))+HESS(435)*(U1(90)*U2(79)) + HU(77) = HESS(436)*(U1(46)*U2(89))+HESS(436)*(U1(89)*U2(46))+HESS(437)*(U1(67)*U2(85))+HESS(437)*(U1(85)*U2(67))& + &+HESS(438)*(U1(67)*U2(86))+HESS(438)*(U1(86)*U2(67))+HESS(439)*(U1(67)*U2(90))+HESS(439)*(U1(90)*U2(67))& + &+HESS(440)*(U1(77)*U2(83))+HESS(440)*(U1(83)*U2(77))+HESS(441)*(U1(77)*U2(89))+HESS(441)*(U1(89)*U2(77))& + &+HESS(442)*(U1(79)*U2(85))+HESS(442)*(U1(85)*U2(79))+HESS(443)*(U1(79)*U2(86))+HESS(443)*(U1(86)*U2(79))& + &+HESS(444)*(U1(79)*U2(90))+HESS(444)*(U1(90)*U2(79)) + HU(78) = HESS(445)*(U1(26)*U2(83))+HESS(445)*(U1(83)*U2(26))+HESS(446)*(U1(58)*U2(83))+HESS(446)*(U1(83)*U2(58))& + &+HESS(447)*(U1(78)*U2(82))+HESS(447)*(U1(82)*U2(78))+HESS(448)*(U1(78)*U2(84))+HESS(448)*(U1(84)*U2(78))& + &+HESS(449)*(U1(78)*U2(85))+HESS(449)*(U1(85)*U2(78))+HESS(450)*(U1(78)*U2(86))+HESS(450)*(U1(86)*U2(78))& + &+HESS(451)*(U1(78)*U2(90))+HESS(451)*(U1(90)*U2(78))+HESS(452)*(U1(80)*U2(83))+HESS(452)*(U1(83)*U2(80))& + &+HESS(453)*(U1(80)*U2(87))+HESS(453)*(U1(87)*U2(80)) + HU(79) = HESS(454)*(U1(45)*U2(83))+HESS(454)*(U1(83)*U2(45))+HESS(455)*(U1(46)*U2(83))+HESS(455)*(U1(83)*U2(46))& + &+HESS(456)*(U1(79)*U2(84))+HESS(456)*(U1(84)*U2(79))+HESS(457)*(U1(79)*U2(85))+HESS(457)*(U1(85)*U2(79))& + &+HESS(458)*(U1(79)*U2(86))+HESS(458)*(U1(86)*U2(79))+HESS(459)*(U1(79)*U2(90))+HESS(459)*(U1(90)*U2(79)) + HU(80) = HESS(460)*(U1(46)*U2(89))+HESS(460)*(U1(89)*U2(46))+HESS(461)*(U1(67)*U2(85))+HESS(461)*(U1(85)*U2(67))& + &+HESS(462)*(U1(67)*U2(86))+HESS(462)*(U1(86)*U2(67))+HESS(463)*(U1(67)*U2(90))+HESS(463)*(U1(90)*U2(67))& + &+HESS(464)*(U1(79)*U2(85))+HESS(464)*(U1(85)*U2(79))+HESS(465)*(U1(79)*U2(86))+HESS(465)*(U1(86)*U2(79))& + &+HESS(466)*(U1(79)*U2(90))+HESS(466)*(U1(90)*U2(79))+HESS(467)*(U1(80)*U2(83))+HESS(467)*(U1(83)*U2(80))& + &+HESS(468)*(U1(80)*U2(87))+HESS(468)*(U1(87)*U2(80))+HESS(469)*(U1(80)*U2(89))+HESS(469)*(U1(89)*U2(80)) + HU(81) = HESS(470)*(U1(33)*U2(83))+HESS(470)*(U1(83)*U2(33))+HESS(471)*(U1(68)*U2(83))+HESS(471)*(U1(83)*U2(68))& + &+HESS(472)*(U1(68)*U2(87))+HESS(472)*(U1(87)*U2(68))+HESS(473)*(U1(81)*U2(82))+HESS(473)*(U1(82)*U2(81))& + &+HESS(474)*(U1(81)*U2(84))+HESS(474)*(U1(84)*U2(81))+HESS(475)*(U1(81)*U2(85))+HESS(475)*(U1(85)*U2(81))& + &+HESS(476)*(U1(81)*U2(86))+HESS(476)*(U1(86)*U2(81))+HESS(477)*(U1(81)*U2(90))+HESS(477)*(U1(90)*U2(81)) + HU(82) = HESS(478)*(U1(24)*U2(83))+HESS(478)*(U1(83)*U2(24))+HESS(479)*(U1(29)*U2(83))+HESS(479)*(U1(83)*U2(29))& + &+HESS(480)*(U1(43)*U2(83))+HESS(480)*(U1(83)*U2(43))+HESS(481)*(U1(44)*U2(83))+HESS(481)*(U1(83)*U2(44))& + &+HESS(482)*(U1(44)*U2(89))+HESS(482)*(U1(89)*U2(44))+HESS(483)*(U1(51)*U2(85))+HESS(483)*(U1(85)*U2(51))& + &+HESS(484)*(U1(51)*U2(86))+HESS(484)*(U1(86)*U2(51))+HESS(485)*(U1(51)*U2(90))+HESS(485)*(U1(90)*U2(51))& + &+HESS(486)*(U1(52)*U2(85))+HESS(486)*(U1(85)*U2(52))+HESS(487)*(U1(53)*U2(85))+HESS(487)*(U1(85)*U2(53))& + &+HESS(488)*(U1(54)*U2(85))+HESS(488)*(U1(85)*U2(54))+HESS(489)*(U1(54)*U2(86))+HESS(489)*(U1(86)*U2(54))& + &+HESS(490)*(U1(54)*U2(90))+HESS(490)*(U1(90)*U2(54))+HESS(491)*(U1(55)*U2(85))+HESS(491)*(U1(85)*U2(55))& + &+HESS(492)*(U1(55)*U2(86))+HESS(492)*(U1(86)*U2(55))+HESS(493)*(U1(55)*U2(90))+HESS(493)*(U1(90)*U2(55))& + &+HESS(494)*(U1(57)*U2(85))+HESS(494)*(U1(85)*U2(57))+HESS(495)*(U1(59)*U2(85))+HESS(495)*(U1(85)*U2(59))& + &+HESS(496)*(U1(60)*U2(85))+HESS(496)*(U1(85)*U2(60))+HESS(497)*(U1(62)*U2(85))+HESS(497)*(U1(85)*U2(62))& + &+HESS(498)*(U1(63)*U2(85))+HESS(498)*(U1(85)*U2(63))+HESS(499)*(U1(63)*U2(86))+HESS(499)*(U1(86)*U2(63))& + &+HESS(500)*(U1(63)*U2(90))+HESS(500)*(U1(90)*U2(63))+HESS(501)*(U1(64)*U2(85))+HESS(501)*(U1(85)*U2(64))& + &+HESS(502)*(U1(65)*U2(85))+HESS(502)*(U1(85)*U2(65))+HESS(503)*(U1(65)*U2(86))+HESS(503)*(U1(86)*U2(65))& + &+HESS(504)*(U1(65)*U2(90))+HESS(504)*(U1(90)*U2(65))+HESS(505)*(U1(66)*U2(85))+HESS(505)*(U1(85)*U2(66))& + &+HESS(506)*(U1(67)*U2(85))+HESS(506)*(U1(85)*U2(67))+HESS(507)*(U1(67)*U2(86))+HESS(507)*(U1(86)*U2(67))& + &+HESS(508)*(U1(67)*U2(90))+HESS(508)*(U1(90)*U2(67))+HESS(509)*(U1(70)*U2(85))+HESS(509)*(U1(85)*U2(70))& + &+HESS(510)*(U1(72)*U2(85))+HESS(510)*(U1(85)*U2(72))+HESS(511)*(U1(74)*U2(85))+HESS(511)*(U1(85)*U2(74))& + &+HESS(512)*(U1(78)*U2(82))+HESS(512)*(U1(82)*U2(78))+HESS(513)*(U1(78)*U2(85))+HESS(513)*(U1(85)*U2(78))& + &+HESS(514)*(U1(79)*U2(85))+HESS(514)*(U1(85)*U2(79))+HESS(515)*(U1(81)*U2(82))+HESS(515)*(U1(82)*U2(81))& + &+HESS(516)*(U1(81)*U2(85))+HESS(516)*(U1(85)*U2(81))+HESS(517)*(U1(82)*U2(83))+HESS(517)*(U1(83)*U2(82))& + &+HESS(518)*(U1(82)*U2(84))+HESS(518)*(U1(84)*U2(82))+HESS(519)*(U1(82)*U2(86))+HESS(519)*(U1(86)*U2(82))& + &+HESS(520)*(U1(82)*U2(87))+HESS(520)*(U1(87)*U2(82))+HESS(521)*(U1(82)*U2(88))+HESS(521)*(U1(88)*U2(82))& + &+HESS(522)*(U1(82)*U2(89))+HESS(522)*(U1(89)*U2(82))+HESS(523)*(U1(83)*U2(87))+HESS(523)*(U1(87)*U2(83))& + &+HESS(524)*(U1(84)*U2(85))+HESS(524)*(U1(85)*U2(84))+HESS(525)*(U1(84)*U2(87))+HESS(525)*(U1(87)*U2(84))& + &+HESS(526)*(U1(85)*U2(86))+HESS(526)*(U1(86)*U2(85))+HESS(527)*(U1(85)*U2(87))+HESS(527)*(U1(87)*U2(85))& + &+HESS(528)*(U1(85)*U2(88))+HESS(528)*(U1(88)*U2(85))+HESS(529)*(U1(85)*U2(89))+HESS(529)*(U1(89)*U2(85))& + &+HESS(530)*(U1(85)*U2(90))+HESS(530)*(U1(90)*U2(85))+HESS(531)*(U1(87)*U2(87)) + HU(83) = HESS(532)*(U1(16)*U2(83))+HESS(532)*(U1(83)*U2(16))+HESS(533)*(U1(17)*U2(83))+HESS(533)*(U1(83)*U2(17))& + &+HESS(534)*(U1(20)*U2(83))+HESS(534)*(U1(83)*U2(20))+HESS(535)*(U1(22)*U2(83))+HESS(535)*(U1(83)*U2(22))& + &+HESS(536)*(U1(23)*U2(83))+HESS(536)*(U1(83)*U2(23))+HESS(537)*(U1(24)*U2(83))+HESS(537)*(U1(83)*U2(24))& + &+HESS(538)*(U1(26)*U2(83))+HESS(538)*(U1(83)*U2(26))+HESS(539)*(U1(27)*U2(83))+HESS(539)*(U1(83)*U2(27))& + &+HESS(540)*(U1(28)*U2(83))+HESS(540)*(U1(83)*U2(28))+HESS(541)*(U1(29)*U2(83))+HESS(541)*(U1(83)*U2(29))& + &+HESS(542)*(U1(30)*U2(83))+HESS(542)*(U1(83)*U2(30))+HESS(543)*(U1(31)*U2(83))+HESS(543)*(U1(83)*U2(31))& + &+HESS(544)*(U1(32)*U2(83))+HESS(544)*(U1(83)*U2(32))+HESS(545)*(U1(33)*U2(83))+HESS(545)*(U1(83)*U2(33))& + &+HESS(546)*(U1(34)*U2(83))+HESS(546)*(U1(83)*U2(34))+HESS(547)*(U1(35)*U2(83))+HESS(547)*(U1(83)*U2(35))& + &+HESS(548)*(U1(36)*U2(83))+HESS(548)*(U1(83)*U2(36))+HESS(549)*(U1(37)*U2(83))+HESS(549)*(U1(83)*U2(37))& + &+HESS(550)*(U1(38)*U2(83))+HESS(550)*(U1(83)*U2(38))+HESS(551)*(U1(39)*U2(83))+HESS(551)*(U1(83)*U2(39))& + &+HESS(552)*(U1(40)*U2(83))+HESS(552)*(U1(83)*U2(40))+HESS(553)*(U1(41)*U2(83))+HESS(553)*(U1(83)*U2(41))& + &+HESS(554)*(U1(42)*U2(83))+HESS(554)*(U1(83)*U2(42))+HESS(555)*(U1(43)*U2(83))+HESS(555)*(U1(83)*U2(43))& + &+HESS(556)*(U1(44)*U2(83))+HESS(556)*(U1(83)*U2(44))+HESS(557)*(U1(45)*U2(83))+HESS(557)*(U1(83)*U2(45))& + &+HESS(558)*(U1(46)*U2(83))+HESS(558)*(U1(83)*U2(46))+HESS(559)*(U1(46)*U2(89))+HESS(559)*(U1(89)*U2(46))& + &+HESS(560)*(U1(47)*U2(83))+HESS(560)*(U1(83)*U2(47))+HESS(561)*(U1(48)*U2(83))+HESS(561)*(U1(83)*U2(48))& + &+HESS(562)*(U1(48)*U2(89))+HESS(562)*(U1(89)*U2(48))+HESS(563)*(U1(49)*U2(83))+HESS(563)*(U1(83)*U2(49))& + &+HESS(564)*(U1(50)*U2(83))+HESS(564)*(U1(83)*U2(50))+HESS(565)*(U1(56)*U2(83))+HESS(565)*(U1(83)*U2(56))& + &+HESS(566)*(U1(58)*U2(83))+HESS(566)*(U1(83)*U2(58))+HESS(567)*(U1(58)*U2(89))+HESS(567)*(U1(89)*U2(58))& + &+HESS(568)*(U1(61)*U2(83))+HESS(568)*(U1(83)*U2(61))+HESS(569)*(U1(68)*U2(83))+HESS(569)*(U1(83)*U2(68))& + &+HESS(570)*(U1(69)*U2(83))+HESS(570)*(U1(83)*U2(69))+HESS(571)*(U1(71)*U2(83))+HESS(571)*(U1(83)*U2(71))& + &+HESS(572)*(U1(73)*U2(83))+HESS(572)*(U1(83)*U2(73))+HESS(573)*(U1(75)*U2(83))+HESS(573)*(U1(83)*U2(75))& + &+HESS(574)*(U1(76)*U2(83))+HESS(574)*(U1(83)*U2(76))+HESS(575)*(U1(77)*U2(83))+HESS(575)*(U1(83)*U2(77))& + &+HESS(576)*(U1(77)*U2(89))+HESS(576)*(U1(89)*U2(77))+HESS(577)*(U1(80)*U2(83))+HESS(577)*(U1(83)*U2(80))& + &+HESS(578)*(U1(80)*U2(89))+HESS(578)*(U1(89)*U2(80))+HESS(579)*(U1(82)*U2(83))+HESS(579)*(U1(83)*U2(82))& + &+HESS(580)*(U1(83)*U2(83))+HESS(581)*(U1(83)*U2(84))+HESS(581)*(U1(84)*U2(83))+HESS(582)*(U1(83)*U2(85))& + &+HESS(582)*(U1(85)*U2(83))+HESS(583)*(U1(83)*U2(87))+HESS(583)*(U1(87)*U2(83))+HESS(584)*(U1(83)*U2(89))& + &+HESS(584)*(U1(89)*U2(83))+HESS(585)*(U1(84)*U2(85))+HESS(585)*(U1(85)*U2(84))+HESS(586)*(U1(84)*U2(86))& + &+HESS(586)*(U1(86)*U2(84))+HESS(587)*(U1(84)*U2(87))+HESS(587)*(U1(87)*U2(84))+HESS(588)*(U1(84)*U2(89))& + &+HESS(588)*(U1(89)*U2(84)) + HU(84) = HESS(589)*(U1(17)*U2(83))+HESS(589)*(U1(83)*U2(17))+HESS(590)*(U1(20)*U2(83))+HESS(590)*(U1(83)*U2(20))& + &+HESS(591)*(U1(44)*U2(83))+HESS(591)*(U1(83)*U2(44))+HESS(592)*(U1(44)*U2(89))+HESS(592)*(U1(89)*U2(44))& + &+HESS(593)*(U1(46)*U2(89))+HESS(593)*(U1(89)*U2(46))+HESS(594)*(U1(47)*U2(83))+HESS(594)*(U1(83)*U2(47))& + &+HESS(595)*(U1(48)*U2(89))+HESS(595)*(U1(89)*U2(48))+HESS(596)*(U1(50)*U2(83))+HESS(596)*(U1(83)*U2(50))& + &+HESS(597)*(U1(51)*U2(84))+HESS(597)*(U1(84)*U2(51))+HESS(598)*(U1(51)*U2(85))+HESS(598)*(U1(85)*U2(51))& + &+HESS(599)*(U1(51)*U2(86))+HESS(599)*(U1(86)*U2(51))+HESS(600)*(U1(51)*U2(90))+HESS(600)*(U1(90)*U2(51))& + &+HESS(601)*(U1(52)*U2(84))+HESS(601)*(U1(84)*U2(52))+HESS(602)*(U1(52)*U2(85))+HESS(602)*(U1(85)*U2(52))& + &+HESS(603)*(U1(52)*U2(86))+HESS(603)*(U1(86)*U2(52))+HESS(604)*(U1(52)*U2(90))+HESS(604)*(U1(90)*U2(52))& + &+HESS(605)*(U1(53)*U2(84))+HESS(605)*(U1(84)*U2(53))+HESS(606)*(U1(53)*U2(85))+HESS(606)*(U1(85)*U2(53))& + &+HESS(607)*(U1(53)*U2(86))+HESS(607)*(U1(86)*U2(53))+HESS(608)*(U1(53)*U2(90))+HESS(608)*(U1(90)*U2(53))& + &+HESS(609)*(U1(54)*U2(84))+HESS(609)*(U1(84)*U2(54))+HESS(610)*(U1(54)*U2(90))+HESS(610)*(U1(90)*U2(54))& + &+HESS(611)*(U1(55)*U2(84))+HESS(611)*(U1(84)*U2(55))+HESS(612)*(U1(55)*U2(90))+HESS(612)*(U1(90)*U2(55))& + &+HESS(613)*(U1(57)*U2(84))+HESS(613)*(U1(84)*U2(57))+HESS(614)*(U1(57)*U2(85))+HESS(614)*(U1(85)*U2(57))& + &+HESS(615)*(U1(57)*U2(86))+HESS(615)*(U1(86)*U2(57))+HESS(616)*(U1(57)*U2(90))+HESS(616)*(U1(90)*U2(57))& + &+HESS(617)*(U1(58)*U2(83))+HESS(617)*(U1(83)*U2(58))+HESS(618)*(U1(59)*U2(84))+HESS(618)*(U1(84)*U2(59))& + &+HESS(619)*(U1(59)*U2(85))+HESS(619)*(U1(85)*U2(59))+HESS(620)*(U1(59)*U2(86))+HESS(620)*(U1(86)*U2(59))& + &+HESS(621)*(U1(59)*U2(90))+HESS(621)*(U1(90)*U2(59))+HESS(622)*(U1(60)*U2(84))+HESS(622)*(U1(84)*U2(60))& + &+HESS(623)*(U1(60)*U2(90))+HESS(623)*(U1(90)*U2(60))+HESS(624)*(U1(61)*U2(83))+HESS(624)*(U1(83)*U2(61))& + &+HESS(625)*(U1(62)*U2(84))+HESS(625)*(U1(84)*U2(62))+HESS(626)*(U1(62)*U2(86))+HESS(626)*(U1(86)*U2(62))& + &+HESS(627)*(U1(62)*U2(90))+HESS(627)*(U1(90)*U2(62))+HESS(628)*(U1(63)*U2(84))+HESS(628)*(U1(84)*U2(63))& + &+HESS(629)*(U1(63)*U2(90))+HESS(629)*(U1(90)*U2(63))+HESS(630)*(U1(64)*U2(84))+HESS(630)*(U1(84)*U2(64))& + &+HESS(631)*(U1(64)*U2(85))+HESS(631)*(U1(85)*U2(64))+HESS(632)*(U1(64)*U2(86))+HESS(632)*(U1(86)*U2(64))& + &+HESS(633)*(U1(64)*U2(90))+HESS(633)*(U1(90)*U2(64))+HESS(634)*(U1(65)*U2(84))+HESS(634)*(U1(84)*U2(65))& + &+HESS(635)*(U1(65)*U2(85))+HESS(635)*(U1(85)*U2(65))+HESS(636)*(U1(65)*U2(90))+HESS(636)*(U1(90)*U2(65))& + &+HESS(637)*(U1(66)*U2(84))+HESS(637)*(U1(84)*U2(66))+HESS(638)*(U1(66)*U2(85))+HESS(638)*(U1(85)*U2(66))& + &+HESS(639)*(U1(66)*U2(86))+HESS(639)*(U1(86)*U2(66))+HESS(640)*(U1(66)*U2(90))+HESS(640)*(U1(90)*U2(66))& + &+HESS(641)*(U1(67)*U2(84))+HESS(641)*(U1(84)*U2(67))+HESS(642)*(U1(67)*U2(85))+HESS(642)*(U1(85)*U2(67))& + &+HESS(643)*(U1(67)*U2(86))+HESS(643)*(U1(86)*U2(67))+HESS(644)*(U1(67)*U2(90))+HESS(644)*(U1(90)*U2(67))& + &+HESS(645)*(U1(69)*U2(83))+HESS(645)*(U1(83)*U2(69))+HESS(646)*(U1(69)*U2(87))+HESS(646)*(U1(87)*U2(69))& + &+HESS(647)*(U1(70)*U2(84))+HESS(647)*(U1(84)*U2(70))+HESS(648)*(U1(70)*U2(85))+HESS(648)*(U1(85)*U2(70))& + &+HESS(649)*(U1(70)*U2(86))+HESS(649)*(U1(86)*U2(70))+HESS(650)*(U1(70)*U2(90))+HESS(650)*(U1(90)*U2(70))& + &+HESS(651)*(U1(71)*U2(83))+HESS(651)*(U1(83)*U2(71))+HESS(652)*(U1(72)*U2(84))+HESS(652)*(U1(84)*U2(72))& + &+HESS(653)*(U1(72)*U2(85))+HESS(653)*(U1(85)*U2(72))+HESS(654)*(U1(72)*U2(86))+HESS(654)*(U1(86)*U2(72))& + &+HESS(655)*(U1(72)*U2(90))+HESS(655)*(U1(90)*U2(72))+HESS(656)*(U1(74)*U2(74))+HESS(657)*(U1(74)*U2(84))& + &+HESS(657)*(U1(84)*U2(74))+HESS(658)*(U1(74)*U2(85))+HESS(658)*(U1(85)*U2(74))+HESS(659)*(U1(74)*U2(86))& + &+HESS(659)*(U1(86)*U2(74))+HESS(660)*(U1(74)*U2(90))+HESS(660)*(U1(90)*U2(74))+HESS(661)*(U1(77)*U2(89)) + HU(84) = HU(84)& + &+HESS(661)*(U1(89)*U2(77))+HESS(662)*(U1(78)*U2(84))+HESS(662)*(U1(84)*U2(78))+HESS(663)*(U1(78)*U2(90))& + &+HESS(663)*(U1(90)*U2(78))+HESS(664)*(U1(79)*U2(84))+HESS(664)*(U1(84)*U2(79))+HESS(665)*(U1(79)*U2(85))& + &+HESS(665)*(U1(85)*U2(79))+HESS(666)*(U1(79)*U2(86))+HESS(666)*(U1(86)*U2(79))+HESS(667)*(U1(79)*U2(90))& + &+HESS(667)*(U1(90)*U2(79))+HESS(668)*(U1(80)*U2(89))+HESS(668)*(U1(89)*U2(80))+HESS(669)*(U1(81)*U2(84))& + &+HESS(669)*(U1(84)*U2(81))+HESS(670)*(U1(81)*U2(90))+HESS(670)*(U1(90)*U2(81))+HESS(671)*(U1(82)*U2(84))& + &+HESS(671)*(U1(84)*U2(82))+HESS(672)*(U1(83)*U2(84))+HESS(672)*(U1(84)*U2(83))+HESS(673)*(U1(83)*U2(87))& + &+HESS(673)*(U1(87)*U2(83))+HESS(674)*(U1(83)*U2(89))+HESS(674)*(U1(89)*U2(83))+HESS(675)*(U1(84)*U2(84))& + &+HESS(676)*(U1(84)*U2(85))+HESS(676)*(U1(85)*U2(84))+HESS(677)*(U1(84)*U2(86))+HESS(677)*(U1(86)*U2(84))& + &+HESS(678)*(U1(84)*U2(87))+HESS(678)*(U1(87)*U2(84))+HESS(679)*(U1(84)*U2(88))+HESS(679)*(U1(88)*U2(84))& + &+HESS(680)*(U1(84)*U2(89))+HESS(680)*(U1(89)*U2(84))+HESS(681)*(U1(84)*U2(90))+HESS(681)*(U1(90)*U2(84))& + &+HESS(682)*(U1(85)*U2(88))+HESS(682)*(U1(88)*U2(85))+HESS(683)*(U1(85)*U2(90))+HESS(683)*(U1(90)*U2(85))& + &+HESS(684)*(U1(86)*U2(88))+HESS(684)*(U1(88)*U2(86))+HESS(685)*(U1(86)*U2(90))+HESS(685)*(U1(90)*U2(86))& + &+HESS(686)*(U1(88)*U2(90))+HESS(686)*(U1(90)*U2(88))+HESS(687)*(U1(89)*U2(90))+HESS(687)*(U1(90)*U2(89))& + &+HESS(688)*(U1(90)*U2(90)) + HU(85) = HESS(689)*(U1(51)*U2(85))+HESS(689)*(U1(85)*U2(51))+HESS(690)*(U1(52)*U2(85))+HESS(690)*(U1(85)*U2(52))& + &+HESS(691)*(U1(53)*U2(85))+HESS(691)*(U1(85)*U2(53))+HESS(692)*(U1(54)*U2(85))+HESS(692)*(U1(85)*U2(54))& + &+HESS(693)*(U1(55)*U2(85))+HESS(693)*(U1(85)*U2(55))+HESS(694)*(U1(57)*U2(85))+HESS(694)*(U1(85)*U2(57))& + &+HESS(695)*(U1(59)*U2(85))+HESS(695)*(U1(85)*U2(59))+HESS(696)*(U1(60)*U2(85))+HESS(696)*(U1(85)*U2(60))& + &+HESS(697)*(U1(62)*U2(85))+HESS(697)*(U1(85)*U2(62))+HESS(698)*(U1(63)*U2(85))+HESS(698)*(U1(85)*U2(63))& + &+HESS(699)*(U1(64)*U2(85))+HESS(699)*(U1(85)*U2(64))+HESS(700)*(U1(65)*U2(85))+HESS(700)*(U1(85)*U2(65))& + &+HESS(701)*(U1(66)*U2(85))+HESS(701)*(U1(85)*U2(66))+HESS(702)*(U1(67)*U2(85))+HESS(702)*(U1(85)*U2(67))& + &+HESS(703)*(U1(70)*U2(85))+HESS(703)*(U1(85)*U2(70))+HESS(704)*(U1(72)*U2(85))+HESS(704)*(U1(85)*U2(72))& + &+HESS(705)*(U1(74)*U2(85))+HESS(705)*(U1(85)*U2(74))+HESS(706)*(U1(78)*U2(85))+HESS(706)*(U1(85)*U2(78))& + &+HESS(707)*(U1(79)*U2(85))+HESS(707)*(U1(85)*U2(79))+HESS(708)*(U1(81)*U2(85))+HESS(708)*(U1(85)*U2(81))& + &+HESS(709)*(U1(82)*U2(87))+HESS(709)*(U1(87)*U2(82))+HESS(710)*(U1(83)*U2(85))+HESS(710)*(U1(85)*U2(83))& + &+HESS(711)*(U1(84)*U2(85))+HESS(711)*(U1(85)*U2(84))+HESS(712)*(U1(85)*U2(86))+HESS(712)*(U1(86)*U2(85))& + &+HESS(713)*(U1(85)*U2(87))+HESS(713)*(U1(87)*U2(85))+HESS(714)*(U1(85)*U2(88))+HESS(714)*(U1(88)*U2(85))& + &+HESS(715)*(U1(85)*U2(89))+HESS(715)*(U1(89)*U2(85))+HESS(716)*(U1(85)*U2(90))+HESS(716)*(U1(90)*U2(85)) + HU(86) = HESS(717)*(U1(27)*U2(83))+HESS(717)*(U1(83)*U2(27))+HESS(718)*(U1(51)*U2(85))+HESS(718)*(U1(85)*U2(51))& + &+HESS(719)*(U1(51)*U2(86))+HESS(719)*(U1(86)*U2(51))+HESS(720)*(U1(51)*U2(90))+HESS(720)*(U1(90)*U2(51))& + &+HESS(721)*(U1(52)*U2(86))+HESS(721)*(U1(86)*U2(52))+HESS(722)*(U1(53)*U2(86))+HESS(722)*(U1(86)*U2(53))& + &+HESS(723)*(U1(54)*U2(86))+HESS(723)*(U1(86)*U2(54))+HESS(724)*(U1(55)*U2(86))+HESS(724)*(U1(86)*U2(55))& + &+HESS(725)*(U1(57)*U2(86))+HESS(725)*(U1(86)*U2(57))+HESS(726)*(U1(59)*U2(86))+HESS(726)*(U1(86)*U2(59))& + &+HESS(727)*(U1(60)*U2(85))+HESS(727)*(U1(85)*U2(60))+HESS(728)*(U1(60)*U2(86))+HESS(728)*(U1(86)*U2(60))& + &+HESS(729)*(U1(60)*U2(90))+HESS(729)*(U1(90)*U2(60))+HESS(730)*(U1(62)*U2(84))+HESS(730)*(U1(84)*U2(62))& + &+HESS(731)*(U1(62)*U2(85))+HESS(731)*(U1(85)*U2(62))+HESS(732)*(U1(62)*U2(86))+HESS(732)*(U1(86)*U2(62))& + &+HESS(733)*(U1(62)*U2(90))+HESS(733)*(U1(90)*U2(62))+HESS(734)*(U1(63)*U2(86))+HESS(734)*(U1(86)*U2(63))& + &+HESS(735)*(U1(64)*U2(85))+HESS(735)*(U1(85)*U2(64))+HESS(736)*(U1(64)*U2(86))+HESS(736)*(U1(86)*U2(64))& + &+HESS(737)*(U1(64)*U2(90))+HESS(737)*(U1(90)*U2(64))+HESS(738)*(U1(65)*U2(86))+HESS(738)*(U1(86)*U2(65))& + &+HESS(739)*(U1(66)*U2(86))+HESS(739)*(U1(86)*U2(66))+HESS(740)*(U1(67)*U2(86))+HESS(740)*(U1(86)*U2(67))& + &+HESS(741)*(U1(70)*U2(86))+HESS(741)*(U1(86)*U2(70))+HESS(742)*(U1(71)*U2(83))+HESS(742)*(U1(83)*U2(71))& + &+HESS(743)*(U1(71)*U2(87))+HESS(743)*(U1(87)*U2(71))+HESS(744)*(U1(72)*U2(86))+HESS(744)*(U1(86)*U2(72))& + &+HESS(745)*(U1(74)*U2(86))+HESS(745)*(U1(86)*U2(74))+HESS(746)*(U1(75)*U2(83))+HESS(746)*(U1(83)*U2(75))& + &+HESS(747)*(U1(75)*U2(87))+HESS(747)*(U1(87)*U2(75))+HESS(748)*(U1(78)*U2(85))+HESS(748)*(U1(85)*U2(78))& + &+HESS(749)*(U1(78)*U2(90))+HESS(749)*(U1(90)*U2(78))+HESS(750)*(U1(79)*U2(86))+HESS(750)*(U1(86)*U2(79))& + &+HESS(751)*(U1(81)*U2(86))+HESS(751)*(U1(86)*U2(81))+HESS(752)*(U1(82)*U2(86))+HESS(752)*(U1(86)*U2(82))& + &+HESS(753)*(U1(84)*U2(86))+HESS(753)*(U1(86)*U2(84))+HESS(754)*(U1(85)*U2(86))+HESS(754)*(U1(86)*U2(85))& + &+HESS(755)*(U1(86)*U2(86))+HESS(756)*(U1(86)*U2(88))+HESS(756)*(U1(88)*U2(86))+HESS(757)*(U1(86)*U2(90))& + &+HESS(757)*(U1(90)*U2(86)) + HU(87) = HESS(758)*(U1(22)*U2(87))+HESS(758)*(U1(87)*U2(22))+HESS(759)*(U1(23)*U2(87))+HESS(759)*(U1(87)*U2(23))& + &+HESS(760)*(U1(34)*U2(87))+HESS(760)*(U1(87)*U2(34))+HESS(761)*(U1(46)*U2(87))+HESS(761)*(U1(87)*U2(46))& + &+HESS(762)*(U1(48)*U2(87))+HESS(762)*(U1(87)*U2(48))+HESS(763)*(U1(56)*U2(83))+HESS(763)*(U1(83)*U2(56))& + &+HESS(764)*(U1(68)*U2(87))+HESS(764)*(U1(87)*U2(68))+HESS(765)*(U1(69)*U2(87))+HESS(765)*(U1(87)*U2(69))& + &+HESS(766)*(U1(71)*U2(87))+HESS(766)*(U1(87)*U2(71))+HESS(767)*(U1(75)*U2(87))+HESS(767)*(U1(87)*U2(75))& + &+HESS(768)*(U1(76)*U2(87))+HESS(768)*(U1(87)*U2(76))+HESS(769)*(U1(80)*U2(87))+HESS(769)*(U1(87)*U2(80))& + &+HESS(770)*(U1(82)*U2(87))+HESS(770)*(U1(87)*U2(82))+HESS(771)*(U1(82)*U2(89))+HESS(771)*(U1(89)*U2(82))& + &+HESS(772)*(U1(83)*U2(87))+HESS(772)*(U1(87)*U2(83))+HESS(773)*(U1(84)*U2(87))+HESS(773)*(U1(87)*U2(84))& + &+HESS(774)*(U1(85)*U2(87))+HESS(774)*(U1(87)*U2(85))+HESS(775)*(U1(87)*U2(87)) + HU(88) = HESS(776)*(U1(36)*U2(83))+HESS(776)*(U1(83)*U2(36))+HESS(777)*(U1(50)*U2(83))+HESS(777)*(U1(83)*U2(50))& + &+HESS(778)*(U1(82)*U2(88))+HESS(778)*(U1(88)*U2(82))+HESS(779)*(U1(84)*U2(88))+HESS(779)*(U1(88)*U2(84))& + &+HESS(780)*(U1(85)*U2(88))+HESS(780)*(U1(88)*U2(85))+HESS(781)*(U1(86)*U2(88))+HESS(781)*(U1(88)*U2(86))& + &+HESS(782)*(U1(88)*U2(90))+HESS(782)*(U1(90)*U2(88)) + HU(89) = HESS(783)*(U1(44)*U2(89))+HESS(783)*(U1(89)*U2(44))+HESS(784)*(U1(46)*U2(89))+HESS(784)*(U1(89)*U2(46))& + &+HESS(785)*(U1(48)*U2(89))+HESS(785)*(U1(89)*U2(48))+HESS(786)*(U1(58)*U2(89))+HESS(786)*(U1(89)*U2(58))& + &+HESS(787)*(U1(77)*U2(89))+HESS(787)*(U1(89)*U2(77))+HESS(788)*(U1(78)*U2(84))+HESS(788)*(U1(84)*U2(78))& + &+HESS(789)*(U1(80)*U2(89))+HESS(789)*(U1(89)*U2(80))+HESS(790)*(U1(81)*U2(84))+HESS(790)*(U1(84)*U2(81))& + &+HESS(791)*(U1(82)*U2(89))+HESS(791)*(U1(89)*U2(82))+HESS(792)*(U1(83)*U2(83))+HESS(793)*(U1(83)*U2(89))& + &+HESS(793)*(U1(89)*U2(83))+HESS(794)*(U1(84)*U2(86))+HESS(794)*(U1(86)*U2(84))+HESS(795)*(U1(84)*U2(88))& + &+HESS(795)*(U1(88)*U2(84))+HESS(796)*(U1(84)*U2(89))+HESS(796)*(U1(89)*U2(84))+HESS(797)*(U1(85)*U2(89))& + &+HESS(797)*(U1(89)*U2(85))+HESS(798)*(U1(89)*U2(90))+HESS(798)*(U1(90)*U2(89)) + HU(90) = HESS(799)*(U1(28)*U2(83))+HESS(799)*(U1(83)*U2(28))+HESS(800)*(U1(34)*U2(83))+HESS(800)*(U1(83)*U2(34))& + &+HESS(801)*(U1(34)*U2(87))+HESS(801)*(U1(87)*U2(34))+HESS(802)*(U1(48)*U2(89))+HESS(802)*(U1(89)*U2(48))& + &+HESS(803)*(U1(51)*U2(86))+HESS(803)*(U1(86)*U2(51))+HESS(804)*(U1(51)*U2(90))+HESS(804)*(U1(90)*U2(51))& + &+HESS(805)*(U1(52)*U2(86))+HESS(805)*(U1(86)*U2(52))+HESS(806)*(U1(52)*U2(90))+HESS(806)*(U1(90)*U2(52))& + &+HESS(807)*(U1(53)*U2(86))+HESS(807)*(U1(86)*U2(53))+HESS(808)*(U1(53)*U2(90))+HESS(808)*(U1(90)*U2(53))& + &+HESS(809)*(U1(54)*U2(86))+HESS(809)*(U1(86)*U2(54))+HESS(810)*(U1(54)*U2(90))+HESS(810)*(U1(90)*U2(54))& + &+HESS(811)*(U1(55)*U2(86))+HESS(811)*(U1(86)*U2(55))+HESS(812)*(U1(55)*U2(90))+HESS(812)*(U1(90)*U2(55))& + &+HESS(813)*(U1(57)*U2(86))+HESS(813)*(U1(86)*U2(57))+HESS(814)*(U1(57)*U2(90))+HESS(814)*(U1(90)*U2(57))& + &+HESS(815)*(U1(59)*U2(86))+HESS(815)*(U1(86)*U2(59))+HESS(816)*(U1(59)*U2(90))+HESS(816)*(U1(90)*U2(59))& + &+HESS(817)*(U1(60)*U2(84))+HESS(817)*(U1(84)*U2(60))+HESS(818)*(U1(60)*U2(86))+HESS(818)*(U1(86)*U2(60))& + &+HESS(819)*(U1(60)*U2(90))+HESS(819)*(U1(90)*U2(60))+HESS(820)*(U1(62)*U2(84))+HESS(820)*(U1(84)*U2(62))& + &+HESS(821)*(U1(62)*U2(86))+HESS(821)*(U1(86)*U2(62))+HESS(822)*(U1(62)*U2(90))+HESS(822)*(U1(90)*U2(62))& + &+HESS(823)*(U1(63)*U2(86))+HESS(823)*(U1(86)*U2(63))+HESS(824)*(U1(63)*U2(90))+HESS(824)*(U1(90)*U2(63))& + &+HESS(825)*(U1(64)*U2(86))+HESS(825)*(U1(86)*U2(64))+HESS(826)*(U1(64)*U2(90))+HESS(826)*(U1(90)*U2(64))& + &+HESS(827)*(U1(65)*U2(86))+HESS(827)*(U1(86)*U2(65))+HESS(828)*(U1(65)*U2(90))+HESS(828)*(U1(90)*U2(65))& + &+HESS(829)*(U1(66)*U2(86))+HESS(829)*(U1(86)*U2(66))+HESS(830)*(U1(66)*U2(90))+HESS(830)*(U1(90)*U2(66))& + &+HESS(831)*(U1(67)*U2(86))+HESS(831)*(U1(86)*U2(67))+HESS(832)*(U1(67)*U2(90))+HESS(832)*(U1(90)*U2(67))& + &+HESS(833)*(U1(70)*U2(86))+HESS(833)*(U1(86)*U2(70))+HESS(834)*(U1(70)*U2(90))+HESS(834)*(U1(90)*U2(70))& + &+HESS(835)*(U1(72)*U2(85))+HESS(835)*(U1(85)*U2(72))+HESS(836)*(U1(72)*U2(86))+HESS(836)*(U1(86)*U2(72))& + &+HESS(837)*(U1(72)*U2(90))+HESS(837)*(U1(90)*U2(72))+HESS(838)*(U1(74)*U2(86))+HESS(838)*(U1(86)*U2(74))& + &+HESS(839)*(U1(74)*U2(90))+HESS(839)*(U1(90)*U2(74))+HESS(840)*(U1(78)*U2(86))+HESS(840)*(U1(86)*U2(78))& + &+HESS(841)*(U1(78)*U2(90))+HESS(841)*(U1(90)*U2(78))+HESS(842)*(U1(79)*U2(86))+HESS(842)*(U1(86)*U2(79))& + &+HESS(843)*(U1(79)*U2(90))+HESS(843)*(U1(90)*U2(79))+HESS(844)*(U1(81)*U2(86))+HESS(844)*(U1(86)*U2(81))& + &+HESS(845)*(U1(81)*U2(90))+HESS(845)*(U1(90)*U2(81))+HESS(846)*(U1(84)*U2(86))+HESS(846)*(U1(86)*U2(84))& + &+HESS(847)*(U1(84)*U2(90))+HESS(847)*(U1(90)*U2(84))+HESS(848)*(U1(85)*U2(86))+HESS(848)*(U1(86)*U2(85))& + &+HESS(849)*(U1(85)*U2(90))+HESS(849)*(U1(90)*U2(85))+HESS(850)*(U1(86)*U2(86))+HESS(851)*(U1(86)*U2(88))& + &+HESS(851)*(U1(88)*U2(86))+HESS(852)*(U1(86)*U2(90))+HESS(852)*(U1(90)*U2(86))+HESS(853)*(U1(88)*U2(90))& + &+HESS(853)*(U1(90)*U2(88))+HESS(854)*(U1(89)*U2(90))+HESS(854)*(U1(90)*U2(89))+HESS(855)*(U1(90)*U2(90)) + +END SUBROUTINE Hess_Vec + +! End of Hess_Vec function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +END MODULE gckpp_adj_Hessian + diff --git a/code/adjoint/gckpp_adj_HessianSP.f90 b/code/adjoint/gckpp_adj_HessianSP.f90 new file mode 100644 index 0000000..2d8b75a --- /dev/null +++ b/code/adjoint/gckpp_adj_HessianSP.f90 @@ -0,0 +1,270 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Sparse Hessian Data Structures File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_HessianSP.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_HessianSP + + PUBLIC + SAVE + + +! Hessian Sparse Data +! + + INTEGER, PARAMETER, DIMENSION(360) :: IHESS_I_0 = (/ & + 11, 12, 13, 13, 13, 13, 15, 16, 17, 17, 17, 18, & + 19, 20, 20, 20, 21, 22, 22, 23, 23, 24, 24, 25, & + 26, 26, 27, 27, 28, 28, 29, 29, 30, 30, 31, 31, & + 32, 32, 33, 33, 34, 34, 35, 35, 36, 36, 37, 37, & + 38, 38, 39, 39, 40, 40, 41, 41, 42, 42, 43, 43, & + 43, 43, 44, 44, 44, 45, 45, 45, 46, 46, 46, 47, & + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, & + 47, 47, 47, 47, 48, 48, 48, 48, 49, 49, 49, 49, & + 49, 49, 49, 49, 50, 50, 50, 50, 50, 50, 50, 50, & + 50, 50, 50, 50, 51, 51, 51, 51, 52, 52, 52, 52, & + 52, 52, 52, 52, 52, 53, 53, 53, 53, 53, 53, 53, & + 53, 53, 54, 54, 54, 54, 54, 55, 55, 55, 55, 55, & + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, & + 56, 56, 56, 56, 56, 56, 56, 56, 56, 57, 57, 57, & + 57, 57, 57, 58, 58, 58, 58, 58, 58, 58, 58, 58, & + 59, 59, 59, 59, 59, 59, 60, 60, 60, 60, 60, 60, & + 61, 61, 61, 61, 61, 61, 61, 61, 61, 61, 61, 61, & + 61, 61, 61, 62, 62, 62, 62, 62, 63, 63, 63, 63, & + 63, 63, 64, 64, 64, 64, 64, 64, 65, 65, 65, 65, & + 65, 66, 66, 66, 66, 66, 66, 67, 67, 67, 67, 67, & + 67, 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, & + 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, & + 68, 68, 68, 68, 69, 69, 69, 69, 69, 69, 69, 69, & + 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, & + 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, & + 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, & + 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, & + 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, & + 70, 70, 70, 70, 70, 70, 71, 71, 71, 71, 71, 71, & + 71, 71, 71, 71, 71, 71, 71, 71, 71, 71, 71, 71 /) + INTEGER, PARAMETER, DIMENSION(360) :: IHESS_I_1 = (/ & + 71, 71, 71, 71, 71, 71, 71, 72, 72, 72, 72, 72, & + 72, 72, 72, 72, 72, 73, 73, 73, 73, 73, 74, 74, & + 74, 74, 74, 74, 74, 74, 74, 74, 74, 74, 74, 74, & + 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, & + 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, 76, 76, & + 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, & + 76, 76, 76, 77, 77, 77, 77, 77, 77, 77, 77, 77, & + 78, 78, 78, 78, 78, 78, 78, 78, 78, 79, 79, 79, & + 79, 79, 79, 80, 80, 80, 80, 80, 80, 80, 80, 80, & + 80, 81, 81, 81, 81, 81, 81, 81, 81, 82, 82, 82, & + 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, & + 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, & + 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, & + 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, & + 82, 82, 82, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 85, 85, 85, 85, 85, 85, 85, 85, & + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, & + 85, 85, 85, 85, 85, 85, 85, 85, 86, 86, 86, 86 /) + INTEGER, PARAMETER, DIMENSION(135) :: IHESS_I_2 = (/ & + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, & + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, & + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, & + 86, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, & + 87, 87, 87, 87, 87, 87, 87, 88, 88, 88, 88, 88, & + 88, 88, 89, 89, 89, 89, 89, 89, 89, 89, 89, 89, & + 89, 89, 89, 89, 89, 89, 90, 90, 90, 90, 90, 90, & + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, & + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, & + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, & + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, & + 90, 90, 90 /) + INTEGER, PARAMETER, DIMENSION(855) :: IHESS_I = (/& + IHESS_I_0, IHESS_I_1, IHESS_I_2 /) + + INTEGER, PARAMETER, DIMENSION(360) :: IHESS_J_0 = (/ & + 20, 34, 46, 47, 80, 85, 46, 16, 17, 83, 84, 81, & + 82, 20, 34, 34, 82, 22, 22, 23, 23, 24, 83, 82, & + 26, 78, 27, 84, 28, 84, 29, 82, 30, 72, 31, 52, & + 32, 53, 33, 81, 34, 34, 35, 74, 36, 84, 37, 70, & + 38, 63, 39, 67, 40, 59, 41, 66, 42, 64, 43, 51, & + 55, 65, 44, 44, 78, 45, 57, 79, 46, 46, 46, 46, & + 47, 48, 50, 58, 59, 59, 66, 66, 66, 69, 69, 71, & + 75, 75, 77, 80, 46, 48, 48, 48, 32, 49, 53, 53, & + 53, 72, 72, 72, 50, 51, 58, 64, 64, 64, 65, 65, & + 65, 66, 66, 66, 51, 51, 51, 51, 16, 31, 52, 52, & + 52, 52, 72, 72, 72, 16, 32, 53, 53, 53, 53, 72, & + 72, 72, 54, 54, 54, 54, 73, 55, 55, 55, 55, 80, & + 22, 23, 34, 51, 56, 57, 59, 64, 65, 66, 67, 67, & + 67, 68, 69, 71, 75, 76, 79, 80, 82, 57, 57, 57, & + 57, 79, 79, 45, 57, 57, 57, 58, 58, 79, 79, 79, & + 40, 59, 59, 59, 59, 80, 60, 60, 60, 60, 76, 76, & + 44, 58, 59, 59, 59, 61, 62, 65, 65, 65, 66, 66, & + 66, 70, 70, 49, 62, 62, 62, 62, 38, 48, 63, 63, & + 63, 63, 42, 64, 64, 64, 64, 77, 43, 65, 65, 65, & + 65, 41, 58, 66, 66, 66, 66, 39, 46, 67, 67, 67, & + 67, 30, 31, 42, 43, 51, 51, 52, 52, 52, 54, 54, & + 54, 55, 55, 63, 63, 65, 65, 67, 67, 68, 68, 70, & + 70, 72, 72, 72, 27, 28, 34, 34, 44, 44, 46, 48, & + 51, 51, 51, 52, 53, 54, 54, 54, 55, 55, 55, 57, & + 57, 57, 58, 59, 59, 59, 60, 62, 62, 62, 63, 63, & + 63, 64, 64, 64, 65, 66, 66, 66, 67, 67, 67, 69, & + 69, 70, 70, 70, 71, 72, 74, 77, 78, 78, 78, 79, & + 79, 79, 80, 81, 84, 85, 85, 86, 86, 88, 89, 90, & + 37, 48, 70, 70, 70, 70, 33, 35, 48, 54, 54, 54, & + 60, 60, 60, 63, 63, 63, 70, 70, 70, 71, 71, 72 /) + INTEGER, PARAMETER, DIMENSION(360) :: IHESS_J_1 = (/ & + 72, 72, 74, 74, 74, 74, 77, 22, 22, 30, 54, 54, & + 54, 72, 72, 72, 72, 54, 60, 62, 72, 73, 23, 23, & + 35, 72, 72, 72, 74, 74, 74, 74, 74, 81, 81, 81, & + 51, 51, 51, 55, 55, 55, 58, 59, 60, 61, 62, 62, & + 64, 64, 64, 66, 66, 66, 75, 75, 77, 80, 57, 57, & + 59, 60, 60, 62, 64, 64, 66, 66, 72, 72, 72, 76, & + 76, 79, 79, 46, 67, 67, 67, 77, 77, 79, 79, 79, & + 26, 58, 78, 78, 78, 78, 78, 80, 80, 45, 46, 79, & + 79, 79, 79, 46, 67, 67, 67, 79, 79, 79, 80, 80, & + 80, 33, 68, 68, 81, 81, 81, 81, 81, 24, 29, 43, & + 44, 44, 51, 51, 51, 52, 53, 54, 54, 54, 55, 55, & + 55, 57, 59, 60, 62, 63, 63, 63, 64, 65, 65, 65, & + 66, 67, 67, 67, 70, 72, 74, 78, 78, 79, 81, 81, & + 82, 82, 82, 82, 82, 82, 83, 84, 84, 85, 85, 85, & + 85, 85, 87, 16, 17, 20, 22, 23, 24, 26, 27, 28, & + 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, & + 41, 42, 43, 44, 45, 46, 46, 47, 48, 48, 49, 50, & + 56, 58, 58, 61, 68, 69, 71, 73, 75, 76, 77, 77, & + 80, 80, 82, 83, 83, 83, 83, 83, 84, 84, 84, 84, & + 17, 20, 44, 44, 46, 47, 48, 50, 51, 51, 51, 51, & + 52, 52, 52, 52, 53, 53, 53, 53, 54, 54, 55, 55, & + 57, 57, 57, 57, 58, 59, 59, 59, 59, 60, 60, 61, & + 62, 62, 62, 63, 63, 64, 64, 64, 64, 65, 65, 65, & + 66, 66, 66, 66, 67, 67, 67, 67, 69, 69, 70, 70, & + 70, 70, 71, 72, 72, 72, 72, 74, 74, 74, 74, 74, & + 77, 78, 78, 79, 79, 79, 79, 80, 81, 81, 82, 83, & + 83, 83, 84, 84, 84, 84, 84, 84, 84, 85, 85, 86, & + 86, 88, 89, 90, 51, 52, 53, 54, 55, 57, 59, 60, & + 62, 63, 64, 65, 66, 67, 70, 72, 74, 78, 79, 81, & + 82, 83, 84, 85, 85, 85, 85, 85, 27, 51, 51, 51 /) + INTEGER, PARAMETER, DIMENSION(135) :: IHESS_J_2 = (/ & + 52, 53, 54, 55, 57, 59, 60, 60, 60, 62, 62, 62, & + 62, 63, 64, 64, 64, 65, 66, 67, 70, 71, 71, 72, & + 74, 75, 75, 78, 78, 79, 81, 82, 84, 85, 86, 86, & + 86, 22, 23, 34, 46, 48, 56, 68, 69, 71, 75, 76, & + 80, 82, 82, 83, 84, 85, 87, 36, 50, 82, 84, 85, & + 86, 88, 44, 46, 48, 58, 77, 78, 80, 81, 82, 83, & + 83, 84, 84, 84, 85, 89, 28, 34, 34, 48, 51, 51, & + 52, 52, 53, 53, 54, 54, 55, 55, 57, 57, 59, 59, & + 60, 60, 60, 62, 62, 62, 63, 63, 64, 64, 65, 65, & + 66, 66, 67, 67, 70, 70, 72, 72, 72, 74, 74, 78, & + 78, 79, 79, 81, 81, 84, 84, 85, 85, 86, 86, 86, & + 88, 89, 90 /) + INTEGER, PARAMETER, DIMENSION(855) :: IHESS_J = (/& + IHESS_J_0, IHESS_J_1, IHESS_J_2 /) + + INTEGER, PARAMETER, DIMENSION(360) :: IHESS_K_0 = (/ & + 83, 83, 89, 83, 89, 86, 83, 83, 83, 83, 84, 82, & + 88, 83, 83, 87, 86, 83, 87, 83, 87, 83, 85, 87, & + 83, 84, 83, 86, 83, 90, 83, 84, 83, 84, 83, 84, & + 83, 84, 83, 84, 83, 87, 83, 84, 83, 88, 83, 84, & + 83, 84, 83, 84, 83, 84, 83, 84, 83, 84, 83, 84, & + 84, 84, 83, 89, 82, 83, 84, 84, 83, 87, 89, 89, & + 83, 89, 83, 89, 86, 90, 85, 86, 90, 83, 87, 83, & + 83, 87, 89, 89, 89, 83, 87, 89, 83, 83, 85, 86, & + 90, 85, 86, 90, 83, 85, 89, 85, 86, 90, 85, 86, & + 90, 85, 86, 90, 84, 85, 86, 90, 83, 83, 84, 85, & + 86, 90, 85, 86, 90, 83, 83, 84, 85, 86, 90, 85, & + 86, 90, 84, 85, 86, 90, 83, 84, 85, 86, 90, 87, & + 87, 87, 87, 85, 83, 85, 85, 85, 85, 85, 85, 86, & + 90, 87, 87, 87, 87, 87, 85, 87, 83, 84, 85, 86, & + 90, 86, 90, 83, 85, 86, 90, 83, 89, 85, 86, 90, & + 83, 84, 85, 86, 90, 83, 84, 85, 86, 90, 83, 87, & + 83, 89, 85, 86, 90, 83, 90, 85, 86, 90, 85, 86, & + 90, 86, 90, 83, 84, 85, 86, 90, 83, 87, 84, 85, & + 86, 90, 83, 84, 85, 86, 90, 83, 83, 84, 85, 86, & + 90, 83, 83, 84, 85, 86, 90, 83, 87, 84, 85, 86, & + 90, 83, 83, 83, 83, 86, 90, 85, 86, 90, 85, 86, & + 90, 86, 90, 86, 90, 86, 90, 86, 90, 83, 87, 86, & + 90, 85, 86, 90, 83, 83, 83, 87, 83, 89, 89, 89, & + 85, 86, 90, 90, 90, 85, 86, 90, 85, 86, 90, 85, & + 86, 90, 89, 85, 86, 90, 90, 85, 86, 90, 85, 86, & + 90, 85, 86, 90, 90, 85, 86, 90, 85, 86, 90, 83, & + 87, 85, 86, 90, 83, 90, 90, 89, 85, 86, 90, 85, & + 86, 90, 89, 90, 88, 88, 90, 88, 90, 90, 90, 90, & + 83, 83, 84, 85, 86, 90, 83, 83, 89, 85, 86, 90, & + 85, 86, 90, 85, 86, 90, 85, 86, 90, 83, 87, 85 /) + INTEGER, PARAMETER, DIMENSION(360) :: IHESS_K_1 = (/ & + 86, 90, 74, 85, 86, 90, 89, 83, 87, 83, 85, 86, & + 90, 84, 85, 86, 90, 84, 85, 85, 85, 83, 83, 87, & + 83, 85, 86, 90, 74, 84, 85, 86, 90, 85, 86, 90, & + 85, 86, 90, 85, 86, 90, 89, 86, 84, 83, 86, 90, & + 85, 86, 90, 85, 86, 90, 83, 87, 89, 89, 86, 90, & + 86, 86, 90, 86, 86, 90, 86, 90, 85, 86, 90, 83, & + 87, 86, 90, 89, 85, 86, 90, 83, 89, 85, 86, 90, & + 83, 83, 82, 84, 85, 86, 90, 83, 87, 83, 83, 84, & + 85, 86, 90, 89, 85, 86, 90, 85, 86, 90, 83, 87, & + 89, 83, 83, 87, 82, 84, 85, 86, 90, 83, 83, 83, & + 83, 89, 85, 86, 90, 85, 85, 85, 86, 90, 85, 86, & + 90, 85, 85, 85, 85, 85, 86, 90, 85, 85, 86, 90, & + 85, 85, 86, 90, 85, 85, 85, 82, 85, 85, 82, 85, & + 83, 84, 86, 87, 88, 89, 87, 85, 87, 86, 87, 88, & + 89, 90, 87, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 83, 83, 89, 83, 83, 89, 83, 83, & + 83, 83, 89, 83, 83, 83, 83, 83, 83, 83, 83, 89, & + 83, 89, 83, 83, 84, 85, 87, 89, 85, 86, 87, 89, & + 83, 83, 83, 89, 89, 83, 89, 83, 84, 85, 86, 90, & + 84, 85, 86, 90, 84, 85, 86, 90, 84, 90, 84, 90, & + 84, 85, 86, 90, 83, 84, 85, 86, 90, 84, 90, 83, & + 84, 86, 90, 84, 90, 84, 85, 86, 90, 84, 85, 90, & + 84, 85, 86, 90, 84, 85, 86, 90, 83, 87, 84, 85, & + 86, 90, 83, 84, 85, 86, 90, 74, 84, 85, 86, 90, & + 89, 84, 90, 84, 85, 86, 90, 89, 84, 90, 84, 84, & + 87, 89, 84, 85, 86, 87, 88, 89, 90, 88, 90, 88, & + 90, 90, 90, 90, 85, 85, 85, 85, 85, 85, 85, 85, & + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, & + 87, 85, 85, 86, 87, 88, 89, 90, 83, 85, 86, 90 /) + INTEGER, PARAMETER, DIMENSION(135) :: IHESS_K_2 = (/ & + 86, 86, 86, 86, 86, 86, 85, 86, 90, 84, 85, 86, & + 90, 86, 85, 86, 90, 86, 86, 86, 86, 83, 87, 86, & + 86, 83, 87, 85, 90, 86, 86, 86, 86, 86, 86, 88, & + 90, 87, 87, 87, 87, 87, 83, 87, 87, 87, 87, 87, & + 87, 87, 89, 87, 87, 87, 87, 83, 83, 88, 88, 88, & + 88, 90, 89, 89, 89, 89, 89, 84, 89, 84, 89, 83, & + 89, 86, 88, 89, 89, 90, 83, 83, 87, 89, 86, 90, & + 86, 90, 86, 90, 86, 90, 86, 90, 86, 90, 86, 90, & + 84, 86, 90, 84, 86, 90, 86, 90, 86, 90, 86, 90, & + 86, 90, 86, 90, 86, 90, 85, 86, 90, 86, 90, 86, & + 90, 86, 90, 86, 90, 86, 90, 86, 90, 86, 88, 90, & + 90, 90, 90 /) + INTEGER, PARAMETER, DIMENSION(855) :: IHESS_K = (/& + IHESS_K_0, IHESS_K_1, IHESS_K_2 /) + + +END MODULE gckpp_adj_HessianSP + diff --git a/code/adjoint/gckpp_adj_Initialize.f90 b/code/adjoint/gckpp_adj_Initialize.f90 new file mode 100644 index 0000000..047e045 --- /dev/null +++ b/code/adjoint/gckpp_adj_Initialize.f90 @@ -0,0 +1,99 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Initialization File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Initialize.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_Initialize + + USE gckpp_adj_Parameters, ONLY: dp, NVAR, NFIX + IMPLICIT NONE + +CONTAINS + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Initialize - function to initialize concentrations +! Arguments : +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE Initialize ( ) + + + USE gckpp_adj_Global + USE gckpp_adj_Util, ONLY : Shuffle_user2kpp + USE gckpp_adj_Monitor + + INTEGER :: i + +! INLINED initializations + + CALL Shuffle_user2kpp(V_CSPEC,VAR) + + DO i = 1, NFIX + FIX(i) = 1.d0 + END DO + +! End INLINED initializations + + ! need to add this to the INLINED for OpenMP (dkh, 07/31/09) + DO I = 1, NVAR + C(I) = VAR(I) + ENDDO + DO I = 1, NFIX + C(NVAR+I) = FIX(I) + ENDDO + +END SUBROUTINE Initialize + +! End of Initialize function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Initialize_adj - function to initialize concentrations +! Arguments : +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE Initialize_adj ( ) + + + USE gckpp_adj_Global + USE gckpp_adj_Util, ONLY : Shuffle_user2kpp + USE gckpp_adj_Monitor + + INTEGER :: i + +! INLINED initializations + + CALL Shuffle_user2kpp(V_CSPEC_ADJ,VAR_ADJ) + +! End INLINED initializations + + +END SUBROUTINE Initialize_adj + +! End of Initialize function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +END MODULE gckpp_adj_Initialize + diff --git a/code/adjoint/gckpp_adj_Integrator.f90 b/code/adjoint/gckpp_adj_Integrator.f90 new file mode 100644 index 0000000..ea37604 --- /dev/null +++ b/code/adjoint/gckpp_adj_Integrator.f90 @@ -0,0 +1,2905 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Numerical Integrator (Time-Stepping) File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Integrator.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! INTEGRATE - Integrator routine +! Arguments : +! TIN - Start Time for Integration +! TOUT - End Time for Integration +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +! Discrete adjoints of Rosenbrock, ! +! for several Rosenbrock methods: ! +! * Ros2 ! +! * Ros3 ! +! * Ros4 ! +! * Rodas3 ! +! * Rodas4 ! +! By default the code employs the KPP sparse linear algebra routines ! +! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! +! ! +! (C) Adrian Sandu, August 2004 ! +! Virginia Polytechnic Institute and State University ! +! Contact: sandu@cs.vt.edu ! +! Revised by Philipp Miehe and Adrian Sandu, May 2006 ! +! Revised by Adrian Sandu, March 2008: ! +! added sensitivity w.r.t. rate coefficients, following D.K. Henze ! ! +! This implementation is part of KPP - the Kinetic PreProcessor ! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! + +MODULE gckpp_adj_Integrator + + USE gckpp_adj_Precision + USE gckpp_adj_Parameters + USE gckpp_adj_Global + USE gckpp_adj_LinearAlgebra + USE gckpp_adj_Rates + USE gckpp_adj_Function + USE gckpp_adj_Jacobian + USE gckpp_adj_Hessian + USE gckpp_adj_Util + + IMPLICIT NONE + PUBLIC + SAVE + +!~~~> Statistics on the work performed by the Rosenbrock method + INTEGER, PARAMETER :: Nfun=1, Njac=2, Nstp=3, Nacc=4, & + Nrej=5, Ndec=6, Nsol=7, Nsng=8, & + Ntexit=1, Nhexit=2, Nhnew = 3, & + Nierr=20 + + +CONTAINS ! Routines in the module gckpp_adj_Integrator + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE INTEGRATE_ADJ( NADJ, Y, Lambda, Lambda_R, & + TIN, TOUT, ATOL_adj, RTOL_adj, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Y - Concentrations + REAL(kind=dp) :: Y(NVAR) +!~~~> NADJ - No. of cost functionals for which adjoints +! are evaluated simultaneously +! If single cost functional is considered (like in +! most applications) simply set NADJ = 1 + INTEGER NADJ +!~~~> Lambda - Sensitivities w.r.t. concentrations +! Note: Lambda (1:NVAR,j) contains sensitivities of +! the j-th cost functional w.r.t. Y(1:NVAR), j=1...NADJ + REAL(kind=dp) :: Lambda(NVAR,NADJ) +!~~~> Lambda_R - Sensitivities w.r.t. rate coefficients +! of reactions JCOEFF(1) ... JCOEFF(NCOEFF) + REAL(kind=dp) :: Lambda_R(NCOEFF,NADJ) +!~~~> Time interval + REAL(kind=dp), INTENT(IN) :: TIN ! TIN - Start Time + REAL(kind=dp), INTENT(IN) :: TOUT ! TOUT - End Time +!~~~> Tolerances for adjoint calculations +! (used only for full continuous adjoint) + REAL(kind=dp), INTENT(IN) :: ATOL_adj(NVAR,NADJ), RTOL_adj(NVAR,NADJ) +!~~~> Optional input parameters and statistics + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + REAL(kind=dp), INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + REAL(kind=dp), INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + + REAL(kind=dp) :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20), IERR + + INTEGER, SAVE :: Ntotal + + + ICNTRL(1:20) = 0 + RCNTRL(1:20) = 0.0_dp + ISTATUS(1:20) = 0 + RSTATUS(1:20) = 0.0_dp + + +!~~~> fine-tune the integrator: +! ICNTRL(1) = 0 ! 0 = non-autonomous, 1 = autonomous +! ICNTRL(2) = 1 ! 0 = scalar, 1 = vector tolerances +! RCNTRL(3) = STEPMIN ! starting step +! ICNTRL(3) = 5 ! choice of the method for forward integration +! ICNTRL(6) = 1 ! choice of the method for continuous adjoint +! ICNTRL(7) = 2 ! 1=none, 2=discrete, 3=full continuous, 4=simplified continuous adjoint +! ICNTRL(8) = 1 ! Save fwd LU factorization: 0 = *don't* save, 1 = save + + + ! if optional parameters are given, and if they are >=0, then they overwrite default settings + IF (PRESENT(ICNTRL_U)) THEN + WHERE(ICNTRL_U(:) >= 0) ICNTRL(:) = ICNTRL_U(:) + END IF + IF (PRESENT(RCNTRL_U)) THEN + WHERE(RCNTRL_U(:) >= 0) RCNTRL(:) = RCNTRL_U(:) + END IF + + + CALL RosenbrockADJ(Y, NADJ, Lambda, Lambda_R, & + TIN, TOUT, & + ATOL, RTOL, ATOL_adj, RTOL_adj, & + RCNTRL, ICNTRL, RSTATUS, ISTATUS, IERR) + + +!~~~> Debug option: show number of steps +! Ntotal = Ntotal + ISTATUS(Nstp) +! WRITE(6,777) ISTATUS(Nstp),Ntotal,VAR(ind_O3),VAR(ind_NO2) +!777 FORMAT('NSTEPS=',I6,' (',I6,') O3=',E24.14,' NO2=',E24.14) + + IF (IERR < 0) THEN + print *,'RosenbrockADJ: Unsucessful step at T=', & + TIN,' (IERR=',IERR,')' + ! Now record IERR value in RSATUS(Niere) (dkh, 07/05/06) + ISTATUS(Nierr) = IERR + END IF + + STEPMIN = RSTATUS(Nhexit) + ! if optional parameters are given for output + ! copy to them to return information + IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) + IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) + +END SUBROUTINE INTEGRATE_ADJ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE RosenbrockADJ( Y, NADJ, Lambda, Lambda_R, & + Tstart, Tend, & + AbsTol, RelTol, AbsTol_adj, RelTol_adj, & + RCNTRL, ICNTRL, RSTATUS, ISTATUS, IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! ADJ = Adjoint of the Tangent Linear Model of a Rosenbrock Method +! +! Solves the system y'=F(t,y) using a RosenbrockADJ method defined by: +! +! G = 1/(H*gamma(1)) - Jac(t0,Y0) +! T_i = t0 + Alpha(i)*H +! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j +! G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + +! gamma(i)*dF/dT(t0, Y0) +! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j +! +! For details on RosenbrockADJ methods and their implementation consult: +! E. Hairer and G. Wanner +! "Solving ODEs II. Stiff and differential-algebraic problems". +! Springer series in computational mathematics, Springer-Verlag, 1996. +! The codes contained in the book inspired this implementation. +! +! (C) Adrian Sandu, August 2004 +! Virginia Polytechnic Institute and State University +! Contact: sandu@cs.vt.edu +! Revised by Philipp Miehe and Adrian Sandu, May 2006 +! This implementation is part of KPP - the Kinetic PreProcessor +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT ARGUMENTS: +! +!- Y(NVAR) = vector of initial conditions (at T=Tstart) +! NADJ -> dimension of linearized system, +! i.e. the number of sensitivity coefficients +!- Lambda(NVAR,NADJ) -> vector of initial sensitivity conditions (at T=Tstart) +!- [Tstart,Tend] = time range of integration +! (if Tstart>Tend the integration is performed backwards in time) +!- RelTol, AbsTol = user precribed accuracy +!- SUBROUTINE Fun( T, Y, Ydot ) = ODE function, +! returns Ydot = Y' = F(T,Y) +!- SUBROUTINE Jac( T, Y, Jcb ) = Jacobian of the ODE function, +! returns Jcb = dF/dY +!- ICNTRL(1:10) = integer inputs parameters +!- RCNTRL(1:10) = real inputs parameters +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT ARGUMENTS: +! +!- Y(NVAR) -> vector of final states (at T->Tend) +!- Lambda(NVAR,NADJ) -> vector of final sensitivities (at T=Tend) +!- ICNTRL(11:20) -> integer output parameters +!- RCNTRL(11:20) -> real output parameters +!- IERR -> job status upon return +! - succes (positive value) or failure (negative value) - +! = 1 : Success +! = -1 : Improper value for maximal no of steps +! = -2 : Selected RosenbrockADJ method not implemented +! = -3 : Hmin/Hmax/Hstart must be positive +! = -4 : FacMin/FacMax/FacRej must be positive +! = -5 : Improper tolerance values +! = -6 : No of steps exceeds maximum bound +! = -7 : Step size too small +! = -8 : Matrix is repeatedly singular +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) +! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) +! +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ICNTRL(3) -> selection of a particular Rosenbrock method +! = 0 : default method is Rodas3 +! = 1 : method is Ros2 +! = 2 : method is Ros3 +! = 3 : method is Ros4 +! = 4 : method is Rodas3 +! = 5: method is Rodas4 +! +! ICNTRL(4) -> maximum number of integration steps +! For ICNTRL(4)=0) the default value of BUFSIZE is used +! +! ICNTRL(6) -> selection of a particular Rosenbrock method for the +! continuous adjoint integration - for cts adjoint it +! can be different than the forward method ICNTRL(3) +! Note 1: to avoid interpolation errors (which can be huge!) +! it is recommended to use only ICNTRL(7) = 2 or 4 +! Note 2: the performance of the full continuous adjoint +! strongly depends on the forward solution accuracy Abs/RelTol +! +! ICNTRL(7) -> Type of adjoint algorithm +! = 0 : default is discrete adjoint ( of method ICNTRL(3) ) +! plus sensitivity w.r.t. reaction coefficients +! = 1 : no adjoint +! = 2 : discrete adjoint ( of method ICNTRL(3) ) +! plus sensitivity w.r.t. reaction coefficients +! = 3 : fully adaptive continuous adjoint ( with method ICNTRL(6) ) +! = 4 : simplified continuous adjoint ( with method ICNTRL(6) ) +! +! ICNTRL(8) -> checkpointing the LU factorization at each step: +! ICNTRL(8)=0 : do *not* save LU factorization (the default) +! ICNTRL(8)=1 : save LU factorization +! Note: if ICNTRL(7)=1 the LU factorization is *not* saved +! +!~~~> Real input parameters: +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! +! RCNTRL(3) -> Hstart, starting value for the integration step size +! +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! +! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) +! +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +! +! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller +! than ThetaMin the Jacobian is not recomputed; +! (default=0.001) +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT PARAMETERS: +! +! Note: each call to RosenbrockADJ adds the corrent no. of fcn calls +! to previous value of ISTATUS(1), and similar for the other params. +! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. +! +! ISTATUS(1) = No. of function calls +! ISTATUS(2) = No. of jacobian calls +! ISTATUS(3) = No. of steps +! ISTATUS(4) = No. of accepted steps +! ISTATUS(5) = No. of rejected steps (except at the beginning) +! ISTATUS(6) = No. of LU decompositions +! ISTATUS(7) = No. of forward/backward substitutions +! ISTATUS(8) = No. of singular matrix decompositions +! +! RSTATUS(1) -> Texit, the time corresponding to the +! computed Y upon return +! RSTATUS(2) -> Hexit, last accepted step before exit +! For multiple restarts, use Hexit as Hstart in the following run +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Arguments + REAL(kind=dp), INTENT(INOUT) :: Y(NVAR) + INTEGER, INTENT(IN) :: NADJ + REAL(kind=dp), INTENT(INOUT) :: Lambda(NVAR,NADJ) + REAL(kind=dp), INTENT(INOUT) :: Lambda_R(NCOEFF,NADJ) + REAL(kind=dp), INTENT(IN) :: Tstart,Tend + REAL(kind=dp), INTENT(IN) :: AbsTol(NVAR),RelTol(NVAR) + REAL(kind=dp), INTENT(IN) :: AbsTol_adj(NVAR,NADJ), RelTol_adj(NVAR,NADJ) + INTEGER, INTENT(IN) :: ICNTRL(20) + REAL(kind=dp), INTENT(IN) :: RCNTRL(20) + INTEGER, INTENT(INOUT) :: ISTATUS(20) + REAL(kind=dp), INTENT(INOUT) :: RSTATUS(20) + INTEGER, INTENT(OUT) :: IERR +!~~~> Parameters of the Rosenbrock method, up to 6 stages + INTEGER :: ros_S, rosMethod + INTEGER, PARAMETER :: RS2=1, RS3=2, RS4=3, RD3=4, RD4=5 + REAL(kind=dp) :: ros_A(15), ros_C(15), ros_M(6), ros_E(6), & + ros_Alpha(6), ros_Gamma(6), ros_ELO + LOGICAL :: ros_NewF(6) + CHARACTER(LEN=12) :: ros_Name +!~~~> Types of Adjoints Implemented + INTEGER, PARAMETER :: Adj_none = 1, Adj_discrete = 2, & + Adj_continuous = 3, Adj_simple_continuous = 4 +!~~~> Checkpoints in memory + ! Can make this much smaller (dkh, 01/06/10) + !INTEGER, PARAMETER :: bufsize = 200000 + INTEGER, PARAMETER :: bufsize = 4000 + ! Need to make stack_ptr THREADPRIVATE (dkh, 07/31/09) + !INTEGER :: stack_ptr = 0 ! last written entry + REAL(kind=dp), DIMENSION(:), POINTER :: chk_H, chk_T + REAL(kind=dp), DIMENSION(:,:), POINTER :: chk_Y, chk_K, chk_J + REAL(kind=dp), DIMENSION(:,:), POINTER :: chk_dY, chk_d2Y +!~~~> Local variables + REAL(kind=dp) :: Roundoff, FacMin, FacMax, FacRej, FacSafe + REAL(kind=dp) :: Hmin, Hmax, Hstart + REAL(kind=dp) :: Texit + INTEGER :: i, UplimTol, Max_no_steps + INTEGER :: IERR_SAVE + INTEGER :: AdjointType, CadjMethod + LOGICAL :: Autonomous, VectorTol, SaveLU +!~~~> Parameters + REAL(kind=dp), PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + REAL(kind=dp), PARAMETER :: DeltaMin = 1.0d-5 + +!~~~> Initialize statistics + ISTATUS(1:20) = 0 + RSTATUS(1:20) = ZERO + +!~~~> Autonomous or time dependent ODE. Default is time dependent. + Autonomous = .NOT.(ICNTRL(1) == 0) + +!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) +! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) + IF (ICNTRL(2) == 0) THEN + VectorTol = .TRUE. + UplimTol = NVAR + ELSE + VectorTol = .FALSE. + UplimTol = 1 + END IF + +!~~~> Initialize the particular Rosenbrock method selected + SELECT CASE (ICNTRL(3)) + CASE (1) + CALL Ros2 + CASE (2) + CALL Ros3 + CASE (3) + CALL Ros4 + CASE (0,4) + CALL Rodas3 + CASE (5) + CALL Rodas4 + CASE DEFAULT + PRINT * , 'Unknown Rosenbrock method: ICNTRL(3)=',ICNTRL(3) + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END SELECT + +!~~~> The maximum number of steps admitted + IF (ICNTRL(4) == 0) THEN + Max_no_steps = bufsize - 1 + ELSEIF (Max_no_steps > 0) THEN + Max_no_steps=ICNTRL(4) + ELSE + PRINT * ,'User-selected max no. of steps: ICNTRL(4)=',ICNTRL(4) + CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> The particular Rosenbrock method chosen for integrating the cts adjoint + IF (ICNTRL(6) == 0) THEN + CadjMethod = 4 + ELSEIF ( (ICNTRL(6) >= 1).AND.(ICNTRL(6) <= 5) ) THEN + CadjMethod = ICNTRL(6) + ELSE + PRINT * , 'Unknown CADJ Rosenbrock method: ICNTRL(6)=', CadjMethod + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> Discrete or continuous adjoint formulation + IF ( ICNTRL(7) == 0 ) THEN + AdjointType = Adj_discrete + ELSEIF ( (ICNTRL(7) >= 1).AND.(ICNTRL(7) <= 4) ) THEN + AdjointType = ICNTRL(7) + ELSE + PRINT * , 'User-selected adjoint type: ICNTRL(7)=', AdjointType + CALL ros_ErrorMsg(-9,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> Save or not the forward LU factorization + SaveLU = (ICNTRL(8) /= 0) + + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) + IF (RCNTRL(1) == ZERO) THEN + Hmin = ZERO + ELSEIF (RCNTRL(1) > ZERO) THEN + Hmin = RCNTRL(1) + ELSE + PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Upper bound on the step size: (positive value) + IF (RCNTRL(2) == ZERO) THEN + Hmax = ABS(Tend-Tstart) + ELSEIF (RCNTRL(2) > ZERO) THEN + Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) + ELSE + PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Starting step size: (positive value) + IF (RCNTRL(3) == ZERO) THEN + Hstart = MAX(Hmin,DeltaMin) + ELSEIF (RCNTRL(3) > ZERO) THEN + Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) + ELSE + PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Step size can be changed s.t. FacMin < Hnew/Hold < FacMax + IF (RCNTRL(4) == ZERO) THEN + FacMin = 0.2d0 + ELSEIF (RCNTRL(4) > ZERO) THEN + FacMin = RCNTRL(4) + ELSE + PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF + IF (RCNTRL(5) == ZERO) THEN + FacMax = 6.0d0 + ELSEIF (RCNTRL(5) > ZERO) THEN + FacMax = RCNTRL(5) + ELSE + PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections + IF (RCNTRL(6) == ZERO) THEN + FacRej = 0.1d0 + ELSEIF (RCNTRL(6) > ZERO) THEN + FacRej = RCNTRL(6) + ELSE + PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacSafe: Safety Factor in the computation of new step size + IF (RCNTRL(7) == ZERO) THEN + FacSafe = 0.9d0 + ELSEIF (RCNTRL(7) > ZERO) THEN + FacSafe = RCNTRL(7) + ELSE + PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Check if tolerances are reasonable + DO i=1,UplimTol + IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.d0*Roundoff) & + .OR. (RelTol(i) >= 1.0d0) ) THEN + PRINT * , ' AbsTol(',i,') = ',AbsTol(i) + PRINT * , ' RelTol(',i,') = ',RelTol(i) + CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR) + RETURN + END IF + END DO + + +!~~~> Allocate checkpoint space or open checkpoint files + IF (AdjointType == Adj_discrete) THEN + CALL ros_AllocateDBuffers( ros_S ) + ELSEIF ( (AdjointType == Adj_continuous).OR. & + (AdjointType == Adj_simple_continuous) ) THEN + CALL ros_AllocateCBuffers + END IF + +!~~~> CALL Forward Rosenbrock method + CALL ros_FwdInt(Y,Tstart,Tend,Texit, & + AbsTol, RelTol, & +! Error indicator + IERR) + +!!$ PRINT*,'FORWARD STATISTICS' +!!$ PRINT*,'Step=',Nstp,' Acc=',Nacc, & +!!$ ' Rej=',Nrej, ' Singular=',Nsng + +! Now contiue to avoid having adjoint arrays become corrupt (dkh, 07/08/11, adj32_004) +!~~~> If Forward integration failed return +! IF (IERR<0) RETURN +! but save a copy of the error stat + IERR_SAVE = IERR + +!~~~> Initialize the particular Rosenbrock method for continuous adjoint + IF ( (AdjointType == Adj_continuous).OR. & + (AdjointType == Adj_simple_continuous) ) THEN + SELECT CASE (CadjMethod) + CASE (1) + CALL Ros2 + CASE (2) + CALL Ros3 + CASE (3) + CALL Ros4 + CASE (4) + CALL Rodas3 + CASE (5) + CALL Rodas4 + CASE DEFAULT + PRINT * , 'Unknown Rosenbrock method: ICNTRL(3)=', ICNTRL(3) + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END SELECT + END IF + + SELECT CASE (AdjointType) + CASE (Adj_discrete) + CALL ros_DadjRateInt ( & + NADJ, Lambda, Lambda_R, & + Tstart, Tend, Texit, & + IERR ) + CASE (Adj_continuous) + CALL ros_CadjInt ( & + NADJ, Lambda, & + Tend, Tstart, Texit, & + AbsTol_adj, RelTol_adj, & + IERR ) + CASE (Adj_simple_continuous) + CALL ros_SimpleCadjInt ( & + NADJ, Lambda, & + Tstart, Tend, Texit, & + IERR ) + END SELECT ! AdjointType + +!!$ PRINT*,'ADJOINT STATISTICS' +!!$ PRINT*,'Step=',Nstp,' Acc=',Nacc, & +!!$ ' Rej=',Nrej, ' Singular=',Nsng + +!~~~> Free checkpoint space or close checkpoint files + IF (AdjointType == Adj_discrete) THEN + CALL ros_FreeDBuffers + ELSEIF ( (AdjointType == Adj_continuous) .OR. & + (AdjointType == Adj_simple_continuous) ) THEN + CALL ros_FreeCBuffers + END IF + + + ! replace with original error stat from fwd int dkh + IERR = IERR_SAVE + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS ! Procedures internal to RosenbrockADJ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_AllocateDBuffers( S ) +!~~~> Allocate buffer space for discrete adjoint +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INTEGER :: i, S + + ALLOCATE( chk_H(bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer H'; STOP + END IF + ALLOCATE( chk_T(bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer T'; STOP + END IF + ALLOCATE( chk_Y(NVAR*S,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer Y'; STOP + END IF + ALLOCATE( chk_K(NVAR*S,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer K'; STOP + END IF + IF (SaveLU) THEN +#ifdef FULL_ALGEBRA + ALLOCATE( chk_J(NVAR*NVAR,bufsize), STAT=i ) +#else + ALLOCATE( chk_J(LU_NONZERO,bufsize), STAT=i ) +#endif + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer J'; STOP + END IF + END IF + + END SUBROUTINE ros_AllocateDBuffers + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FreeDBuffers +!~~~> Dallocate buffer space for discrete adjoint +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INTEGER :: i + + DEALLOCATE( chk_H, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer H'; STOP + END IF + DEALLOCATE( chk_T, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer T'; STOP + END IF + DEALLOCATE( chk_Y, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer Y'; STOP + END IF + DEALLOCATE( chk_K, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer K'; STOP + END IF + IF (SaveLU) THEN + DEALLOCATE( chk_J, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer J'; STOP + END IF + END IF + + END SUBROUTINE ros_FreeDBuffers + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_AllocateCBuffers +!~~~> Allocate buffer space for continuous adjoint +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INTEGER :: i + + ALLOCATE( chk_H(bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer H'; STOP + END IF + ALLOCATE( chk_T(bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer T'; STOP + END IF + ALLOCATE( chk_Y(NVAR,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer Y'; STOP + END IF + ALLOCATE( chk_dY(NVAR,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer dY'; STOP + END IF + ALLOCATE( chk_d2Y(NVAR,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer d2Y'; STOP + END IF + + END SUBROUTINE ros_AllocateCBuffers + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FreeCBuffers +!~~~> Dallocate buffer space for continuous adjoint +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INTEGER :: i + + DEALLOCATE( chk_H, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer H'; STOP + END IF + DEALLOCATE( chk_T, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer T'; STOP + END IF + DEALLOCATE( chk_Y, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer Y'; STOP + END IF + DEALLOCATE( chk_dY, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer dY'; STOP + END IF + DEALLOCATE( chk_d2Y, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer d2Y'; STOP + END IF + + END SUBROUTINE ros_FreeCBuffers + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_DPush( S, T, H, Ystage, K, E, P ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Saves the next trajectory snapshot for discrete adjoints +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INTEGER :: S ! no of stages + REAL(kind=dp) :: T, H, Ystage(NVAR*S), K(NVAR*S) + INTEGER :: P(NVAR) +#ifdef FULL_ALGEBRA + REAL(kind=dp) :: E(NVAR,NVAR) +#else + REAL(kind=dp) :: E(LU_NONZERO) +#endif + + stack_ptr = stack_ptr + 1 + IF ( stack_ptr > bufsize ) THEN + PRINT*,'Push failed: buffer overflow' + STOP + END IF + chk_H( stack_ptr ) = H + chk_T( stack_ptr ) = T + !CALL WCOPY(NVAR*S,Ystage,1,chk_Y(1,stack_ptr),1) + !CALL WCOPY(NVAR*S,K,1,chk_K(1,stack_ptr),1) + chk_Y(1:NVAR*S,stack_ptr) = Ystage(1:NVAR*S) + chk_K(1:NVAR*S,stack_ptr) = K(1:NVAR*S) + IF (SaveLU) THEN +#ifdef FULL_ALGEBRA + chk_J(1:NVAR,1:NVAR,stack_ptr) = E(1:NVAR,1:NVAR) + chk_P(1:NVAR,stack_ptr) = P(1:NVAR) +#else + chk_J(1:LU_NONZERO,stack_ptr) = E(1:LU_NONZERO) +#endif + END IF + + END SUBROUTINE ros_DPush + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_DPop( S, T, H, Ystage, K, E, P ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Retrieves the next trajectory snapshot for discrete adjoints +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + INTEGER :: S ! no of stages + REAL(kind=dp) :: T, H, Ystage(NVAR*S), K(NVAR*S) + INTEGER :: P(NVAR) +#ifdef FULL_ALGEBRA + REAL(kind=dp) :: E(NVAR,NVAR) +#else + REAL(kind=dp) :: E(LU_NONZERO) +#endif + + IF ( stack_ptr <= 0 ) THEN + PRINT*,'Pop failed: empty buffer' + STOP + END IF + H = chk_H( stack_ptr ) + T = chk_T( stack_ptr ) + !CALL WCOPY(NVAR*S,chk_Y(1,stack_ptr),1,Ystage,1) + !CALL WCOPY(NVAR*S,chk_K(1,stack_ptr),1,K,1) + Ystage(1:NVAR*S) = chk_Y(1:NVAR*S,stack_ptr) + K(1:NVAR*S) = chk_K(1:NVAR*S,stack_ptr) + !CALL WCOPY(LU_NONZERO,chk_J(1,stack_ptr),1,Jcb,1) + IF (SaveLU) THEN +#ifdef FULL_ALGEBRA + E(1:NVAR,1:NVAR) = chk_J(1:NVAR,1:NVAR,stack_ptr) + P(1:NVAR) = chk_P(1:NVAR,stack_ptr) +#else + E(1:LU_NONZERO) = chk_J(1:LU_NONZERO,stack_ptr) +#endif + END IF + + stack_ptr = stack_ptr - 1 + + END SUBROUTINE ros_DPop + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_CPush( T, H, Y, dY, d2Y ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Saves the next trajectory snapshot for discrete adjoints +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + REAL(kind=dp) :: T, H, Y(NVAR), dY(NVAR), d2Y(NVAR) + + stack_ptr = stack_ptr + 1 + IF ( stack_ptr > bufsize ) THEN + PRINT*,'Push failed: buffer overflow' + STOP + END IF + chk_H( stack_ptr ) = H + chk_T( stack_ptr ) = T + !CALL WCOPY(NVAR,Y,1,chk_Y(1,stack_ptr),1) + !CALL WCOPY(NVAR,dY,1,chk_dY(1,stack_ptr),1) + !CALL WCOPY(NVAR,d2Y,1,chk_d2Y(1,stack_ptr),1) + chk_Y(1:NVAR,stack_ptr) = Y(1:NVAR) + chk_dY(1:NVAR,stack_ptr) = dY(1:NVAR) + chk_d2Y(1:NVAR,stack_ptr) = d2Y(1:NVAR) + END SUBROUTINE ros_CPush + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_CPop( T, H, Y, dY, d2Y ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Retrieves the next trajectory snapshot for discrete adjoints +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + REAL(kind=dp) :: T, H, Y(NVAR), dY(NVAR), d2Y(NVAR) + + IF ( stack_ptr <= 0 ) THEN + PRINT*,'Pop failed: empty buffer' + STOP + END IF + H = chk_H( stack_ptr ) + T = chk_T( stack_ptr ) + !CALL WCOPY(NVAR,chk_Y(1,stack_ptr),1,Y,1) + !CALL WCOPY(NVAR,chk_dY(1,stack_ptr),1,dY,1) + !CALL WCOPY(NVAR,chk_d2Y(1,stack_ptr),1,d2Y,1) + Y(1:NVAR) = chk_Y(1:NVAR,stack_ptr) + dY(1:NVAR) = chk_dY(1:NVAR,stack_ptr) + d2Y(1:NVAR) = chk_d2Y(1:NVAR,stack_ptr) + + stack_ptr = stack_ptr - 1 + + END SUBROUTINE ros_CPop + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + REAL(kind=dp), INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from RosenbrockADJ due to the following error:' + + SELECT CASE (Code) + CASE (-1) + PRINT * , '--> Improper value for maximal no of steps' + CASE (-2) + PRINT * , '--> Selected RosenbrockADJ method not implemented' + CASE (-3) + PRINT * , '--> Hmin/Hmax/Hstart must be positive' + CASE (-4) + PRINT * , '--> FacMin/FacMax/FacRej must be positive' + CASE (-5) + PRINT * , '--> Improper tolerance values' + CASE (-6) + PRINT * , '--> No of steps exceeds maximum buffer bound' + CASE (-7) + PRINT * , '--> Step size too small: T + 10*H = T', & + ' or H < Roundoff' + CASE (-8) + PRINT * , '--> Matrix is repeatedly singular' + CASE (-9) + PRINT * , '--> Improper type of adjoint selected' + CASE DEFAULT + PRINT *, 'Unknown Error code: ', Code + END SELECT + + PRINT *, 'T=', T, 'and H=', H + + END SUBROUTINE ros_ErrorMsg + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FwdInt (Y, & + Tstart, Tend, T, & + AbsTol, RelTol, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic RosenbrockADJ method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + REAL(kind=dp), INTENT(INOUT) :: Y(NVAR) +!~~~> Input: integration interval + REAL(kind=dp), INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + REAL(kind=dp), INTENT(OUT) :: T +!~~~> Input: tolerances + REAL(kind=dp), INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + REAL(kind=dp) :: Ynew(NVAR), Fcn0(NVAR), Fcn(NVAR) + REAL(kind=dp) :: K(NVAR*ros_S), dFdT(NVAR) + REAL(kind=dp), DIMENSION(:), POINTER :: Ystage +#ifdef FULL_ALGEBRA + REAL(kind=dp) :: Jac0(NVAR,NVAR), Ghimj(NVAR,NVAR) +#else + REAL(kind=dp) :: Jac0(LU_NONZERO), Ghimj(LU_NONZERO) +#endif + REAL(kind=dp) :: H, Hnew, HC, HG, Fac, Tau + REAL(kind=dp) :: Err, Yerr(NVAR) + INTEGER :: Pivot(NVAR), Direction, ioffset, i, j, istage + LOGICAL :: RejectLastH, RejectMoreH, Singular +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Allocate stage vector buffer if needed + IF (AdjointType == Adj_discrete) THEN + ALLOCATE(Ystage(NVAR*ros_S), STAT=i) + ! Uninitialized Ystage may lead to NaN on some compilers + Ystage = 0.0d0 + IF (i/=0) THEN + PRINT*,'Allocation of Ystage failed' + STOP + END IF + END IF + +!~~~> Initial preparations + T = Tstart + RSTATUS(Nhexit) = ZERO + H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , ABS(Hmax) ) + IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + H = Direction*H + + RejectLastH=.FALSE. + RejectMoreH=.FALSE. + +!~~~> Time loop begins below + +TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff*abs(Tend) <= ZERO) & + .OR. (Direction < 0).AND.((Tend-T)+Roundoff*abs(Tend) <= ZERO) ) ! Added *abs(Tend) by KS, A.Sandu for boundary cases + + IF ( ISTATUS(Nstp) > Max_no_steps ) THEN ! Too many steps + CALL ros_ErrorMsg(-6,T,H,IERR) + RETURN + END IF + IF ( ((T+0.1d0*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small + CALL ros_ErrorMsg(-7,T,H,IERR) + RETURN + END IF + +!~~~> Limit H if necessary to avoid going beyond Tend + RSTATUS(Nhexit) = H + H = MIN(H,ABS(Tend-T)) + +!~~~> Compute the function at current time + CALL FunTemplate(T,Y,Fcn0) + ISTATUS(Nfun) = ISTATUS(Nfun) + 1 + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL ros_FunTimeDerivative ( T, Roundoff, Y, & + Fcn0, dFdT ) + END IF + +!~~~> Compute the Jacobian at current time + CALL JacTemplate(T,Y,Jac0) + ISTATUS(Njac) = ISTATUS(Njac) + 1 + +!~~~> Repeat step calculation until current step accepted +UntilAccepted: DO + + CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1), & + Jac0,Ghimj,Pivot,Singular) + IF (Singular) THEN ! More than 5 consecutive failed decompositions + CALL ros_ErrorMsg(-8,T,H,IERR) + RETURN + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + CALL WCOPY(NVAR,Fcn0,1,Fcn,1) + IF (AdjointType == Adj_discrete) THEN ! Save stage solution + ! CALL WCOPY(NVAR,Y,1,Ystage(1),1) + Ystage(1:NVAR) = Y(1:NVAR) + CALL WCOPY(NVAR,Y,1,Ynew,1) + END IF + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL WCOPY(NVAR,Y,1,Ynew,1) + DO j = 1, istage-1 + CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1),1,Ynew,1) + END DO + Tau = T + ros_Alpha(istage)*Direction*H + CALL FunTemplate(Tau,Ynew,Fcn) + ISTATUS(Nfun) = ISTATUS(Nfun) + 1 + END IF ! if istage == 1 elseif ros_NewF(istage) + ! save stage solution every time even if ynew is not updated + IF ( ( istage > 1 ).AND.(AdjointType == Adj_discrete) ) THEN + ! CALL WCOPY(NVAR,Ynew,1,Ystage(ioffset+1),1) + Ystage(ioffset+1:ioffset+NVAR) = Ynew(1:NVAR) + END IF + CALL WCOPY(NVAR,Fcn,1,K(ioffset+1),1) + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1),1,K(ioffset+1),1) + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + CALL WAXPY(NVAR,HG,dFdT,1,K(ioffset+1),1) + END IF + CALL ros_Solve('N', Ghimj, Pivot, K(ioffset+1)) + + END DO Stage + + +!~~~> Compute the new solution + CALL WCOPY(NVAR,Y,1,Ynew,1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1),1,Ynew,1) + END DO + +!~~~> Compute the error estimation + CALL WSCAL(NVAR,ZERO,Yerr,1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1),1,Yerr,1) + END DO + Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) + +!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax + Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) + Hnew = H*Fac + +!~~~> Check the error magnitude and adjust step size + ISTATUS(Nstp) = ISTATUS(Nstp) + 1 + IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step + ISTATUS(Nacc) = ISTATUS(Nacc) + 1 + IF (AdjointType == Adj_discrete) THEN ! Save current state + CALL ros_DPush( ros_S, T, H, Ystage, K, Ghimj, Pivot ) + ELSEIF ( (AdjointType == Adj_continuous) .OR. & + (AdjointType == Adj_simple_continuous) ) THEN +#ifdef FULL_ALGEBRA + K = MATMUL(Jac0,Fcn0) +#else + CALL Jac_SP_Vec( Jac0, Fcn0, K(1) ) +#endif + IF (.NOT. Autonomous) THEN + CALL WAXPY(NVAR,ONE,dFdT,1,K(1),1) + END IF + CALL ros_CPush( T, H, Y, Fcn0, K(1) ) + END IF + CALL WCOPY(NVAR,Ynew,1,Y,1) + T = T + Direction*H + Hnew = MAX(Hmin,MIN(Hnew,Hmax)) + IF (RejectLastH) THEN ! No step size increase after a rejected step + Hnew = MIN(Hnew,H) + END IF + RSTATUS(Nhexit) = H + RSTATUS(Nhnew) = Hnew + RSTATUS(Ntexit) = T + RejectLastH = .FALSE. + RejectMoreH = .FALSE. + H = Hnew + EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED + ELSE !~~~> Reject step + IF (RejectMoreH) THEN + Hnew = H*FacRej + END IF + RejectMoreH = RejectLastH + RejectLastH = .TRUE. + H = Hnew + IF (ISTATUS(Nacc) >= 1) THEN + ISTATUS(Nrej) = ISTATUS(Nrej) + 1 + END IF + END IF ! Err <= 1 + + END DO UntilAccepted + + END DO TimeLoop + +!~~~> Save last state: only needed for continuous adjoint + IF ( (AdjointType == Adj_continuous) .OR. & + (AdjointType == Adj_simple_continuous) ) THEN + CALL FunTemplate(T,Y,Fcn0) + ISTATUS(Nfun) = ISTATUS(Nfun) + 1 + CALL JacTemplate(T,Y,Jac0) + ISTATUS(Njac) = ISTATUS(Njac) + 1 +#ifdef FULL_ALGEBRA + K = MATMUL(Jac0,Fcn0) +#else + CALL Jac_SP_Vec( Jac0, Fcn0, K(1) ) +#endif + IF (.NOT. Autonomous) THEN + CALL ros_FunTimeDerivative ( T, Roundoff, Y, & + Fcn0, dFdT ) + CALL WAXPY(NVAR,ONE,dFdT,1,K(1),1) + END IF + CALL ros_CPush( T, H, Y, Fcn0, K(1) ) +!~~~> Deallocate stage buffer: only needed for discrete adjoint + ELSEIF (AdjointType == Adj_discrete) THEN + DEALLOCATE(Ystage, STAT=i) + IF (i/=0) THEN + PRINT*,'Deallocation of Ystage failed' + STOP + END IF + END IF + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + END SUBROUTINE ros_FwdInt + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_DadjRateInt ( & + NADJ, Lambda, Lambda_R, & + Tstart, Tend, T, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic RosenbrockADJ method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +! The adjoint sensitivity of the solution with respect to NCOEFF selected +! reaction rate coefficients JCOEFF(1:NCOEFF) is also included +! Note: works only for autonomous systems, with fixed (in time) RCOEFF +! Based on the implementation of Daven K. Henze +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Contains dFun_dRcoeff, dJac_dRcoeff + USE gckpp_adj_STOICHIOM + ! added logical switch (tww, 05/08/12) + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + INTEGER, INTENT(IN) :: NADJ +!~~~> First order adjoint + REAL(kind=dp), INTENT(INOUT) :: Lambda(NVAR,NADJ) +!!~~~> Input: integration interval + REAL(kind=dp), INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + REAL(kind=dp), INTENT(OUT) :: T +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + REAL(kind=dp) :: Ystage(NVAR*ros_S), K(NVAR*ros_S) + REAL(kind=dp) :: U(NVAR*ros_S,NADJ), V(NVAR*ros_S,NADJ) +#ifdef FULL_ALGEBRA + REAL(kind=dp), DIMENSION(NVAR,NVAR) :: Jac, dJdT, Ghimj +#else + REAL(kind=dp), DIMENSION(LU_NONZERO) :: Jac, dJdT, Ghimj +#endif + REAL(kind=dp) :: Hes0(NHESS) + REAL(kind=dp) :: Tmp(NVAR), Tmp2(NVAR) + REAL(kind=dp) :: H, HC, HA, Tau + INTEGER :: Pivot(NVAR), Direction + INTEGER :: i, j, m, istage, istart, jstart +!~~~> Local parameters + REAL(kind=dp), PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + REAL(kind=dp), PARAMETER :: DeltaMin = 1.0d-5 +!~~~> Sensitivities w.r.t. reacton coefficients + REAL(kind=dp), INTENT(OUT) :: Lambda_R(NCOEFF,NADJ) + INTEGER :: icoeff, vstart + REAL(kind=dp) :: DFDR(NVAR*NCOEFF) + REAL(kind=dp) :: DJDR(NVAR*NCOEFF) + REAL(kind=dp) :: DJDR_O3dep(NVAR) + REAL(kind=dp) :: V_R(NCOEFF*ros_S,NADJ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IF (.NOT.Autonomous) THEN + PRINT*,'ERROR: ros_DadjRateInt cannot handle NON-AUTONOMOUS systems' + STOP + END IF + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + +!~~~> dkh Initialize added to 0d0 at the start of each loop + Lambda_R(:,:) = ZERO + DFDR(:) = ZERO + DJDR(:) = ZERO + DJDR_O3dep(:) = ZERO + V_R(:,:) = ZERO + +!~~~> Time loop begins below +TimeLoop: DO WHILE ( stack_ptr > 0 ) + + !~~~> Recover checkpoints for stage values and vectors + CALL ros_DPop( ros_S, T, H, Ystage, K, Ghimj, Pivot ) + +! ISTATUS(Nstp) = ISTATUS(Nstp) + 1 + +!~~~> Compute LU decomposition + IF (.NOT.SaveLU) THEN + CALL JacTemplate(T,Ystage(1),Ghimj) + ISTATUS(Njac) = ISTATUS(Njac) + 1 + Tau = ONE/(Direction*H*ros_Gamma(1)) +#ifdef FULL_ALGEBRA + Ghimj(1:NVAR,1:NVAR) = -Ghimj(1:NVAR,1:NVAR) + DO i=1,NVAR + Ghimj(i,i) = Ghimj(i,i)+Tau + END DO +#else + CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+Tau + END DO +#endif + CALL ros_Decomp( Ghimj, Pivot, j ) + END IF + +!~~~> Compute Hessian at the beginning of the interval + CALL HessTemplate(T,Ystage(1),Hes0) + +!~~~> Compute the stages +Stage: DO istage = ros_S, 1, -1 + + !~~~> Current istage first entry + istart = NVAR*(istage-1) + 1 + + !~~~> Compute U + DO m = 1,NADJ + CALL WCOPY(NVAR,Lambda(1,m),1,U(istart,m),1) + CALL WSCAL(NVAR,ros_M(istage),U(istart,m),1) + END DO ! m=1:NADJ + DO j = istage+1, ros_S + jstart = NVAR*(j-1) + 1 + HA = ros_A((j-1)*(j-2)/2+istage) + HC = ros_C((j-1)*(j-2)/2+istage)/(Direction*H) + DO m = 1,NADJ + CALL WAXPY(NVAR,HA,V(jstart,m),1,U(istart,m),1) + CALL WAXPY(NVAR,HC,U(jstart,m),1,U(istart,m),1) + END DO ! m=1:NADJ + END DO + DO m = 1,NADJ + CALL ros_Solve('T', Ghimj, Pivot, U(istart,m)) + END DO ! m=1:NADJ + !~~~> Compute V + Tau = T + ros_Alpha(istage)*Direction*H + CALL JacTemplate(Tau,Ystage(istart),Jac) + ISTATUS(Njac) = ISTATUS(Njac) + 1 + + ! f_r(Y_istage) + CALL dFun_dRcoeff(Ystage(istart:istart+NVAR-1), FIX, NCOEFF, JCOEFF, DFDR) + !??CALL dJac_dRcoeff(Ystage(istart:istart+NVAR-1), FIX, K(istart:istart+NVAR-1),NCOEFF, JCOEFF, DJDR) + ! don't need for just emissions (dkh, 03/31/10) + !! J_r(y_n) x K_istage + !CALL dJac_dRcoeff(Ystage(1:NVAR), FIX, K(istart:istart+NVAR-1),NCOEFF, JCOEFF, DJDR) + ! added logical switch (tww, 05/08/12) + + ! Compute for all rxns + IF ( LADJ_RRATE ) THEN + CALL dJac_dRcoeff(Ystage(1:NVAR), FIX, K(istart:istart+NVAR-1),NCOEFF, JCOEFF, DJDR) + ELSE + ! Default: Only compute for O3 depostion (needed for shipping emissions), which + ! will be the last one. + CALL dJac_dRcoeff(Ystage(1:NVAR), FIX, K(istart:istart+NVAR-1),1, JCOEFF(NCOEFF), DJDR_O3dep) + ENDIF + + DO m = 1,NADJ +#ifdef FULL_ALGEBRA + V(istart:istart+NVAR-1,m) = MATMUL(TRANSPOSE(Jac),U(istart:istart+NVAR-1,m)) +#else + !---------------------------------------------------------------------- + ! Sensitivity w.r.t. reaction rate coefficients (dkh) + vstart = NCOEFF*(istage-1) + IF ( LADJ_RRATE ) THEN + DO icoeff = 1, NCOEFF + V_R(vstart+icoeff,m) = ZERO + DO j = 1, NVAR + !j = DMAP(icoeff) + ! += f_r(Y_istage) * U_istage + V_R(vstart+icoeff,m) = V_R(vstart+icoeff,m) + DFDR(NVAR*(icoeff-1)+j)*U(istart+j-1,m) + + !! dkh debug + !IF ( icoeff == NCOEFF ) THEN + ! print*, ' DFDR j = ', DFDR(NVAR*(icoeff-1)+j), j + ! print*, ' DJDR j = ', DJDR(NVAR*(icoeff-1)+j), j + !ENDIF + + ! don't need for just emissions (dkh, 03/31/10) + !! += ( J_r(y_n) x K_istage )^T * U_istage + !V_R(vstart+icoeff,m) = V_R(vstart+icoeff,m) + DJDR(NVAR*(icoeff-1)+j)*U(istart+j-1,m) + ! also comment out calc of DJDR above ! + ! added logical switch (tww, 05/08/12) + V_R(vstart+icoeff,m) = V_R(vstart+icoeff,m) + DJDR(NVAR*(icoeff-1)+j)*U(istart+j-1,m) + END DO + END DO + ELSE + DO icoeff = 1, NCOEFF-1 + V_R(vstart+icoeff,m) = ZERO + j = DMAP(icoeff) + ! += f_r(Y_istage) * U_istage + V_R(vstart+icoeff,m) = V_R(vstart+icoeff,m) + DFDR(NVAR*(icoeff-1)+j)*U(istart+j-1,m) + ! don't need for just emissions (dkh, 03/31/10) + !! += ( J_r(y_n) x K_istage )^T * U_istage + !V_R(vstart+icoeff,m) = V_R(vstart+icoeff,m) + DJDR(NVAR*(icoeff-1)+j)*U(istart+j-1,m) + END DO + + ! Now include O3 drydep to account for shipping emissions + icoeff = NCOEFF + V_R(vstart+icoeff,m) = ZERO + V_R(vstart+icoeff,m) = V_R(vstart+icoeff,m) & + + DFDR(NVAR*(icoeff-1)+ind_O3 ) * U(istart+ind_O3 -1,m) & + + DFDR(NVAR*(icoeff-1)+ind_DRYO3 ) * U(istart+ind_DRYO3 -1,m) & + + DFDR(NVAR*(icoeff-1)+ind_DRYDEP) * U(istart+ind_DRYDEP-1,m) & + + DJDR_O3dep(ind_O3 ) * U(istart+ind_O3 -1,m) & + + DJDR_O3dep(ind_DRYO3 ) * U(istart+ind_DRYO3 -1,m) & + + DJDR_O3dep(ind_DRYDEP) * U(istart+ind_DRYDEP-1,m) + + !! dkh debug + !print *, ' DFDR(NVAR*(icoeff-1)+ind_O3 ) = ', DFDR(NVAR*(icoeff-1)+ind_O3 ) + !print *, ' DFDR(NVAR*(icoeff-1)+ind_DRYO3 ) = ', DFDR(NVAR*(icoeff-1)+ind_DRYO3 ) + !print *, ' DFDR(NVAR*(icoeff-1)+ind_DRYDEP) =', DFDR(NVAR*(icoeff-1)+ind_DRYDEP) + !print *, ' DJDR_O3dep(ind_O3 ) = ', DJDR_O3dep(ind_O3 ) + !print *, ' DJDR_O3dep(ind_DRYO3 ) = ', DJDR_O3dep(ind_DRYO3 ) + !print *, ' DJDR_O3dep(ind_DRYDEP) = ', DJDR_O3dep(ind_DRYDEP) + + ENDIF + !---------------------------------------------------------------------- + CALL JacTR_SP_Vec(Jac,U(istart,m),V(istart,m)) +#endif + END DO ! m=1:NADJ + + END DO Stage + +!$$ IF (.NOT.Autonomous) THEN +!$$!~~~> Compute the Jacobian derivative with respect to T. +!$$! Last "Jac" computed for stage 1 +!$$ CALL ros_JacTimeDerivative ( T, Roundoff, Ystage(1), Jac, dJdT ) +!$$ END IF + +!~~~> Compute the new solution + + !~~~> Compute Lambda_R (dkh) + DO istage=1,ros_S + vstart = NCOEFF*(istage-1) + 1 + DO m = 1,NADJ + ! Sum_over_i f_r(Y_i)^T * U_i + (J_r x K_i)^T * U_i + CALL WAXPY(NCOEFF,ONE,V_R(vstart,m),1,Lambda_R(1,m),1) + END DO ! m=1:NADJ + END DO + + + !~~~> Compute Lambda + DO istage=1,ros_S + istart = NVAR*(istage-1) + 1 + DO m = 1,NADJ + ! Add V_i + CALL WAXPY(NVAR,ONE,V(istart,m),1,Lambda(1,m),1) + ! Add (H0xK_i)^T * U_i + CALL HessTR_Vec ( Hes0, U(istart,m), K(istart), Tmp ) + CALL WAXPY(NVAR,ONE,Tmp,1,Lambda(1,m),1) + END DO ! m=1:NADJ + END DO + ! Add H * dJac_dT_0^T * \sum(gamma_i U_i) + ! Tmp holds sum gamma_i U_i +!$$ IF (.NOT.Autonomous) THEN +!$$ DO m = 1,NADJ +!$$ Tmp(1:NVAR) = ZERO +!$$ DO istage = 1, ros_S +!$$ istart = NVAR*(istage-1) + 1 +!$$ CALL WAXPY(NVAR,ros_Gamma(istage),U(istart,m),1,Tmp,1) +!$$ END DO +!$$#ifdef FULL_ALGEBRA +!$$ Tmp2 = MATMUL(TRANSPOSE(dJdT),Tmp) +!$$#else +!$$ CALL JacTR_SP_Vec(dJdT,Tmp,Tmp2) +!$$#endif +!$$ CALL WAXPY(NVAR,H,Tmp2,1,Lambda(1,m),1) +!$$ END DO ! m=1:NADJ +!$$ END IF ! .NOT.Autonomous + + + END DO TimeLoop + +!~~~> Save last state + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + END SUBROUTINE ros_DadjRateInt +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_DadjInt ( & + NADJ, Lambda, & + Tstart, Tend, T, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic RosenbrockADJ method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + INTEGER, INTENT(IN) :: NADJ +!~~~> First order adjoint + REAL(kind=dp), INTENT(INOUT) :: Lambda(NVAR,NADJ) +!!~~~> Input: integration interval + REAL(kind=dp), INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + REAL(kind=dp), INTENT(OUT) :: T +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + REAL(kind=dp) :: Ystage(NVAR*ros_S), K(NVAR*ros_S) + REAL(kind=dp) :: U(NVAR*ros_S,NADJ), V(NVAR*ros_S,NADJ) +#ifdef FULL_ALGEBRA + REAL(kind=dp), DIMENSION(NVAR,NVAR) :: Jac, dJdT, Ghimj +#else + REAL(kind=dp), DIMENSION(LU_NONZERO) :: Jac, dJdT, Ghimj +#endif + REAL(kind=dp) :: Hes0(NHESS) + REAL(kind=dp) :: Tmp(NVAR), Tmp2(NVAR) + REAL(kind=dp) :: H, HC, HA, Tau + INTEGER :: Pivot(NVAR), Direction + INTEGER :: i, j, m, istage, istart, jstart +!~~~> Local parameters + REAL(kind=dp), PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + REAL(kind=dp), PARAMETER :: DeltaMin = 1.0d-5 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + +!~~~> Time loop begins below +TimeLoop: DO WHILE ( stack_ptr > 0 ) + + !~~~> Recover checkpoints for stage values and vectors + CALL ros_DPop( ros_S, T, H, Ystage, K, Ghimj, Pivot ) + +! ISTATUS(Nstp) = ISTATUS(Nstp) + 1 + +!~~~> Compute LU decomposition + IF (.NOT.SaveLU) THEN + CALL JacTemplate(T,Ystage(1),Ghimj) + ISTATUS(Njac) = ISTATUS(Njac) + 1 + Tau = ONE/(Direction*H*ros_Gamma(1)) +#ifdef FULL_ALGEBRA + Ghimj(1:NVAR,1:NVAR) = -Ghimj(1:NVAR,1:NVAR) + DO i=1,NVAR + Ghimj(i,i) = Ghimj(i,i)+Tau + END DO +#else + CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+Tau + END DO +#endif + CALL ros_Decomp( Ghimj, Pivot, j ) + END IF + +!~~~> Compute Hessian at the beginning of the interval + CALL HessTemplate(T,Ystage(1),Hes0) + +!~~~> Compute the stages +Stage: DO istage = ros_S, 1, -1 + + !~~~> Current istage first entry + istart = NVAR*(istage-1) + 1 + + !~~~> Compute U + DO m = 1,NADJ + CALL WCOPY(NVAR,Lambda(1,m),1,U(istart,m),1) + CALL WSCAL(NVAR,ros_M(istage),U(istart,m),1) + END DO ! m=1:NADJ + DO j = istage+1, ros_S + jstart = NVAR*(j-1) + 1 + HA = ros_A((j-1)*(j-2)/2+istage) + HC = ros_C((j-1)*(j-2)/2+istage)/(Direction*H) + DO m = 1,NADJ + CALL WAXPY(NVAR,HA,V(jstart,m),1,U(istart,m),1) + CALL WAXPY(NVAR,HC,U(jstart,m),1,U(istart,m),1) + END DO ! m=1:NADJ + END DO + DO m = 1,NADJ + CALL ros_Solve('T', Ghimj, Pivot, U(istart,m)) + END DO ! m=1:NADJ + !~~~> Compute V + Tau = T + ros_Alpha(istage)*Direction*H + CALL JacTemplate(Tau,Ystage(istart),Jac) + ISTATUS(Njac) = ISTATUS(Njac) + 1 + DO m = 1,NADJ +#ifdef FULL_ALGEBRA + V(istart:istart+NVAR-1,m) = MATMUL(TRANSPOSE(Jac),U(istart:istart+NVAR-1,m)) +#else + CALL JacTR_SP_Vec(Jac,U(istart,m),V(istart,m)) +#endif + END DO ! m=1:NADJ + + END DO Stage + + IF (.NOT.Autonomous) THEN +!~~~> Compute the Jacobian derivative with respect to T. +! Last "Jac" computed for stage 1 + CALL ros_JacTimeDerivative ( T, Roundoff, Ystage(1), Jac, dJdT ) + END IF + +!~~~> Compute the new solution + + !~~~> Compute Lambda + DO istage=1,ros_S + istart = NVAR*(istage-1) + 1 + DO m = 1,NADJ + ! Add V_i + CALL WAXPY(NVAR,ONE,V(istart,m),1,Lambda(1,m),1) + ! Add (H0xK_i)^T * U_i + CALL HessTR_Vec ( Hes0, U(istart,m), K(istart), Tmp ) + CALL WAXPY(NVAR,ONE,Tmp,1,Lambda(1,m),1) + END DO ! m=1:NADJ + END DO + ! Add H * dJac_dT_0^T * \sum(gamma_i U_i) + ! Tmp holds sum gamma_i U_i + IF (.NOT.Autonomous) THEN + DO m = 1,NADJ + Tmp(1:NVAR) = ZERO + DO istage = 1, ros_S + istart = NVAR*(istage-1) + 1 + CALL WAXPY(NVAR,ros_Gamma(istage),U(istart,m),1,Tmp,1) + END DO +#ifdef FULL_ALGEBRA + Tmp2 = MATMUL(TRANSPOSE(dJdT),Tmp) +#else + CALL JacTR_SP_Vec(dJdT,Tmp,Tmp2) +#endif + CALL WAXPY(NVAR,H,Tmp2,1,Lambda(1,m),1) + END DO ! m=1:NADJ + END IF ! .NOT.Autonomous + + + END DO TimeLoop + +!~~~> Save last state + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + END SUBROUTINE ros_DadjInt +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_CadjInt ( & + NADJ, Y, & + Tstart, Tend, T, & + AbsTol_adj, RelTol_adj, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic RosenbrockADJ method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + INTEGER, INTENT(IN) :: NADJ + REAL(kind=dp), INTENT(INOUT) :: Y(NVAR,NADJ) +!~~~> Input: integration interval + REAL(kind=dp), INTENT(IN) :: Tstart,Tend +!~~~> Input: adjoint tolerances + REAL(kind=dp), INTENT(IN) :: AbsTol_adj(NVAR,NADJ), RelTol_adj(NVAR,NADJ) +!~~~> Output: time at which the solution is returned (T=Tend if success) + REAL(kind=dp), INTENT(OUT) :: T +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + REAL(kind=dp) :: Y0(NVAR) + REAL(kind=dp) :: Ynew(NVAR,NADJ), Fcn0(NVAR,NADJ), Fcn(NVAR,NADJ) + REAL(kind=dp) :: K(NVAR*ros_S,NADJ), dFdT(NVAR,NADJ) +#ifdef FULL_ALGEBRA + REAL(kind=dp), DIMENSION(NVAR,NVAR) :: Jac0, Ghimj, Jac, dJdT +#else + REAL(kind=dp), DIMENSION(LU_NONZERO) :: Jac0, Ghimj, Jac, dJdT +#endif + REAL(kind=dp) :: H, Hnew, HC, HG, Fac, Tau + REAL(kind=dp) :: Err, Yerr(NVAR,NADJ) + INTEGER :: Pivot(NVAR), Direction, ioffset, j, istage, iadj + LOGICAL :: RejectLastH, RejectMoreH, Singular +!~~~> Local parameters + REAL(kind=dp), PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + REAL(kind=dp), PARAMETER :: DeltaMin = 1.0d-5 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~> Initial preparations + T = Tstart + RSTATUS(Nhexit) = 0.0_dp + H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , ABS(Hmax) ) + IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + H = Direction*H + + RejectLastH=.FALSE. + RejectMoreH=.FALSE. + +!~~~> Time loop begins below + +TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff*abs(Tend) <= ZERO) & + .OR. (Direction < 0).AND.((Tend-T)+Roundoff*abs(Tend) <= ZERO) ) ! Added *abs(Tend) by KS, A.Sandu for boundary cases + + IF ( ISTATUS(Nstp) > Max_no_steps ) THEN ! Too many steps + CALL ros_ErrorMsg(-6,T,H,IERR) + RETURN + END IF + IF ( ((T+0.1d0*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small + CALL ros_ErrorMsg(-7,T,H,IERR) + RETURN + END IF + +!~~~> Limit H if necessary to avoid going beyond Tend + RSTATUS(Nhexit) = H + H = MIN(H,ABS(Tend-T)) + +!~~~> Interpolate forward solution + CALL ros_cadj_Y( T, Y0 ) +!~~~> Compute the Jacobian at current time + CALL JacTemplate(T, Y0, Jac0) + ISTATUS(Njac) = ISTATUS(Njac) + 1 + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL ros_JacTimeDerivative ( T, Roundoff, Y0, & + Jac0, dJdT ) + DO iadj = 1, NADJ +#ifdef FULL_ALGEBRA + dFdT(1:NVAR,iadj) = MATMUL(TRANSPOSE(dJdT),Y(1:NVAR,iadj)) +#else + CALL JacTR_SP_Vec(dJdT,Y(1,iadj),dFdT(1,iadj)) +#endif + CALL WSCAL(NVAR,(-ONE),dFdT(1,iadj),1) + END DO + END IF + +!~~~> Ydot = -J^T*Y +#ifdef FULL_ALGEBRA + Jac0(1:NVAR,1:NVAR) = -Jac0(1:NVAR,1:NVAR) +#else + CALL WSCAL(LU_NONZERO,(-ONE),Jac0,1) +#endif + DO iadj = 1, NADJ +#ifdef FULL_ALGEBRA + Fcn0(1:NVAR,iadj) = MATMUL(TRANSPOSE(Jac0),Y(1:NVAR,iadj)) +#else + CALL JacTR_SP_Vec(Jac0,Y(1,iadj),Fcn0(1,iadj)) +#endif + END DO + +!~~~> Repeat step calculation until current step accepted +UntilAccepted: DO + + CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1), & + Jac0,Ghimj,Pivot,Singular) + IF (Singular) THEN ! More than 5 consecutive failed decompositions + CALL ros_ErrorMsg(-8,T,H,IERR) + RETURN + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + DO iadj = 1, NADJ + CALL WCOPY(NVAR,Fcn0(1,iadj),1,Fcn(1,iadj),1) + END DO + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL WCOPY(NVAR*NADJ,Y,1,Ynew,1) + DO j = 1, istage-1 + DO iadj = 1, NADJ + CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1,iadj),1,Ynew(1,iadj),1) + END DO + END DO + Tau = T + ros_Alpha(istage)*Direction*H + ! CALL FunTemplate(Tau,Ynew,Fcn) + ! ISTATUS(Nfun) = ISTATUS(Nfun) + 1 + CALL ros_cadj_Y( Tau, Y0 ) + CALL JacTemplate(Tau, Y0, Jac) + ISTATUS(Njac) = ISTATUS(Njac) + 1 +#ifdef FULL_ALGEBRA + Jac(1:NVAR,1:NVAR) = -Jac(1:NVAR,1:NVAR) +#else + CALL WSCAL(LU_NONZERO,(-ONE),Jac,1) +#endif + DO iadj = 1, NADJ +#ifdef FULL_ALGEBRA + Fcn(1:NVAR,iadj) = MATMUL(TRANSPOSE(Jac),Ynew(1:NVAR,iadj)) +#else + CALL JacTR_SP_Vec(Jac,Ynew(1,iadj),Fcn(1,iadj)) +#endif + !CALL WSCAL(NVAR,(-ONE),Fcn(1,iadj),1) + END DO + END IF ! if istage == 1 elseif ros_NewF(istage) + + DO iadj = 1, NADJ + CALL WCOPY(NVAR,Fcn(1,iadj),1,K(ioffset+1,iadj),1) + END DO + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + DO iadj = 1, NADJ + CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1,iadj),1, & + K(ioffset+1,iadj),1) + END DO + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + DO iadj = 1, NADJ + CALL WAXPY(NVAR,HG,dFdT(1,iadj),1,K(ioffset+1,iadj),1) + END DO + END IF + DO iadj = 1, NADJ + CALL ros_Solve('T', Ghimj, Pivot, K(ioffset+1,iadj)) + END DO + + END DO Stage + + +!~~~> Compute the new solution + DO iadj = 1, NADJ + CALL WCOPY(NVAR,Y(1,iadj),1,Ynew(1,iadj),1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1,iadj),1,Ynew(1,iadj),1) + END DO + END DO + +!~~~> Compute the error estimation + CALL WSCAL(NVAR*NADJ,ZERO,Yerr,1) + DO j=1,ros_S + DO iadj = 1, NADJ + CALL WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1,iadj),1,Yerr(1,iadj),1) + END DO + END DO +!~~~> Max error among all adjoint components + iadj = 1 + Err = ros_ErrorNorm ( Y(1,iadj), Ynew(1,iadj), Yerr(1,iadj), & + AbsTol_adj(1,iadj), RelTol_adj(1,iadj), VectorTol ) + +!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax + Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) + Hnew = H*Fac + +!~~~> Check the error magnitude and adjust step size +! ISTATUS(Nstp) = ISTATUS(Nstp) + 1 + IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step + ISTATUS(Nacc) = ISTATUS(Nacc) + 1 + CALL WCOPY(NVAR*NADJ,Ynew,1,Y,1) + T = T + Direction*H + Hnew = MAX(Hmin,MIN(Hnew,Hmax)) + IF (RejectLastH) THEN ! No step size increase after a rejected step + Hnew = MIN(Hnew,H) + END IF + RSTATUS(Nhexit) = H + RSTATUS(Nhnew) = Hnew + RSTATUS(Ntexit) = T + RejectLastH = .FALSE. + RejectMoreH = .FALSE. + H = Hnew + EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED + ELSE !~~~> Reject step + IF (RejectMoreH) THEN + Hnew = H*FacRej + END IF + RejectMoreH = RejectLastH + RejectLastH = .TRUE. + H = Hnew + IF (ISTATUS(Nacc) >= 1) THEN + ISTATUS(Nrej) = ISTATUS(Nrej) + 1 + END IF + END IF ! Err <= 1 + + END DO UntilAccepted + + END DO TimeLoop + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + END SUBROUTINE ros_CadjInt + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_SimpleCadjInt ( & + NADJ, Y, & + Tstart, Tend, T, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic RosenbrockADJ method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + INTEGER, INTENT(IN) :: NADJ + REAL(kind=dp), INTENT(INOUT) :: Y(NVAR,NADJ) +!~~~> Input: integration interval + REAL(kind=dp), INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + REAL(kind=dp), INTENT(OUT) :: T +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + REAL(kind=dp) :: Y0(NVAR) + REAL(kind=dp) :: Ynew(NVAR,NADJ), Fcn0(NVAR,NADJ), Fcn(NVAR,NADJ) + REAL(kind=dp) :: K(NVAR*ros_S,NADJ), dFdT(NVAR,NADJ) +#ifdef FULL_ALGEBRA + REAL(kind=dp),DIMENSION(NVAR,NVAR) :: Jac0, Ghimj, Jac, dJdT +#else + REAL(kind=dp),DIMENSION(LU_NONZERO) :: Jac0, Ghimj, Jac, dJdT +#endif + REAL(kind=dp) :: H, HC, HG, Tau + REAL(kind=dp) :: ghinv + INTEGER :: Pivot(NVAR), Direction, ioffset, i, j, istage, iadj + INTEGER :: istack +!~~~> Local parameters + REAL(kind=dp), PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + REAL(kind=dp), PARAMETER :: DeltaMin = 1.0d-5 +!~~~> Locally called functions +! REAL(kind=dp) WLAMCH +! EXTERNAL WLAMCH +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~> INITIAL PREPARATIONS + + IF (Tend >= Tstart) THEN + Direction = -1 + ELSE + Direction = +1 + END IF + +!~~~> Time loop begins below +TimeLoop: DO istack = stack_ptr,2,-1 + + T = chk_T(istack) + H = chk_H(istack-1) + !CALL WCOPY(NVAR,chk_Y(1,istack),1,Y0,1) + Y0(1:NVAR) = chk_Y(1:NVAR,istack) + +!~~~> Compute the Jacobian at current time + CALL JacTemplate(T, Y0, Jac0) + ISTATUS(Njac) = ISTATUS(Njac) + 1 + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL ros_JacTimeDerivative ( T, Roundoff, Y0, & + Jac0, dJdT ) + DO iadj = 1, NADJ +#ifdef FULL_ALGEBRA + dFdT(1:NVAR,iadj) = MATMUL(TRANSPOSE(dJdT),Y(1:NVAR,iadj)) +#else + CALL JacTR_SP_Vec(dJdT,Y(1,iadj),dFdT(1,iadj)) +#endif + CALL WSCAL(NVAR,(-ONE),dFdT(1,iadj),1) + END DO + END IF + +!~~~> Ydot = -J^T*Y +#ifdef FULL_ALGEBRA + Jac0(1:NVAR,1:NVAR) = -Jac0(1:NVAR,1:NVAR) +#else + CALL WSCAL(LU_NONZERO,(-ONE),Jac0,1) +#endif + DO iadj = 1, NADJ +#ifdef FULL_ALGEBRA + Fcn0(1:NVAR,iadj) = MATMUL(TRANSPOSE(Jac0),Y(1:NVAR,iadj)) +#else + CALL JacTR_SP_Vec(Jac0,Y(1,iadj),Fcn0(1,iadj)) +#endif + END DO + +!~~~> Construct Ghimj = 1/(H*ham) - Jac0 + ghinv = ONE/(Direction*H*ros_Gamma(1)) +#ifdef FULL_ALGEBRA + Ghimj(1:NVAR,1:NVAR) = -Jac0(1:NVAR,1:NVAR) + DO i=1,NVAR + Ghimj(i,i) = Ghimj(i,i)+ghinv + END DO +#else + CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) + CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv + END DO +#endif +!~~~> Compute LU decomposition + CALL ros_Decomp( Ghimj, Pivot, j ) + IF (j /= 0) THEN + CALL ros_ErrorMsg(-8,T,H,IERR) + PRINT*,' The matrix is singular !' + STOP + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + DO iadj = 1, NADJ + CALL WCOPY(NVAR,Fcn0(1,iadj),1,Fcn(1,iadj),1) + END DO + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL WCOPY(NVAR*NADJ,Y,1,Ynew,1) + DO j = 1, istage-1 + DO iadj = 1, NADJ + CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1,iadj),1,Ynew(1,iadj),1) + END DO + END DO + Tau = T + ros_Alpha(istage)*Direction*H + CALL ros_Hermite3( chk_T(istack-1), chk_T(istack), Tau, & + chk_Y(1:NVAR,istack-1), chk_Y(1:NVAR,istack), & + chk_dY(1:NVAR,istack-1), chk_dY(1:NVAR,istack), Y0 ) + CALL JacTemplate(Tau, Y0, Jac) + ISTATUS(Njac) = ISTATUS(Njac) + 1 +#ifdef FULL_ALGEBRA + Jac(1:NVAR,1:NVAR) = -Jac(1:NVAR,1:NVAR) +#else + CALL WSCAL(LU_NONZERO,(-ONE),Jac,1) +#endif + DO iadj = 1, NADJ +#ifdef FULL_ALGEBRA + Fcn(1:NVAR,iadj) = MATMUL(TRANSPOSE(Jac),Ynew(1:NVAR,iadj)) +#else + CALL JacTR_SP_Vec(Jac,Ynew(1,iadj),Fcn(1,iadj)) +#endif + END DO + END IF ! if istage == 1 elseif ros_NewF(istage) + + DO iadj = 1, NADJ + CALL WCOPY(NVAR,Fcn(1,iadj),1,K(ioffset+1,iadj),1) + END DO + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + DO iadj = 1, NADJ + CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1,iadj),1, & + K(ioffset+1,iadj),1) + END DO + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + DO iadj = 1, NADJ + CALL WAXPY(NVAR,HG,dFdT(1,iadj),1,K(ioffset+1,iadj),1) + END DO + END IF + DO iadj = 1, NADJ + CALL ros_Solve('T', Ghimj, Pivot, K(ioffset+1,iadj)) + END DO + + END DO Stage + + +!~~~> Compute the new solution + DO iadj = 1, NADJ + DO j=1,ros_S + CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1,iadj),1,Y(1,iadj),1) + END DO + END DO + + END DO TimeLoop + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + END SUBROUTINE ros_SimpleCadjInt + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + REAL(kind=dp) FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr, & + AbsTol, RelTol, VectorTol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Computes the "scaled norm" of the error vector Yerr +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +! Input arguments + REAL(kind=dp), INTENT(IN) :: Y(NVAR), Ynew(NVAR), & + Yerr(NVAR), AbsTol(NVAR), RelTol(NVAR) + LOGICAL, INTENT(IN) :: VectorTol +! Local variables + REAL(kind=dp) :: Err, Scale, Ymax + INTEGER :: i + + Err = ZERO + DO i=1,NVAR + Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) + IF (VectorTol) THEN + Scale = AbsTol(i)+RelTol(i)*Ymax + ELSE + Scale = AbsTol(1)+RelTol(1)*Ymax + END IF + Err = Err+(Yerr(i)/Scale)**2 + END DO + Err = SQRT(Err/NVAR) + + ros_ErrorNorm = MAX(Err,1.0d-10) + + END FUNCTION ros_ErrorNorm + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y, Fcn0, dFdT ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the function by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input arguments + REAL(kind=dp), INTENT(IN) :: T, Roundoff, Y(NVAR), Fcn0(NVAR) +!~~~> Output arguments + REAL(kind=dp), INTENT(OUT) :: dFdT(NVAR) +!~~~> Local variables + REAL(kind=dp) :: Delta + REAL(kind=dp), PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL FunTemplate(T+Delta,Y,dFdT) + ISTATUS(Nfun) = ISTATUS(Nfun) + 1 + CALL WAXPY(NVAR,(-ONE),Fcn0,1,dFdT,1) + CALL WSCAL(NVAR,(ONE/Delta),dFdT,1) + + END SUBROUTINE ros_FunTimeDerivative + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_JacTimeDerivative ( T, Roundoff, Y, & + Jac0, dJdT ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the Jacobian by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Arguments + REAL(kind=dp), INTENT(IN) :: T, Roundoff, Y(NVAR) +#ifdef FULL_ALGEBRA + REAL(kind=dp), INTENT(IN) :: Jac0(NVAR,NVAR) + REAL(kind=dp), INTENT(OUT) :: dJdT(NVAR,NVAR) +#else + REAL(kind=dp), INTENT(IN) :: Jac0(LU_NONZERO) + REAL(kind=dp), INTENT(OUT) :: dJdT(LU_NONZERO) +#endif +!~~~> Local variables + REAL(kind=dp) :: Delta + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL JacTemplate(T+Delta,Y,dJdT) + ISTATUS(Njac) = ISTATUS(Njac) + 1 +#ifdef FULL_ALGEBRA + CALL WAXPY(NVAR*NVAR,(-ONE),Jac0,1,dJdT,1) + CALL WSCAL(NVAR*NVAR,(ONE/Delta),dJdT,1) +#else + CALL WAXPY(LU_NONZERO,(-ONE),Jac0,1,dJdT,1) + CALL WSCAL(LU_NONZERO,(ONE/Delta),dJdT,1) +#endif + + END SUBROUTINE ros_JacTimeDerivative + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_PrepareMatrix ( H, Direction, gam, & + Jac0, Ghimj, Pivot, Singular ) +! --- --- --- --- --- --- --- --- --- --- --- --- --- +! Prepares the LHS matrix for stage calculations +! 1. Construct Ghimj = 1/(H*gam) - Jac0 +! "(Gamma H) Inverse Minus Jacobian" +! 2. Repeat LU decomposition of Ghimj until successful. +! -half the step size if LU decomposition fails and retry +! -exit after 5 consecutive fails +! --- --- --- --- --- --- --- --- --- --- --- --- --- + IMPLICIT NONE + +!~~~> Input arguments +#ifdef FULL_ALGEBRA + REAL(kind=dp), INTENT(IN) :: Jac0(NVAR,NVAR) +#else + REAL(kind=dp), INTENT(IN) :: Jac0(LU_NONZERO) +#endif + REAL(kind=dp), INTENT(IN) :: gam + INTEGER, INTENT(IN) :: Direction +!~~~> Output arguments +#ifdef FULL_ALGEBRA + REAL(kind=dp), INTENT(OUT) :: Ghimj(NVAR,NVAR) +#else + REAL(kind=dp), INTENT(OUT) :: Ghimj(LU_NONZERO) +#endif + LOGICAL, INTENT(OUT) :: Singular + INTEGER, INTENT(OUT) :: Pivot(NVAR) +!~~~> Inout arguments + REAL(kind=dp), INTENT(INOUT) :: H ! step size is decreased when LU fails +!~~~> Local variables + INTEGER :: i, ising, Nconsecutive + REAL(kind=dp) :: ghinv + REAL(kind=dp), PARAMETER :: ONE = 1.0_dp, HALF = 0.5_dp + + Nconsecutive = 0 + Singular = .TRUE. + + DO WHILE (Singular) + +!~~~> Construct Ghimj = 1/(H*gam) - Jac0 +#ifdef FULL_ALGEBRA + CALL WCOPY(NVAR*NVAR,Jac0,1,Ghimj,1) + CALL WSCAL(NVAR*NVAR,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(i,i) = Ghimj(i,i)+ghinv + END DO +#else + CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) + CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv + END DO +#endif +!~~~> Compute LU decomposition + CALL ros_Decomp( Ghimj, Pivot, ising ) + IF (ising == 0) THEN +!~~~> If successful done + Singular = .FALSE. + ELSE ! ising .ne. 0 +!~~~> If unsuccessful half the step size; if 5 consecutive fails then return + ISTATUS(Nsng) = ISTATUS(Nsng) + 1 + Nconsecutive = Nconsecutive+1 + Singular = .TRUE. + PRINT*,'Warning: LU Decomposition returned ising = ',ising + IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decompositions + H = H*HALF + ELSE ! More than 5 consecutive failed decompositions + RETURN + END IF ! Nconsecutive + END IF ! ising + + END DO ! WHILE Singular + + END SUBROUTINE ros_PrepareMatrix + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Decomp( A, Pivot, ising ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the LU decomposition +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Inout variables +#ifdef FULL_ALGEBRA + REAL(kind=dp), INTENT(INOUT) :: A(NVAR,NVAR) +#else + REAL(kind=dp), INTENT(INOUT) :: A(LU_NONZERO) +#endif +!~~~> Output variables + INTEGER, INTENT(OUT) :: Pivot(NVAR), ising + +#ifdef FULL_ALGEBRA + CALL DGETRF( NVAR, NVAR, A, NVAR, Pivot, ising ) +#else + CALL KppDecomp ( A, ising ) + Pivot(1) = 1 +#endif + ISTATUS(Ndec) = ISTATUS(Ndec) + 1 + + END SUBROUTINE ros_Decomp + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Solve( How, A, Pivot, b ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the forward/backward substitution (using pre-computed LU decomposition) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + CHARACTER, INTENT(IN) :: How +#ifdef FULL_ALGEBRA + REAL(kind=dp), INTENT(IN) :: A(NVAR,NVAR) +#else + REAL(kind=dp), INTENT(IN) :: A(LU_NONZERO) +#endif + INTEGER, INTENT(IN) :: Pivot(NVAR) +!~~~> InOut variables + REAL(kind=dp), INTENT(INOUT) :: b(NVAR) + + SELECT CASE (How) + CASE ('N') +#ifdef FULL_ALGEBRA + CALL DGETRS( 'N', NVAR , 1, A, NVAR, Pivot, b, NVAR, 0 ) +#else + CALL KppSolve( A, b ) +#endif + CASE ('T') +#ifdef FULL_ALGEBRA + CALL DGETRS( 'T', NVAR , 1, A, NVAR, Pivot, b, NVAR, 0 ) +#else + CALL KppSolveTR( A, b, b ) +#endif + CASE DEFAULT + PRINT*,'Error: unknown argument in ros_Solve: How=',How + STOP + END SELECT + ISTATUS(Nsol) = ISTATUS(Nsol) + 1 + + END SUBROUTINE ros_Solve + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_cadj_Y( T, Y ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Finds the solution Y at T by interpolating the stored forward trajectory +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + REAL(kind=dp), INTENT(IN) :: T +!~~~> Output variables + REAL(kind=dp), INTENT(OUT) :: Y(NVAR) +!~~~> Local variables + INTEGER :: i + REAL(kind=dp), PARAMETER :: ONE = 1.0d0 + +! chk_H, chk_T, chk_Y, chk_dY, chk_d2Y + + IF( (T < chk_T(1)).OR.(T> chk_T(stack_ptr)) ) THEN + PRINT*,'Cannot locate solution at T = ',T + PRINT*,'Stored trajectory is between Tstart = ',chk_T(1) + PRINT*,' and Tend = ',chk_T(stack_ptr) + STOP + END IF + DO i = 1, stack_ptr-1 + IF( (T>= chk_T(i)).AND.(T<= chk_T(i+1)) ) EXIT + END DO + + +! IF (.FALSE.) THEN +! +! CALL ros_Hermite5( chk_T(i), chk_T(i+1), T, & +! chk_Y(1,i), chk_Y(1,i+1), & +! chk_dY(1,i), chk_dY(1,i+1), & +! chk_d2Y(1,i), chk_d2Y(1,i+1), Y ) +! +! ELSE + + CALL ros_Hermite3( chk_T(i), chk_T(i+1), T, & + chk_Y(1:NVAR,i), chk_Y(1:NVAR,i+1), & + chk_dY(1:NVAR,i), chk_dY(1:NVAR,i+1), & + Y ) + +! +! END IF + + END SUBROUTINE ros_cadj_Y + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Hermite3( a, b, T, Ya, Yb, Ja, Jb, Y ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for Hermite interpolation of order 5 on the interval [a,b] +! P = c(1) + c(2)*(x-a) + ... + c(4)*(x-a)^3 +! P[a,b] = [Ya,Yb], P'[a,b] = [Ja,Jb] +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + REAL(kind=dp), INTENT(IN) :: a, b, T, Ya(NVAR), Yb(NVAR) + REAL(kind=dp), INTENT(IN) :: Ja(NVAR), Jb(NVAR) +!~~~> Output variables + REAL(kind=dp), INTENT(OUT) :: Y(NVAR) +!~~~> Local variables + REAL(kind=dp) :: Tau, amb(3), C(NVAR,4) + REAL(kind=dp), PARAMETER :: ZERO = 0.0d0 + INTEGER :: i, j + + amb(1) = 1.0d0/(a-b) + DO i=2,3 + amb(i) = amb(i-1)*amb(1) + END DO + + +! c(1) = ya; + CALL WCOPY(NVAR,Ya,1,C(1,1),1) +! c(2) = ja; + CALL WCOPY(NVAR,Ja,1,C(1,2),1) +! c(3) = 2/(a-b)*ja + 1/(a-b)*jb - 3/(a - b)^2*ya + 3/(a - b)^2*yb ; + CALL WCOPY(NVAR,Ya,1,C(1,3),1) + CALL WSCAL(NVAR,-3.0*amb(2),C(1,3),1) + CALL WAXPY(NVAR,3.0*amb(2),Yb,1,C(1,3),1) + CALL WAXPY(NVAR,2.0*amb(1),Ja,1,C(1,3),1) + CALL WAXPY(NVAR,amb(1),Jb,1,C(1,3),1) +! c(4) = 1/(a-b)^2*ja + 1/(a-b)^2*jb - 2/(a-b)^3*ya + 2/(a-b)^3*yb ; + CALL WCOPY(NVAR,Ya,1,C(1,4),1) + CALL WSCAL(NVAR,-2.0*amb(3),C(1,4),1) + CALL WAXPY(NVAR,2.0*amb(3),Yb,1,C(1,4),1) + CALL WAXPY(NVAR,amb(2),Ja,1,C(1,4),1) + CALL WAXPY(NVAR,amb(2),Jb,1,C(1,4),1) + + Tau = T - a + CALL WCOPY(NVAR,C(1,4),1,Y,1) + CALL WSCAL(NVAR,Tau**3,Y,1) + DO j = 3,1,-1 + CALL WAXPY(NVAR,TAU**(j-1),C(1,j),1,Y,1) + END DO + + END SUBROUTINE ros_Hermite3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Hermite5( a, b, T, Ya, Yb, Ja, Jb, Ha, Hb, Y ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for Hermite interpolation of order 5 on the interval [a,b] +! P = c(1) + c(2)*(x-a) + ... + c(6)*(x-a)^5 +! P[a,b] = [Ya,Yb], P'[a,b] = [Ja,Jb], P"[a,b] = [Ha,Hb] +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + REAL(kind=dp), INTENT(IN) :: a, b, T, Ya(NVAR), Yb(NVAR) + REAL(kind=dp), INTENT(IN) :: Ja(NVAR), Jb(NVAR), Ha(NVAR), Hb(NVAR) +!~~~> Output variables + REAL(kind=dp), INTENT(OUT) :: Y(NVAR) +!~~~> Local variables + REAL(kind=dp) :: Tau, amb(5), C(NVAR,6) + REAL(kind=dp), PARAMETER :: ZERO = 0.0d0, HALF = 0.5d0 + INTEGER :: i, j + + amb(1) = 1.0d0/(a-b) + DO i=2,5 + amb(i) = amb(i-1)*amb(1) + END DO + +! c(1) = ya; + CALL WCOPY(NVAR,Ya,1,C(1,1),1) +! c(2) = ja; + CALL WCOPY(NVAR,Ja,1,C(1,2),1) +! c(3) = ha/2; + CALL WCOPY(NVAR,Ha,1,C(1,3),1) + CALL WSCAL(NVAR,HALF,C(1,3),1) + +! c(4) = 10*amb(3)*ya - 10*amb(3)*yb - 6*amb(2)*ja - 4*amb(2)*jb + 1.5*amb(1)*ha - 0.5*amb(1)*hb ; + CALL WCOPY(NVAR,Ya,1,C(1,4),1) + CALL WSCAL(NVAR,10.0*amb(3),C(1,4),1) + CALL WAXPY(NVAR,-10.0*amb(3),Yb,1,C(1,4),1) + CALL WAXPY(NVAR,-6.0*amb(2),Ja,1,C(1,4),1) + CALL WAXPY(NVAR,-4.0*amb(2),Jb,1,C(1,4),1) + CALL WAXPY(NVAR, 1.5*amb(1),Ha,1,C(1,4),1) + CALL WAXPY(NVAR,-0.5*amb(1),Hb,1,C(1,4),1) + +! c(5) = 15*amb(4)*ya - 15*amb(4)*yb - 8.*amb(3)*ja - 7*amb(3)*jb + 1.5*amb(2)*ha - 1*amb(2)*hb ; + CALL WCOPY(NVAR,Ya,1,C(1,5),1) + CALL WSCAL(NVAR, 15.0*amb(4),C(1,5),1) + CALL WAXPY(NVAR,-15.0*amb(4),Yb,1,C(1,5),1) + CALL WAXPY(NVAR,-8.0*amb(3),Ja,1,C(1,5),1) + CALL WAXPY(NVAR,-7.0*amb(3),Jb,1,C(1,5),1) + CALL WAXPY(NVAR,1.5*amb(2),Ha,1,C(1,5),1) + CALL WAXPY(NVAR,-amb(2),Hb,1,C(1,5),1) + +! c(6) = 6*amb(5)*ya - 6*amb(5)*yb - 3.*amb(4)*ja - 3.*amb(4)*jb + 0.5*amb(3)*ha -0.5*amb(3)*hb ; + CALL WCOPY(NVAR,Ya,1,C(1,6),1) + CALL WSCAL(NVAR, 6.0*amb(5),C(1,6),1) + CALL WAXPY(NVAR,-6.0*amb(5),Yb,1,C(1,6),1) + CALL WAXPY(NVAR,-3.0*amb(4),Ja,1,C(1,6),1) + CALL WAXPY(NVAR,-3.0*amb(4),Jb,1,C(1,6),1) + CALL WAXPY(NVAR, 0.5*amb(3),Ha,1,C(1,6),1) + CALL WAXPY(NVAR,-0.5*amb(3),Hb,1,C(1,6),1) + + Tau = T - a + CALL WCOPY(NVAR,C(1,6),1,Y,1) + DO j = 5,1,-1 + CALL WSCAL(NVAR,Tau,Y,1) + CALL WAXPY(NVAR,ONE,C(1,j),1,Y,1) + END DO + + END SUBROUTINE ros_Hermite5 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros2 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 2 stages, order 2 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + DOUBLE PRECISION g + + g = 1.0d0 + 1.0d0/SQRT(2.0d0) + + rosMethod = RS2 +!~~~> Name of the method + ros_Name = 'ROS-2' +!~~~> Number of stages + ros_S = 2 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = (1.d0)/g + ros_C(1) = (-2.d0)/g +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1)= (3.d0)/(2.d0*g) + ros_M(2)= (1.d0)/(2.d0*g) +! E_i = Coefficients for error estimator + ros_E(1) = 1.d0/(2.d0*g) + ros_E(2) = 1.d0/(2.d0*g) +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus one + ros_ELO = 2.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0d0 + ros_Alpha(2) = 1.0d0 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = g + ros_Gamma(2) =-g + + END SUBROUTINE Ros2 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros3 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + rosMethod = RS3 +!~~~> Name of the method + ros_Name = 'ROS-3' +!~~~> Number of stages + ros_S = 3 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1)= 1.d0 + ros_A(2)= 1.d0 + ros_A(3)= 0.d0 + + ros_C(1) = -0.10156171083877702091975600115545d+01 + ros_C(2) = 0.40759956452537699824805835358067d+01 + ros_C(3) = 0.92076794298330791242156818474003d+01 +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.1d+01 + ros_M(2) = 0.61697947043828245592553615689730d+01 + ros_M(3) = -0.42772256543218573326238373806514d+00 +! E_i = Coefficients for error estimator + ros_E(1) = 0.5d+00 + ros_E(2) = -0.29079558716805469821718236208017d+01 + ros_E(3) = 0.22354069897811569627360909276199d+00 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1)= 0.0d+00 + ros_Alpha(2)= 0.43586652150845899941601945119356d+00 + ros_Alpha(3)= 0.43586652150845899941601945119356d+00 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1)= 0.43586652150845899941601945119356d+00 + ros_Gamma(2)= 0.24291996454816804366592249683314d+00 + ros_Gamma(3)= 0.21851380027664058511513169485832d+01 + + END SUBROUTINE Ros3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros4 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES +! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1990) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + rosMethod = RS4 +!~~~> Name of the method + ros_Name = 'ROS-4' +!~~~> Number of stages + ros_S = 4 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.2000000000000000d+01 + ros_A(2) = 0.1867943637803922d+01 + ros_A(3) = 0.2344449711399156d+00 + ros_A(4) = ros_A(2) + ros_A(5) = ros_A(3) + ros_A(6) = 0.0D0 + + ros_C(1) =-0.7137615036412310d+01 + ros_C(2) = 0.2580708087951457d+01 + ros_C(3) = 0.6515950076447975d+00 + ros_C(4) =-0.2137148994382534d+01 + ros_C(5) =-0.3214669691237626d+00 + ros_C(6) =-0.6949742501781779d+00 +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.2255570073418735d+01 + ros_M(2) = 0.2870493262186792d+00 + ros_M(3) = 0.4353179431840180d+00 + ros_M(4) = 0.1093502252409163d+01 +!~~~> E_i = Coefficients for error estimator + ros_E(1) =-0.2815431932141155d+00 + ros_E(2) =-0.7276199124938920d-01 + ros_E(3) =-0.1082196201495311d+00 + ros_E(4) =-0.1093502252409163d+01 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.D0 + ros_Alpha(2) = 0.1145640000000000d+01 + ros_Alpha(3) = 0.6552168638155900d+00 + ros_Alpha(4) = ros_Alpha(3) +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5728200000000000d+00 + ros_Gamma(2) =-0.1769193891319233d+01 + ros_Gamma(3) = 0.7592633437920482d+00 + ros_Gamma(4) =-0.1049021087100450d+00 + + END SUBROUTINE Ros4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rodas3 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + rosMethod = RD3 +!~~~> Name of the method + ros_Name = 'RODAS-3' +!~~~> Number of stages + ros_S = 4 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.0d+00 + ros_A(2) = 2.0d+00 + ros_A(3) = 0.0d+00 + ros_A(4) = 2.0d+00 + ros_A(5) = 0.0d+00 + ros_A(6) = 1.0d+00 + + ros_C(1) = 4.0d+00 + ros_C(2) = 1.0d+00 + ros_C(3) =-1.0d+00 + ros_C(4) = 1.0d+00 + ros_C(5) =-1.0d+00 + ros_C(6) =-(8.0d+00/3.0d+00) + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .FALSE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 2.0d+00 + ros_M(2) = 0.0d+00 + ros_M(3) = 1.0d+00 + ros_M(4) = 1.0d+00 +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0d+00 + ros_E(2) = 0.0d+00 + ros_E(3) = 0.0d+00 + ros_E(4) = 1.0d+00 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0d+00 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0d+00 + ros_Alpha(2) = 0.0d+00 + ros_Alpha(3) = 1.0d+00 + ros_Alpha(4) = 1.0d+00 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5d+00 + ros_Gamma(2) = 1.5d+00 + ros_Gamma(3) = 0.0d+00 + ros_Gamma(4) = 0.0d+00 + + END SUBROUTINE Rodas3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rodas4 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1996) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + rosMethod = RD4 +!~~~> Name of the method + ros_Name = 'RODAS-4' +!~~~> Number of stages + ros_S = 6 + +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.000d0 + ros_Alpha(2) = 0.386d0 + ros_Alpha(3) = 0.210d0 + ros_Alpha(4) = 0.630d0 + ros_Alpha(5) = 1.000d0 + ros_Alpha(6) = 1.000d0 + +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.2500000000000000d+00 + ros_Gamma(2) =-0.1043000000000000d+00 + ros_Gamma(3) = 0.1035000000000000d+00 + ros_Gamma(4) =-0.3620000000000023d-01 + ros_Gamma(5) = 0.0d0 + ros_Gamma(6) = 0.0d0 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.1544000000000000d+01 + ros_A(2) = 0.9466785280815826d+00 + ros_A(3) = 0.2557011698983284d+00 + ros_A(4) = 0.3314825187068521d+01 + ros_A(5) = 0.2896124015972201d+01 + ros_A(6) = 0.9986419139977817d+00 + ros_A(7) = 0.1221224509226641d+01 + ros_A(8) = 0.6019134481288629d+01 + ros_A(9) = 0.1253708332932087d+02 + ros_A(10) =-0.6878860361058950d+00 + ros_A(11) = ros_A(7) + ros_A(12) = ros_A(8) + ros_A(13) = ros_A(9) + ros_A(14) = ros_A(10) + ros_A(15) = 1.0d+00 + + ros_C(1) =-0.5668800000000000d+01 + ros_C(2) =-0.2430093356833875d+01 + ros_C(3) =-0.2063599157091915d+00 + ros_C(4) =-0.1073529058151375d+00 + ros_C(5) =-0.9594562251023355d+01 + ros_C(6) =-0.2047028614809616d+02 + ros_C(7) = 0.7496443313967647d+01 + ros_C(8) =-0.1024680431464352d+02 + ros_C(9) =-0.3399990352819905d+02 + ros_C(10) = 0.1170890893206160d+02 + ros_C(11) = 0.8083246795921522d+01 + ros_C(12) =-0.7981132988064893d+01 + ros_C(13) =-0.3152159432874371d+02 + ros_C(14) = 0.1631930543123136d+02 + ros_C(15) =-0.6058818238834054d+01 + +!~~~> M_i = Coefficients for new step solution + ros_M(1) = ros_A(7) + ros_M(2) = ros_A(8) + ros_M(3) = ros_A(9) + ros_M(4) = ros_A(10) + ros_M(5) = 1.0d+00 + ros_M(6) = 1.0d+00 + +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0d+00 + ros_E(2) = 0.0d+00 + ros_E(3) = 0.0d+00 + ros_E(4) = 0.0d+00 + ros_E(5) = 0.0d+00 + ros_E(6) = 1.0d+00 + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. + ros_NewF(5) = .TRUE. + ros_NewF(6) = .TRUE. + +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0d0 + + END SUBROUTINE Rodas4 + + +END SUBROUTINE RosenbrockADJ ! and its internal procedures + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE FunTemplate( T, Y, Ydot ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE function call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Input variables + REAL(kind=dp), INTENT(IN) :: T, Y(NVAR) +!~~~> Output variables + REAL(kind=dp), INTENT(OUT) :: Ydot(NVAR) +!~~~> Local variables + REAL(kind=dp) :: Told + +!!$ Told = TIME +!!$ TIME = T +!!$ CALL Update_SUN() +!!$ CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, Ydot ) +!!$ TIME = Told + +END SUBROUTINE FunTemplate + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE JacTemplate( T, Y, Jcb ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Jacobian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Input variables + REAL(kind=dp) :: T, Y(NVAR) +!~~~> Output variables +#ifdef FULL_ALGEBRA + REAL(kind=dp) :: JV(LU_NONZERO), Jcb(NVAR,NVAR) +#else + REAL(kind=dp) :: Jcb(LU_NONZERO) +#endif +!~~~> Local variables + REAL(kind=dp) :: Told +#ifdef FULL_ALGEBRA + INTEGER :: i, j +#endif + +!!$ Told = TIME +!!$ TIME = T +!!$ CALL Update_SUN() +!!$ CALL Update_RCONST() +#ifdef FULL_ALGEBRA + CALL Jac_SP(Y, FIX, RCONST, JV) + DO j=1,NVAR + DO i=1,NVAR + Jcb(i,j) = 0.0_dp + END DO + END DO + DO i=1,LU_NONZERO + Jcb(LU_IROW(i),LU_ICOL(i)) = JV(i) + END DO +#else + CALL Jac_SP( Y, FIX, RCONST, Jcb ) +#endif +!!$ TIME = Told + +END SUBROUTINE JacTemplate + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE HessTemplate( T, Y, Hes ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Hessian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Input variables + REAL(kind=dp), INTENT(IN) :: T, Y(NVAR) +!~~~> Output variables + REAL(kind=dp), INTENT(OUT) :: Hes(NHESS) +!~~~> Local variables + REAL(kind=dp) :: Told + +!!$ Told = TIME +!!$ TIME = T +!!$ CALL Update_SUN() +!!$ CALL Update_RCONST() + CALL Hessian( Y, FIX, RCONST, Hes ) +!!$ TIME = Told + +END SUBROUTINE HessTemplate + +END MODULE gckpp_adj_Integrator + + + + +! End of INTEGRATE function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + diff --git a/code/adjoint/gckpp_adj_Jacobian.f90 b/code/adjoint/gckpp_adj_Jacobian.f90 new file mode 100644 index 0000000..2808e25 --- /dev/null +++ b/code/adjoint/gckpp_adj_Jacobian.f90 @@ -0,0 +1,3582 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! The ODE Jacobian of Chemical Model File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Jacobian.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_Jacobian + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + IMPLICIT NONE + +CONTAINS + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Jac_SP - the Jacobian of Variables in sparse matrix representation +! Arguments : +! V - Concentrations of variable species (local) +! F - Concentrations of fixed species (local) +! RCT - Rate constants (local) +! JVS - sparse Jacobian of variables +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE Jac_SP ( V, F, RCT, JVS ) + +! V - Concentrations of variable species (local) + REAL(kind=dp) :: V(NVAR) +! F - Concentrations of fixed species (local) + REAL(kind=dp) :: F(NFIX) +! RCT - Rate constants (local) + REAL(kind=dp) :: RCT(NREACT) +! JVS - sparse Jacobian of variables + REAL(kind=dp) :: JVS(LU_NONZERO) + + +! Local variables +! B - Temporary array + REAL(kind=dp) :: B(527) + +! B(1) = dA(1)/dV(85) + B(1) = RCT(1)*V(89) +! B(2) = dA(1)/dV(89) + B(2) = RCT(1)*V(85) +! B(3) = dA(2)/dV(83) + B(3) = RCT(2)*V(89) +! B(4) = dA(2)/dV(89) + B(4) = RCT(2)*V(83) +! B(5) = dA(3)/dV(84) + B(5) = RCT(3)*V(89) +! B(6) = dA(3)/dV(89) + B(6) = RCT(3)*V(84) +! B(7) = dA(4)/dV(82) + B(7) = RCT(4)*V(89) +! B(8) = dA(4)/dV(89) + B(8) = RCT(4)*V(82) +! B(9) = dA(5)/dV(89) + B(9) = RCT(5)*V(90) +! B(10) = dA(5)/dV(90) + B(10) = RCT(5)*V(89) +! B(11) = dA(6)/dV(83) + B(11) = RCT(6)*2*V(83) +! B(12) = dA(7)/dV(83) + B(12) = RCT(7)*2*V(83) +! B(13) = dA(8)/dV(83) + B(13) = RCT(8)*V(84) +! B(14) = dA(8)/dV(84) + B(14) = RCT(8)*V(83) +! B(15) = dA(9)/dV(17) + B(15) = RCT(9)*V(83) +! B(16) = dA(9)/dV(83) + B(16) = RCT(9)*V(17) +! B(17) = dA(10)/dV(84) + B(17) = RCT(10)*V(85) +! B(18) = dA(10)/dV(85) + B(18) = RCT(10)*V(84) +! B(19) = dA(11)/dV(84) + B(19) = RCT(11)*2*V(84) +! B(20) = dA(12)/dV(83) + B(20) = RCT(12)*F(9) +! B(22) = dA(13)/dV(47) + B(22) = RCT(13)*V(83) +! B(23) = dA(13)/dV(83) + B(23) = RCT(13)*V(47) +! B(24) = dA(14)/dV(83) + B(24) = RCT(14)*F(2) +! B(26) = dA(15)/dV(85) + B(26) = RCT(15)*V(90) +! B(27) = dA(15)/dV(90) + B(27) = RCT(15)*V(85) +! B(28) = dA(16)/dV(84) + B(28) = RCT(16)*V(90) +! B(29) = dA(16)/dV(90) + B(29) = RCT(16)*V(84) +! B(30) = dA(17)/dV(90) + B(30) = RCT(17)*2*V(90) +! B(31) = dA(18)/dV(90) + B(31) = RCT(18)*2*V(90) +! B(32) = dA(19)/dV(28) + B(32) = RCT(19)*V(83) +! B(33) = dA(19)/dV(83) + B(33) = RCT(19)*V(28) +! B(34) = dA(20)/dV(28) + B(34) = RCT(20)*V(83) +! B(35) = dA(20)/dV(83) + B(35) = RCT(20)*V(28) +! B(36) = dA(21)/dV(69) + B(36) = RCT(21)*V(83) +! B(37) = dA(21)/dV(83) + B(37) = RCT(21)*V(69) +! B(38) = dA(22)/dV(82) + B(38) = RCT(22)*V(83) +! B(39) = dA(22)/dV(83) + B(39) = RCT(22)*V(82) +! B(40) = dA(23)/dV(56) + B(40) = RCT(23)*V(83) +! B(41) = dA(23)/dV(83) + B(41) = RCT(23)*V(56) +! B(42) = dA(24)/dV(83) + B(42) = RCT(24)*V(85) +! B(43) = dA(24)/dV(85) + B(43) = RCT(24)*V(83) +! B(44) = dA(25)/dV(24) + B(44) = RCT(25)*V(83) +! B(45) = dA(25)/dV(83) + B(45) = RCT(25)*V(24) +! B(46) = dA(26)/dV(82) + B(46) = RCT(26)*V(84) +! B(47) = dA(26)/dV(84) + B(47) = RCT(26)*V(82) +! B(48) = dA(27)/dV(29) + B(48) = RCT(27) +! B(49) = dA(28)/dV(29) + B(49) = RCT(28)*V(83) +! B(50) = dA(28)/dV(83) + B(50) = RCT(28)*V(29) +! B(51) = dA(29)/dV(84) + B(51) = RCT(29)*V(87) +! B(52) = dA(29)/dV(87) + B(52) = RCT(29)*V(84) +! B(53) = dA(30)/dV(85) + B(53) = RCT(30)*V(87) +! B(54) = dA(30)/dV(87) + B(54) = RCT(30)*V(85) +! B(55) = dA(31)/dV(83) + B(55) = RCT(31)*V(87) +! B(56) = dA(31)/dV(87) + B(56) = RCT(31)*V(83) +! B(57) = dA(32)/dV(82) + B(57) = RCT(32)*V(87) +! B(58) = dA(32)/dV(87) + B(58) = RCT(32)*V(82) +! B(59) = dA(33)/dV(25) + B(59) = RCT(33) +! B(60) = dA(34)/dV(83) + B(60) = RCT(34)*F(11) +! B(62) = dA(35)/dV(83) + B(62) = RCT(35)*F(13) +! B(64) = dA(36)/dV(82) + B(64) = RCT(36)*V(87) +! B(65) = dA(36)/dV(87) + B(65) = RCT(36)*V(82) +! B(66) = dA(37)/dV(69) + B(66) = RCT(37)*V(87) +! B(67) = dA(37)/dV(87) + B(67) = RCT(37)*V(69) +! B(68) = dA(38)/dV(71) + B(68) = RCT(38)*V(83) +! B(69) = dA(38)/dV(83) + B(69) = RCT(38)*V(71) +! B(70) = dA(39)/dV(71) + B(70) = RCT(39)*V(87) +! B(71) = dA(39)/dV(87) + B(71) = RCT(39)*V(71) +! B(72) = dA(40)/dV(82) + B(72) = RCT(40)*V(86) +! B(73) = dA(40)/dV(86) + B(73) = RCT(40)*V(82) +! B(74) = dA(41)/dV(21) + B(74) = RCT(41) +! B(75) = dA(42)/dV(85) + B(75) = RCT(42)*V(86) +! B(76) = dA(42)/dV(86) + B(76) = RCT(42)*V(85) +! B(77) = dA(43)/dV(23) + B(77) = RCT(43)*V(83) +! B(78) = dA(43)/dV(83) + B(78) = RCT(43)*V(23) +! B(79) = dA(44)/dV(74) + B(79) = RCT(44)*V(85) +! B(80) = dA(44)/dV(85) + B(80) = RCT(44)*V(74) +! B(81) = dA(45)/dV(16) + B(81) = RCT(45)*V(83) +! B(82) = dA(45)/dV(83) + B(82) = RCT(45)*V(16) +! B(83) = dA(46)/dV(16) + B(83) = RCT(46)*V(83) +! B(84) = dA(46)/dV(83) + B(84) = RCT(46)*V(16) +! B(85) = dA(47)/dV(52) + B(85) = RCT(47)*V(85) +! B(86) = dA(47)/dV(85) + B(86) = RCT(47)*V(52) +! B(87) = dA(48)/dV(70) + B(87) = RCT(48)*V(85) +! B(88) = dA(48)/dV(85) + B(88) = RCT(48)*V(70) +! B(89) = dA(49)/dV(22) + B(89) = RCT(49)*V(83) +! B(90) = dA(49)/dV(83) + B(90) = RCT(49)*V(22) +! B(91) = dA(50)/dV(72) + B(91) = RCT(50)*V(85) +! B(92) = dA(50)/dV(85) + B(92) = RCT(50)*V(72) +! B(93) = dA(51)/dV(72) + B(93) = RCT(51)*V(85) +! B(94) = dA(51)/dV(85) + B(94) = RCT(51)*V(72) +! B(95) = dA(52)/dV(54) + B(95) = RCT(52)*V(85) +! B(96) = dA(52)/dV(85) + B(96) = RCT(52)*V(54) +! B(97) = dA(53)/dV(62) + B(97) = RCT(53)*V(85) +! B(98) = dA(53)/dV(85) + B(98) = RCT(53)*V(62) +! B(99) = dA(54)/dV(60) + B(99) = RCT(54)*V(85) +! B(100) = dA(54)/dV(85) + B(100) = RCT(54)*V(60) +! B(101) = dA(55)/dV(79) + B(101) = RCT(55)*V(85) +! B(102) = dA(55)/dV(85) + B(102) = RCT(55)*V(79) +! B(103) = dA(56)/dV(79) + B(103) = RCT(56)*V(85) +! B(104) = dA(56)/dV(85) + B(104) = RCT(56)*V(79) +! B(105) = dA(57)/dV(57) + B(105) = RCT(57)*V(85) +! B(106) = dA(57)/dV(85) + B(106) = RCT(57)*V(57) +! B(107) = dA(58)/dV(57) + B(107) = RCT(58)*V(85) +! B(108) = dA(58)/dV(85) + B(108) = RCT(58)*V(57) +! B(109) = dA(59)/dV(66) + B(109) = RCT(59)*V(85) +! B(110) = dA(59)/dV(85) + B(110) = RCT(59)*V(66) +! B(111) = dA(60)/dV(65) + B(111) = RCT(60)*V(85) +! B(112) = dA(60)/dV(85) + B(112) = RCT(60)*V(65) +! B(113) = dA(61)/dV(64) + B(113) = RCT(61)*V(85) +! B(114) = dA(61)/dV(85) + B(114) = RCT(61)*V(64) +! B(115) = dA(62)/dV(64) + B(115) = RCT(62)*V(85) +! B(116) = dA(62)/dV(85) + B(116) = RCT(62)*V(64) +! B(117) = dA(63)/dV(59) + B(117) = RCT(63)*V(85) +! B(118) = dA(63)/dV(85) + B(118) = RCT(63)*V(59) +! B(119) = dA(64)/dV(59) + B(119) = RCT(64)*V(85) +! B(120) = dA(64)/dV(85) + B(120) = RCT(64)*V(59) +! B(121) = dA(65)/dV(51) + B(121) = RCT(65)*V(85) +! B(122) = dA(65)/dV(85) + B(122) = RCT(65)*V(51) +! B(123) = dA(66)/dV(55) + B(123) = RCT(66)*V(85) +! B(124) = dA(66)/dV(85) + B(124) = RCT(66)*V(55) +! B(125) = dA(67)/dV(53) + B(125) = RCT(67)*V(85) +! B(126) = dA(67)/dV(85) + B(126) = RCT(67)*V(53) +! B(127) = dA(68)/dV(67) + B(127) = RCT(68)*V(85) +! B(128) = dA(68)/dV(85) + B(128) = RCT(68)*V(67) +! B(129) = dA(69)/dV(63) + B(129) = RCT(69)*V(85) +! B(130) = dA(69)/dV(85) + B(130) = RCT(69)*V(63) +! B(131) = dA(70)/dV(22) + B(131) = RCT(70)*V(87) +! B(132) = dA(70)/dV(87) + B(132) = RCT(70)*V(22) +! B(133) = dA(71)/dV(73) + B(133) = RCT(71)*V(83) +! B(134) = dA(71)/dV(83) + B(134) = RCT(71)*V(73) +! B(135) = dA(72)/dV(83) + B(135) = RCT(72)*F(1) +! B(137) = dA(73)/dV(68) + B(137) = RCT(73)*V(83) +! B(138) = dA(73)/dV(83) + B(138) = RCT(73)*V(68) +! B(139) = dA(74)/dV(81) + B(139) = RCT(74)*V(82) +! B(140) = dA(74)/dV(82) + B(140) = RCT(74)*V(81) +! B(141) = dA(75)/dV(18) + B(141) = RCT(75) +! B(142) = dA(76)/dV(82) + B(142) = RCT(76)*V(88) +! B(143) = dA(76)/dV(88) + B(143) = RCT(76)*V(82) +! B(144) = dA(77)/dV(19) + B(144) = RCT(77) +! B(145) = dA(78)/dV(78) + B(145) = RCT(78)*V(82) +! B(146) = dA(78)/dV(82) + B(146) = RCT(78)*V(78) +! B(147) = dA(79)/dV(44) + B(147) = RCT(79) +! B(148) = dA(80)/dV(82) + B(148) = RCT(80)*F(5) +! B(151) = dA(82)/dV(81) + B(151) = RCT(82)*V(85) +! B(152) = dA(82)/dV(85) + B(152) = RCT(82)*V(81) +! B(153) = dA(83)/dV(85) + B(153) = RCT(83)*V(88) +! B(154) = dA(83)/dV(88) + B(154) = RCT(83)*V(85) +! B(155) = dA(84)/dV(78) + B(155) = RCT(84)*V(85) +! B(156) = dA(84)/dV(85) + B(156) = RCT(84)*V(78) +! B(157) = dA(85)/dV(85) + B(157) = RCT(85)*F(5) +! B(159) = dA(86)/dV(68) + B(159) = RCT(86)*V(87) +! B(160) = dA(86)/dV(87) + B(160) = RCT(86)*V(68) +! B(161) = dA(87)/dV(49) + B(161) = RCT(87)*V(83) +! B(162) = dA(87)/dV(83) + B(162) = RCT(87)*V(49) +! B(163) = dA(88)/dV(49) + B(163) = RCT(88)*V(83) +! B(164) = dA(88)/dV(83) + B(164) = RCT(88)*V(49) +! B(165) = dA(89)/dV(52) + B(165) = RCT(89)*V(90) +! B(166) = dA(89)/dV(90) + B(166) = RCT(89)*V(52) +! B(167) = dA(90)/dV(70) + B(167) = RCT(90)*V(90) +! B(168) = dA(90)/dV(90) + B(168) = RCT(90)*V(70) +! B(169) = dA(91)/dV(72) + B(169) = RCT(91)*V(84) +! B(170) = dA(91)/dV(84) + B(170) = RCT(91)*V(72) +! B(171) = dA(92)/dV(54) + B(171) = RCT(92)*V(84) +! B(172) = dA(92)/dV(84) + B(172) = RCT(92)*V(54) +! B(173) = dA(93)/dV(62) + B(173) = RCT(93)*V(84) +! B(174) = dA(93)/dV(84) + B(174) = RCT(93)*V(62) +! B(175) = dA(94)/dV(60) + B(175) = RCT(94)*V(84) +! B(176) = dA(94)/dV(84) + B(176) = RCT(94)*V(60) +! B(177) = dA(95)/dV(79) + B(177) = RCT(95)*V(84) +! B(178) = dA(95)/dV(84) + B(178) = RCT(95)*V(79) +! B(179) = dA(96)/dV(57) + B(179) = RCT(96)*V(84) +! B(180) = dA(96)/dV(84) + B(180) = RCT(96)*V(57) +! B(181) = dA(97)/dV(66) + B(181) = RCT(97)*V(84) +! B(182) = dA(97)/dV(84) + B(182) = RCT(97)*V(66) +! B(183) = dA(98)/dV(65) + B(183) = RCT(98)*V(84) +! B(184) = dA(98)/dV(84) + B(184) = RCT(98)*V(65) +! B(185) = dA(99)/dV(64) + B(185) = RCT(99)*V(84) +! B(186) = dA(99)/dV(84) + B(186) = RCT(99)*V(64) +! B(187) = dA(100)/dV(59) + B(187) = RCT(100)*V(84) +! B(188) = dA(100)/dV(84) + B(188) = RCT(100)*V(59) +! B(189) = dA(101)/dV(51) + B(189) = RCT(101)*V(84) +! B(190) = dA(101)/dV(84) + B(190) = RCT(101)*V(51) +! B(191) = dA(102)/dV(55) + B(191) = RCT(102)*V(84) +! B(192) = dA(102)/dV(84) + B(192) = RCT(102)*V(55) +! B(193) = dA(103)/dV(53) + B(193) = RCT(103)*V(84) +! B(194) = dA(103)/dV(84) + B(194) = RCT(103)*V(53) +! B(195) = dA(104)/dV(67) + B(195) = RCT(104)*V(84) +! B(196) = dA(104)/dV(84) + B(196) = RCT(104)*V(67) +! B(197) = dA(105)/dV(63) + B(197) = RCT(105)*V(84) +! B(198) = dA(105)/dV(84) + B(198) = RCT(105)*V(63) +! B(199) = dA(106)/dV(76) + B(199) = RCT(106)*V(83) +! B(200) = dA(106)/dV(83) + B(200) = RCT(106)*V(76) +! B(201) = dA(107)/dV(74) + B(201) = RCT(107)*V(90) +! B(202) = dA(107)/dV(90) + B(202) = RCT(107)*V(74) +! B(203) = dA(108)/dV(76) + B(203) = RCT(108)*V(87) +! B(204) = dA(108)/dV(87) + B(204) = RCT(108)*V(76) +! B(205) = dA(109)/dV(72) + B(205) = RCT(109)*V(90) +! B(206) = dA(109)/dV(90) + B(206) = RCT(109)*V(72) +! B(207) = dA(110)/dV(54) + B(207) = RCT(110)*V(90) +! B(208) = dA(110)/dV(90) + B(208) = RCT(110)*V(54) +! B(209) = dA(111)/dV(62) + B(209) = RCT(111)*V(90) +! B(210) = dA(111)/dV(90) + B(210) = RCT(111)*V(62) +! B(211) = dA(112)/dV(60) + B(211) = RCT(112)*V(90) +! B(212) = dA(112)/dV(90) + B(212) = RCT(112)*V(60) +! B(213) = dA(113)/dV(79) + B(213) = RCT(113)*V(90) +! B(214) = dA(113)/dV(90) + B(214) = RCT(113)*V(79) +! B(215) = dA(114)/dV(57) + B(215) = RCT(114)*V(90) +! B(216) = dA(114)/dV(90) + B(216) = RCT(114)*V(57) +! B(217) = dA(115)/dV(66) + B(217) = RCT(115)*V(90) +! B(218) = dA(115)/dV(90) + B(218) = RCT(115)*V(66) +! B(219) = dA(116)/dV(65) + B(219) = RCT(116)*V(90) +! B(220) = dA(116)/dV(90) + B(220) = RCT(116)*V(65) +! B(221) = dA(117)/dV(64) + B(221) = RCT(117)*V(90) +! B(222) = dA(117)/dV(90) + B(222) = RCT(117)*V(64) +! B(223) = dA(118)/dV(59) + B(223) = RCT(118)*V(90) +! B(224) = dA(118)/dV(90) + B(224) = RCT(118)*V(59) +! B(225) = dA(119)/dV(51) + B(225) = RCT(119)*V(90) +! B(226) = dA(119)/dV(90) + B(226) = RCT(119)*V(51) +! B(227) = dA(120)/dV(55) + B(227) = RCT(120)*V(90) +! B(228) = dA(120)/dV(90) + B(228) = RCT(120)*V(55) +! B(229) = dA(121)/dV(53) + B(229) = RCT(121)*V(90) +! B(230) = dA(121)/dV(90) + B(230) = RCT(121)*V(53) +! B(231) = dA(122)/dV(67) + B(231) = RCT(122)*V(90) +! B(232) = dA(122)/dV(90) + B(232) = RCT(122)*V(67) +! B(233) = dA(123)/dV(63) + B(233) = RCT(123)*V(90) +! B(234) = dA(123)/dV(90) + B(234) = RCT(123)*V(63) +! B(235) = dA(124)/dV(83) + B(235) = RCT(124)*F(4) +! B(237) = dA(125)/dV(83) + B(237) = RCT(125)*F(16) +! B(239) = dA(126)/dV(74) + B(239) = RCT(126)*2*V(74) +! B(240) = dA(127)/dV(74) + B(240) = RCT(127)*2*V(74) +! B(241) = dA(128)/dV(74) + B(241) = RCT(128)*V(84) +! B(242) = dA(128)/dV(84) + B(242) = RCT(128)*V(74) +! B(243) = dA(129)/dV(52) + B(243) = RCT(129)*V(84) +! B(244) = dA(129)/dV(84) + B(244) = RCT(129)*V(52) +! B(245) = dA(130)/dV(70) + B(245) = RCT(130)*V(84) +! B(246) = dA(130)/dV(84) + B(246) = RCT(130)*V(70) +! B(247) = dA(131)/dV(84) + B(247) = RCT(131)*V(86) +! B(248) = dA(131)/dV(86) + B(248) = RCT(131)*V(84) +! B(249) = dA(132)/dV(81) + B(249) = RCT(132)*V(84) +! B(250) = dA(132)/dV(84) + B(250) = RCT(132)*V(81) +! B(251) = dA(133)/dV(84) + B(251) = RCT(133)*V(88) +! B(252) = dA(133)/dV(88) + B(252) = RCT(133)*V(84) +! B(253) = dA(134)/dV(78) + B(253) = RCT(134)*V(84) +! B(254) = dA(134)/dV(84) + B(254) = RCT(134)*V(78) +! B(255) = dA(135)/dV(84) + B(255) = RCT(135)*F(5) +! B(257) = dA(136)/dV(48) + B(257) = RCT(136)*V(83) +! B(258) = dA(136)/dV(83) + B(258) = RCT(136)*V(48) +! B(259) = dA(137)/dV(48) + B(259) = RCT(137)*V(89) +! B(260) = dA(137)/dV(89) + B(260) = RCT(137)*V(48) +! B(261) = dA(138)/dV(44) + B(261) = RCT(138)*V(83) +! B(262) = dA(138)/dV(83) + B(262) = RCT(138)*V(44) +! B(263) = dA(139)/dV(44) + B(263) = RCT(139)*V(89) +! B(264) = dA(139)/dV(89) + B(264) = RCT(139)*V(44) +! B(265) = dA(140)/dV(50) + B(265) = RCT(140)*V(83) +! B(266) = dA(140)/dV(83) + B(266) = RCT(140)*V(50) +! B(267) = dA(141)/dV(48) + B(267) = RCT(141)*V(87) +! B(268) = dA(141)/dV(87) + B(268) = RCT(141)*V(48) +! B(269) = dA(142)/dV(83) + B(269) = RCT(142)*F(8) +! B(271) = dA(143)/dV(75) + B(271) = RCT(143)*V(83) +! B(272) = dA(143)/dV(83) + B(272) = RCT(143)*V(75) +! B(273) = dA(144)/dV(87) + B(273) = RCT(144)*F(8) +! B(275) = dA(145)/dV(75) + B(275) = RCT(145)*V(87) +! B(276) = dA(145)/dV(87) + B(276) = RCT(145)*V(75) +! B(277) = dA(146)/dV(46) + B(277) = RCT(146)*V(83) +! B(278) = dA(146)/dV(83) + B(278) = RCT(146)*V(46) +! B(279) = dA(147)/dV(77) + B(279) = RCT(147)*V(83) +! B(280) = dA(147)/dV(83) + B(280) = RCT(147)*V(77) +! B(281) = dA(148)/dV(80) + B(281) = RCT(148)*V(83) +! B(282) = dA(148)/dV(83) + B(282) = RCT(148)*V(80) +! B(283) = dA(149)/dV(61) + B(283) = RCT(149)*V(83) +! B(284) = dA(149)/dV(83) + B(284) = RCT(149)*V(61) +! B(285) = dA(150)/dV(52) + B(285) = RCT(150)*V(86) +! B(286) = dA(150)/dV(86) + B(286) = RCT(150)*V(52) +! B(287) = dA(151)/dV(70) + B(287) = RCT(151)*V(86) +! B(288) = dA(151)/dV(86) + B(288) = RCT(151)*V(70) +! B(289) = dA(152)/dV(52) + B(289) = RCT(152)*V(86) +! B(290) = dA(152)/dV(86) + B(290) = RCT(152)*V(52) +! B(291) = dA(153)/dV(70) + B(291) = RCT(153)*V(86) +! B(292) = dA(153)/dV(86) + B(292) = RCT(153)*V(70) +! B(293) = dA(154)/dV(46) + B(293) = RCT(154)*V(89) +! B(294) = dA(154)/dV(89) + B(294) = RCT(154)*V(46) +! B(295) = dA(155)/dV(77) + B(295) = RCT(155)*V(89) +! B(296) = dA(155)/dV(89) + B(296) = RCT(155)*V(77) +! B(297) = dA(156)/dV(80) + B(297) = RCT(156)*V(89) +! B(298) = dA(156)/dV(89) + B(298) = RCT(156)*V(80) +! B(299) = dA(157)/dV(46) + B(299) = RCT(157)*V(87) +! B(300) = dA(157)/dV(87) + B(300) = RCT(157)*V(46) +! B(301) = dA(158)/dV(80) + B(301) = RCT(158)*V(87) +! B(302) = dA(158)/dV(87) + B(302) = RCT(158)*V(80) +! B(303) = dA(159)/dV(80) + B(303) = RCT(159)*V(87) +! B(304) = dA(159)/dV(87) + B(304) = RCT(159)*V(80) +! B(305) = dA(160)/dV(81) + B(305) = RCT(160)*V(90) +! B(306) = dA(160)/dV(90) + B(306) = RCT(160)*V(81) +! B(307) = dA(161)/dV(88) + B(307) = RCT(161)*V(90) +! B(308) = dA(161)/dV(90) + B(308) = RCT(161)*V(88) +! B(309) = dA(162)/dV(78) + B(309) = RCT(162)*V(90) +! B(310) = dA(162)/dV(90) + B(310) = RCT(162)*V(78) +! B(311) = dA(163)/dV(90) + B(311) = RCT(163)*F(5) +! B(313) = dA(164)/dV(81) + B(313) = RCT(164)*V(90) +! B(314) = dA(164)/dV(90) + B(314) = RCT(164)*V(81) +! B(315) = dA(165)/dV(88) + B(315) = RCT(165)*V(90) +! B(316) = dA(165)/dV(90) + B(316) = RCT(165)*V(88) +! B(317) = dA(166)/dV(78) + B(317) = RCT(166)*V(90) +! B(318) = dA(166)/dV(90) + B(318) = RCT(166)*V(78) +! B(319) = dA(167)/dV(90) + B(319) = RCT(167)*F(5) +! B(321) = dA(168)/dV(39) + B(321) = RCT(168)*V(83) +! B(322) = dA(168)/dV(83) + B(322) = RCT(168)*V(39) +! B(323) = dA(169)/dV(38) + B(323) = RCT(169)*V(83) +! B(324) = dA(169)/dV(83) + B(324) = RCT(169)*V(38) +! B(325) = dA(170)/dV(35) + B(325) = RCT(170)*V(83) +! B(326) = dA(170)/dV(83) + B(326) = RCT(170)*V(35) +! B(327) = dA(171)/dV(31) + B(327) = RCT(171)*V(83) +! B(328) = dA(171)/dV(83) + B(328) = RCT(171)*V(31) +! B(329) = dA(172)/dV(32) + B(329) = RCT(172)*V(83) +! B(330) = dA(172)/dV(83) + B(330) = RCT(172)*V(32) +! B(331) = dA(173)/dV(30) + B(331) = RCT(173)*V(83) +! B(332) = dA(173)/dV(83) + B(332) = RCT(173)*V(30) +! B(333) = dA(174)/dV(33) + B(333) = RCT(174)*V(83) +! B(334) = dA(174)/dV(83) + B(334) = RCT(174)*V(33) +! B(335) = dA(175)/dV(37) + B(335) = RCT(175)*V(83) +! B(336) = dA(175)/dV(83) + B(336) = RCT(175)*V(37) +! B(337) = dA(176)/dV(36) + B(337) = RCT(176)*V(83) +! B(338) = dA(176)/dV(83) + B(338) = RCT(176)*V(36) +! B(339) = dA(177)/dV(83) + B(339) = RCT(177)*F(6) +! B(341) = dA(178)/dV(45) + B(341) = RCT(178)*V(83) +! B(342) = dA(178)/dV(83) + B(342) = RCT(178)*V(45) +! B(343) = dA(179)/dV(41) + B(343) = RCT(179)*V(83) +! B(344) = dA(179)/dV(83) + B(344) = RCT(179)*V(41) +! B(345) = dA(180)/dV(43) + B(345) = RCT(180)*V(83) +! B(346) = dA(180)/dV(83) + B(346) = RCT(180)*V(43) +! B(347) = dA(181)/dV(42) + B(347) = RCT(181)*V(83) +! B(348) = dA(181)/dV(83) + B(348) = RCT(181)*V(42) +! B(349) = dA(182)/dV(40) + B(349) = RCT(182)*V(83) +! B(350) = dA(182)/dV(83) + B(350) = RCT(182)*V(40) +! B(351) = dA(183)/dV(26) + B(351) = RCT(183)*V(83) +! B(352) = dA(183)/dV(83) + B(352) = RCT(183)*V(26) +! B(353) = dA(184)/dV(27) + B(353) = RCT(184)*V(83) +! B(354) = dA(184)/dV(83) + B(354) = RCT(184)*V(27) +! B(355) = dA(185)/dV(23) + B(355) = RCT(185)*V(87) +! B(356) = dA(185)/dV(87) + B(356) = RCT(185)*V(23) +! B(357) = dA(186)/dV(83) + B(357) = RCT(186)*F(12) +! B(359) = dA(187)/dV(58) + B(359) = RCT(187)*V(83) +! B(360) = dA(187)/dV(83) + B(360) = RCT(187)*V(58) +! B(361) = dA(188)/dV(58) + B(361) = RCT(188)*V(89) +! B(362) = dA(188)/dV(89) + B(362) = RCT(188)*V(58) +! B(363) = dA(189)/dV(86) + B(363) = RCT(189)*2*V(86) +! B(364) = dA(190)/dV(86) + B(364) = RCT(190)*V(90) +! B(365) = dA(190)/dV(90) + B(365) = RCT(190)*V(86) +! B(366) = dA(191)/dV(86) + B(366) = RCT(191)*V(90) +! B(367) = dA(191)/dV(90) + B(367) = RCT(191)*V(86) +! B(368) = dA(192)/dV(72) + B(368) = RCT(192)*V(86) +! B(369) = dA(192)/dV(86) + B(369) = RCT(192)*V(72) +! B(370) = dA(193)/dV(62) + B(370) = RCT(193)*V(86) +! B(371) = dA(193)/dV(86) + B(371) = RCT(193)*V(62) +! B(372) = dA(194)/dV(60) + B(372) = RCT(194)*V(86) +! B(373) = dA(194)/dV(86) + B(373) = RCT(194)*V(60) +! B(374) = dA(195)/dV(79) + B(374) = RCT(195)*V(86) +! B(375) = dA(195)/dV(86) + B(375) = RCT(195)*V(79) +! B(376) = dA(196)/dV(57) + B(376) = RCT(196)*V(86) +! B(377) = dA(196)/dV(86) + B(377) = RCT(196)*V(57) +! B(378) = dA(197)/dV(66) + B(378) = RCT(197)*V(86) +! B(379) = dA(197)/dV(86) + B(379) = RCT(197)*V(66) +! B(380) = dA(198)/dV(65) + B(380) = RCT(198)*V(86) +! B(381) = dA(198)/dV(86) + B(381) = RCT(198)*V(65) +! B(382) = dA(199)/dV(64) + B(382) = RCT(199)*V(86) +! B(383) = dA(199)/dV(86) + B(383) = RCT(199)*V(64) +! B(384) = dA(200)/dV(59) + B(384) = RCT(200)*V(86) +! B(385) = dA(200)/dV(86) + B(385) = RCT(200)*V(59) +! B(386) = dA(201)/dV(53) + B(386) = RCT(201)*V(86) +! B(387) = dA(201)/dV(86) + B(387) = RCT(201)*V(53) +! B(388) = dA(202)/dV(54) + B(388) = RCT(202)*V(86) +! B(389) = dA(202)/dV(86) + B(389) = RCT(202)*V(54) +! B(390) = dA(203)/dV(51) + B(390) = RCT(203)*V(86) +! B(391) = dA(203)/dV(86) + B(391) = RCT(203)*V(51) +! B(392) = dA(204)/dV(55) + B(392) = RCT(204)*V(86) +! B(393) = dA(204)/dV(86) + B(393) = RCT(204)*V(55) +! B(394) = dA(205)/dV(67) + B(394) = RCT(205)*V(86) +! B(395) = dA(205)/dV(86) + B(395) = RCT(205)*V(67) +! B(396) = dA(206)/dV(63) + B(396) = RCT(206)*V(86) +! B(397) = dA(206)/dV(86) + B(397) = RCT(206)*V(63) +! B(398) = dA(207)/dV(72) + B(398) = RCT(207)*V(86) +! B(399) = dA(207)/dV(86) + B(399) = RCT(207)*V(72) +! B(400) = dA(208)/dV(62) + B(400) = RCT(208)*V(86) +! B(401) = dA(208)/dV(86) + B(401) = RCT(208)*V(62) +! B(402) = dA(209)/dV(60) + B(402) = RCT(209)*V(86) +! B(403) = dA(209)/dV(86) + B(403) = RCT(209)*V(60) +! B(404) = dA(210)/dV(79) + B(404) = RCT(210)*V(86) +! B(405) = dA(210)/dV(86) + B(405) = RCT(210)*V(79) +! B(406) = dA(211)/dV(57) + B(406) = RCT(211)*V(86) +! B(407) = dA(211)/dV(86) + B(407) = RCT(211)*V(57) +! B(408) = dA(212)/dV(66) + B(408) = RCT(212)*V(86) +! B(409) = dA(212)/dV(86) + B(409) = RCT(212)*V(66) +! B(410) = dA(213)/dV(64) + B(410) = RCT(213)*V(86) +! B(411) = dA(213)/dV(86) + B(411) = RCT(213)*V(64) +! B(412) = dA(214)/dV(59) + B(412) = RCT(214)*V(86) +! B(413) = dA(214)/dV(86) + B(413) = RCT(214)*V(59) +! B(414) = dA(215)/dV(54) + B(414) = RCT(215)*V(86) +! B(415) = dA(215)/dV(86) + B(415) = RCT(215)*V(54) +! B(416) = dA(216)/dV(65) + B(416) = RCT(216)*V(86) +! B(417) = dA(216)/dV(86) + B(417) = RCT(216)*V(65) +! B(418) = dA(217)/dV(51) + B(418) = RCT(217)*V(86) +! B(419) = dA(217)/dV(86) + B(419) = RCT(217)*V(51) +! B(420) = dA(218)/dV(55) + B(420) = RCT(218)*V(86) +! B(421) = dA(218)/dV(86) + B(421) = RCT(218)*V(55) +! B(422) = dA(219)/dV(67) + B(422) = RCT(219)*V(86) +! B(423) = dA(219)/dV(86) + B(423) = RCT(219)*V(67) +! B(424) = dA(220)/dV(63) + B(424) = RCT(220)*V(86) +! B(425) = dA(220)/dV(86) + B(425) = RCT(220)*V(63) +! B(426) = dA(221)/dV(53) + B(426) = RCT(221)*V(86) +! B(427) = dA(221)/dV(86) + B(427) = RCT(221)*V(53) +! B(428) = dA(222)/dV(74) + B(428) = RCT(222)*V(86) +! B(429) = dA(222)/dV(86) + B(429) = RCT(222)*V(74) +! B(430) = dA(223)/dV(74) + B(430) = RCT(223)*V(86) +! B(431) = dA(223)/dV(86) + B(431) = RCT(223)*V(74) +! B(432) = dA(224)/dV(81) + B(432) = RCT(224)*V(86) +! B(433) = dA(224)/dV(86) + B(433) = RCT(224)*V(81) +! B(434) = dA(225)/dV(86) + B(434) = RCT(225)*V(88) +! B(435) = dA(225)/dV(88) + B(435) = RCT(225)*V(86) +! B(436) = dA(226)/dV(78) + B(436) = RCT(226)*V(86) +! B(437) = dA(226)/dV(86) + B(437) = RCT(226)*V(78) +! B(438) = dA(227)/dV(86) + B(438) = RCT(227)*F(5) +! B(440) = dA(228)/dV(87) + B(440) = RCT(228)*2*V(87) +! B(455) = dA(243)/dV(82) + B(455) = RCT(243) +! B(456) = dA(244)/dV(89) + B(456) = RCT(244) +! B(457) = dA(245)/dV(21) + B(457) = RCT(245) +! B(458) = dA(246)/dV(56) + B(458) = RCT(246) +! B(459) = dA(247)/dV(69) + B(459) = RCT(247) +! B(460) = dA(248)/dV(25) + B(460) = RCT(248) +! B(461) = dA(249)/dV(17) + B(461) = RCT(249) +! B(462) = dA(250)/dV(44) + B(462) = RCT(250) +! B(463) = dA(251)/dV(18) + B(463) = RCT(251) +! B(464) = dA(252)/dV(73) + B(464) = RCT(252) +! B(465) = dA(253)/dV(84) + B(465) = RCT(253) +! B(466) = dA(254)/dV(82) + B(466) = RCT(254) +! B(467) = dA(255)/dV(87) + B(467) = RCT(255) +! B(468) = dA(256)/dV(25) + B(468) = RCT(256) +! B(469) = dA(257)/dV(34) + B(469) = RCT(257)*V(83) +! B(470) = dA(257)/dV(83) + B(470) = RCT(257)*V(34) +! B(471) = dA(258)/dV(34) + B(471) = RCT(258)*V(83) +! B(472) = dA(258)/dV(83) + B(472) = RCT(258)*V(34) +! B(473) = dA(259)/dV(34) + B(473) = RCT(259)*V(87) +! B(474) = dA(259)/dV(87) + B(474) = RCT(259)*V(34) +! B(475) = dA(260)/dV(20) + B(475) = RCT(260)*V(83) +! B(476) = dA(260)/dV(83) + B(476) = RCT(260)*V(20) +! B(477) = dA(261)/dV(89) + B(477) = RCT(261) +! B(478) = dA(262)/dV(82) + B(478) = RCT(262) +! B(479) = dA(263)/dV(17) + B(479) = RCT(263) +! B(480) = dA(264)/dV(28) + B(480) = RCT(264) +! B(481) = dA(265)/dV(69) + B(481) = RCT(265) +! B(482) = dA(266)/dV(69) + B(482) = RCT(266) +! B(483) = dA(267)/dV(56) + B(483) = RCT(267) +! B(484) = dA(268)/dV(24) + B(484) = RCT(268) +! B(485) = dA(269)/dV(29) + B(485) = RCT(269) +! B(486) = dA(270)/dV(87) + B(486) = RCT(270) +! B(487) = dA(271)/dV(87) + B(487) = RCT(271) +! B(488) = dA(272)/dV(25) + B(488) = RCT(272) +! B(489) = dA(273)/dV(25) + B(489) = RCT(273) +! B(490) = dA(274)/dV(29) + B(490) = RCT(274) +! B(491) = dA(275)/dV(71) + B(491) = RCT(275) +! B(492) = dA(276)/dV(71) + B(492) = RCT(276) +! B(493) = dA(277)/dV(21) + B(493) = RCT(277) +! B(494) = dA(278)/dV(68) + B(494) = RCT(278) +! B(495) = dA(279)/dV(49) + B(495) = RCT(279) +! B(496) = dA(280)/dV(49) + B(496) = RCT(280) +! B(497) = dA(281)/dV(76) + B(497) = RCT(281) +! B(499) = dA(283)/dV(50) + B(499) = RCT(283) +! B(502) = dA(286)/dV(75) + B(502) = RCT(286) +! B(503) = dA(287)/dV(75) + B(503) = RCT(287) +! B(504) = dA(288)/dV(77) + B(504) = RCT(288) +! B(505) = dA(289)/dV(77) + B(505) = RCT(289) +! B(506) = dA(290)/dV(77) + B(506) = RCT(290) +! B(507) = dA(291)/dV(80) + B(507) = RCT(291) +! B(508) = dA(292)/dV(80) + B(508) = RCT(292) +! B(509) = dA(293)/dV(61) + B(509) = RCT(293) +! B(510) = dA(294)/dV(39) + B(510) = RCT(294) +! B(511) = dA(295)/dV(38) + B(511) = RCT(295) +! B(512) = dA(296)/dV(35) + B(512) = RCT(296) +! B(513) = dA(297)/dV(31) + B(513) = RCT(297) +! B(514) = dA(298)/dV(32) + B(514) = RCT(298) +! B(515) = dA(299)/dV(30) + B(515) = RCT(299) +! B(516) = dA(300)/dV(37) + B(516) = RCT(300) +! B(517) = dA(301)/dV(33) + B(517) = RCT(301) +! B(518) = dA(302)/dV(36) + B(518) = RCT(302) +! B(520) = dA(304)/dV(45) + B(520) = RCT(304) +! B(521) = dA(305)/dV(41) + B(521) = RCT(305) +! B(522) = dA(306)/dV(43) + B(522) = RCT(306) +! B(523) = dA(307)/dV(42) + B(523) = RCT(307) +! B(524) = dA(308)/dV(40) + B(524) = RCT(308) +! B(525) = dA(309)/dV(26) + B(525) = RCT(309) +! B(526) = dA(310)/dV(73) + B(526) = RCT(310) +! B(527) = dA(311)/dV(27) + B(527) = RCT(311) + +! Construct the Jacobian terms from B's +! JVS(1) = Jac_FULL(1,1) + JVS(1) = 0 +! JVS(2) = Jac_FULL(1,69) + JVS(2) = B(459) +! JVS(3) = Jac_FULL(2,2) + JVS(3) = 0 +! JVS(4) = Jac_FULL(2,17) + JVS(4) = B(461) +! JVS(5) = Jac_FULL(3,3) + JVS(5) = 0 +! JVS(6) = Jac_FULL(3,56) + JVS(6) = B(458) +! JVS(7) = Jac_FULL(4,4) + JVS(7) = 0 +! JVS(8) = Jac_FULL(4,25) + JVS(8) = B(460) +! JVS(9) = Jac_FULL(5,5) + JVS(9) = 0 +! JVS(10) = Jac_FULL(5,82) + JVS(10) = B(455) +! JVS(11) = Jac_FULL(6,6) + JVS(11) = 0 +! JVS(12) = Jac_FULL(6,89) + JVS(12) = B(456) +! JVS(13) = Jac_FULL(7,7) + JVS(13) = 0 +! JVS(14) = Jac_FULL(7,21) + JVS(14) = B(457) +! JVS(15) = Jac_FULL(8,8) + JVS(15) = 0 +! JVS(16) = Jac_FULL(8,44) + JVS(16) = B(462) +! JVS(17) = Jac_FULL(9,9) + JVS(17) = 0 +! JVS(18) = Jac_FULL(9,18) + JVS(18) = B(463) +! JVS(19) = Jac_FULL(10,10) + JVS(19) = 0 +! JVS(20) = Jac_FULL(10,73) + JVS(20) = B(464) +! JVS(21) = Jac_FULL(11,11) + JVS(21) = 0 +! JVS(22) = Jac_FULL(11,20) + JVS(22) = B(475) +! JVS(23) = Jac_FULL(11,83) + JVS(23) = B(476) +! JVS(24) = Jac_FULL(12,12) + JVS(24) = 0 +! JVS(25) = Jac_FULL(12,34) + JVS(25) = 0.25*B(471) +! JVS(26) = Jac_FULL(12,83) + JVS(26) = 0.25*B(472) +! JVS(27) = Jac_FULL(13,13) + JVS(27) = 0 +! JVS(28) = Jac_FULL(13,46) + JVS(28) = 0.15*B(293) +! JVS(29) = Jac_FULL(13,47) + JVS(29) = B(22) +! JVS(30) = Jac_FULL(13,80) + JVS(30) = 0.16*B(297) +! JVS(31) = Jac_FULL(13,83) + JVS(31) = B(23)+B(60)+B(135) +! JVS(32) = Jac_FULL(13,85) + JVS(32) = B(75) +! JVS(33) = Jac_FULL(13,86) + JVS(33) = B(76) +! JVS(34) = Jac_FULL(13,89) + JVS(34) = 0.15*B(294)+0.16*B(298) +! JVS(35) = Jac_FULL(14,14) + JVS(35) = 0 +! JVS(36) = Jac_FULL(14,17) + JVS(36) = B(461) +! JVS(37) = Jac_FULL(14,18) + JVS(37) = B(463) +! JVS(38) = Jac_FULL(14,21) + JVS(38) = B(457) +! JVS(39) = Jac_FULL(14,25) + JVS(39) = B(460) +! JVS(40) = Jac_FULL(14,44) + JVS(40) = B(462) +! JVS(41) = Jac_FULL(14,56) + JVS(41) = B(458) +! JVS(42) = Jac_FULL(14,69) + JVS(42) = B(459) +! JVS(43) = Jac_FULL(14,73) + JVS(43) = B(464) +! JVS(44) = Jac_FULL(14,82) + JVS(44) = B(455) +! JVS(45) = Jac_FULL(14,89) + JVS(45) = B(456) +! JVS(46) = Jac_FULL(15,15) + JVS(46) = 0 +! JVS(47) = Jac_FULL(15,46) + JVS(47) = B(277) +! JVS(48) = Jac_FULL(15,83) + JVS(48) = B(278) +! JVS(49) = Jac_FULL(16,16) + JVS(49) = -B(81)-B(83) +! JVS(50) = Jac_FULL(16,83) + JVS(50) = -B(82)-B(84) +! JVS(51) = Jac_FULL(17,17) + JVS(51) = -B(15)-B(461)-B(479) +! JVS(52) = Jac_FULL(17,83) + JVS(52) = B(12)-B(16) +! JVS(53) = Jac_FULL(17,84) + JVS(53) = B(19)+0.5*B(465) +! JVS(54) = Jac_FULL(18,18) + JVS(54) = -B(141)-B(463) +! JVS(55) = Jac_FULL(18,81) + JVS(55) = B(139) +! JVS(56) = Jac_FULL(18,82) + JVS(56) = B(140) +! JVS(57) = Jac_FULL(19,19) + JVS(57) = -B(144) +! JVS(58) = Jac_FULL(19,82) + JVS(58) = B(142) +! JVS(59) = Jac_FULL(19,88) + JVS(59) = B(143) +! JVS(60) = Jac_FULL(20,20) + JVS(60) = -B(475) +! JVS(61) = Jac_FULL(20,34) + JVS(61) = B(469)+0.75*B(471)+B(473) +! JVS(62) = Jac_FULL(20,83) + JVS(62) = B(470)+0.75*B(472)-B(476) +! JVS(63) = Jac_FULL(20,87) + JVS(63) = B(474) +! JVS(64) = Jac_FULL(21,21) + JVS(64) = -B(74)-B(457)-B(493) +! JVS(65) = Jac_FULL(21,82) + JVS(65) = B(72) +! JVS(66) = Jac_FULL(21,86) + JVS(66) = B(73) +! JVS(67) = Jac_FULL(22,22) + JVS(67) = -B(89)-B(131) +! JVS(68) = Jac_FULL(22,83) + JVS(68) = -B(90) +! JVS(69) = Jac_FULL(22,87) + JVS(69) = -B(132) +! JVS(70) = Jac_FULL(23,23) + JVS(70) = -B(77)-B(355) +! JVS(71) = Jac_FULL(23,83) + JVS(71) = -B(78) +! JVS(72) = Jac_FULL(23,87) + JVS(72) = -B(356) +! JVS(73) = Jac_FULL(24,24) + JVS(73) = -B(44)-B(484) +! JVS(74) = Jac_FULL(24,82) + JVS(74) = 0.5*B(466) +! JVS(75) = Jac_FULL(24,83) + JVS(75) = B(42)-B(45) +! JVS(76) = Jac_FULL(24,85) + JVS(76) = B(43) +! JVS(77) = Jac_FULL(25,25) + JVS(77) = -B(59)-B(460)-B(468)-B(488)-B(489) +! JVS(78) = Jac_FULL(25,82) + JVS(78) = B(57) +! JVS(79) = Jac_FULL(25,87) + JVS(79) = B(58) +! JVS(80) = Jac_FULL(26,26) + JVS(80) = -B(351)-B(525) +! JVS(81) = Jac_FULL(26,78) + JVS(81) = 0.7*B(253) +! JVS(82) = Jac_FULL(26,83) + JVS(82) = -B(352) +! JVS(83) = Jac_FULL(26,84) + JVS(83) = 0.7*B(254) +! JVS(84) = Jac_FULL(27,27) + JVS(84) = -B(353)-B(527) +! JVS(85) = Jac_FULL(27,83) + JVS(85) = -B(354) +! JVS(86) = Jac_FULL(27,84) + JVS(86) = 0.41*B(247) +! JVS(87) = Jac_FULL(27,86) + JVS(87) = 0.41*B(248) +! JVS(88) = Jac_FULL(28,28) + JVS(88) = -B(32)-B(34)-B(480) +! JVS(89) = Jac_FULL(28,83) + JVS(89) = -B(33)-B(35) +! JVS(90) = Jac_FULL(28,84) + JVS(90) = B(28) +! JVS(91) = Jac_FULL(28,90) + JVS(91) = B(29) +! JVS(92) = Jac_FULL(29,29) + JVS(92) = -B(48)-B(49)-B(485)-B(490) +! JVS(93) = Jac_FULL(29,82) + JVS(93) = B(46) +! JVS(94) = Jac_FULL(29,83) + JVS(94) = -B(50) +! JVS(95) = Jac_FULL(29,84) + JVS(95) = B(47) +! JVS(96) = Jac_FULL(30,30) + JVS(96) = -B(331)-B(515) +! JVS(97) = Jac_FULL(30,72) + JVS(97) = B(169) +! JVS(98) = Jac_FULL(30,83) + JVS(98) = -B(332) +! JVS(99) = Jac_FULL(30,84) + JVS(99) = B(170) +! JVS(100) = Jac_FULL(31,31) + JVS(100) = -B(327)-B(513) +! JVS(101) = Jac_FULL(31,52) + JVS(101) = B(243) +! JVS(102) = Jac_FULL(31,83) + JVS(102) = -B(328) +! JVS(103) = Jac_FULL(31,84) + JVS(103) = B(244) +! JVS(104) = Jac_FULL(32,32) + JVS(104) = -B(329)-B(514) +! JVS(105) = Jac_FULL(32,53) + JVS(105) = B(193) +! JVS(106) = Jac_FULL(32,83) + JVS(106) = -B(330) +! JVS(107) = Jac_FULL(32,84) + JVS(107) = B(194) +! JVS(108) = Jac_FULL(33,33) + JVS(108) = -B(333)-B(517) +! JVS(109) = Jac_FULL(33,81) + JVS(109) = 0.7*B(249) +! JVS(110) = Jac_FULL(33,83) + JVS(110) = -B(334) +! JVS(111) = Jac_FULL(33,84) + JVS(111) = 0.7*B(250) +! JVS(112) = Jac_FULL(34,34) + JVS(112) = -B(469)-B(471)-B(473) +! JVS(113) = Jac_FULL(34,83) + JVS(113) = -B(470)-B(472) +! JVS(114) = Jac_FULL(34,87) + JVS(114) = -B(474) +! JVS(115) = Jac_FULL(35,35) + JVS(115) = -B(325)-B(512) +! JVS(116) = Jac_FULL(35,74) + JVS(116) = B(241) +! JVS(117) = Jac_FULL(35,83) + JVS(117) = -B(326) +! JVS(118) = Jac_FULL(35,84) + JVS(118) = B(242) +! JVS(119) = Jac_FULL(36,36) + JVS(119) = -B(337)-B(518) +! JVS(120) = Jac_FULL(36,83) + JVS(120) = -B(338) +! JVS(121) = Jac_FULL(36,84) + JVS(121) = 0.71*B(251) +! JVS(122) = Jac_FULL(36,88) + JVS(122) = 0.71*B(252) +! JVS(123) = Jac_FULL(37,37) + JVS(123) = -B(335)-B(516) +! JVS(124) = Jac_FULL(37,70) + JVS(124) = B(245) +! JVS(125) = Jac_FULL(37,83) + JVS(125) = -B(336) +! JVS(126) = Jac_FULL(37,84) + JVS(126) = B(246) +! JVS(127) = Jac_FULL(38,38) + JVS(127) = -B(323)-B(511) +! JVS(128) = Jac_FULL(38,63) + JVS(128) = B(197) +! JVS(129) = Jac_FULL(38,83) + JVS(129) = -B(324) +! JVS(130) = Jac_FULL(38,84) + JVS(130) = B(198) +! JVS(131) = Jac_FULL(39,39) + JVS(131) = -B(321)-B(510) +! JVS(132) = Jac_FULL(39,67) + JVS(132) = B(195) +! JVS(133) = Jac_FULL(39,83) + JVS(133) = -B(322) +! JVS(134) = Jac_FULL(39,84) + JVS(134) = B(196) +! JVS(135) = Jac_FULL(40,40) + JVS(135) = -B(349)-B(524) +! JVS(136) = Jac_FULL(40,59) + JVS(136) = B(187) +! JVS(137) = Jac_FULL(40,83) + JVS(137) = -B(350) +! JVS(138) = Jac_FULL(40,84) + JVS(138) = B(188) +! JVS(139) = Jac_FULL(41,41) + JVS(139) = -B(343)-B(521) +! JVS(140) = Jac_FULL(41,66) + JVS(140) = B(181) +! JVS(141) = Jac_FULL(41,83) + JVS(141) = -B(344) +! JVS(142) = Jac_FULL(41,84) + JVS(142) = B(182) +! JVS(143) = Jac_FULL(42,42) + JVS(143) = -B(347)-B(523) +! JVS(144) = Jac_FULL(42,64) + JVS(144) = B(185) +! JVS(145) = Jac_FULL(42,83) + JVS(145) = -B(348) +! JVS(146) = Jac_FULL(42,84) + JVS(146) = B(186) +! JVS(147) = Jac_FULL(43,43) + JVS(147) = -B(345)-B(522) +! JVS(148) = Jac_FULL(43,51) + JVS(148) = B(189) +! JVS(149) = Jac_FULL(43,55) + JVS(149) = B(191) +! JVS(150) = Jac_FULL(43,65) + JVS(150) = B(183) +! JVS(151) = Jac_FULL(43,83) + JVS(151) = -B(346) +! JVS(152) = Jac_FULL(43,84) + JVS(152) = B(184)+B(190)+B(192) +! JVS(153) = Jac_FULL(44,44) + JVS(153) = -B(147)-B(261)-B(263)-B(462) +! JVS(154) = Jac_FULL(44,78) + JVS(154) = B(145) +! JVS(155) = Jac_FULL(44,82) + JVS(155) = B(146) +! JVS(156) = Jac_FULL(44,83) + JVS(156) = -B(262) +! JVS(157) = Jac_FULL(44,89) + JVS(157) = -B(264) +! JVS(158) = Jac_FULL(45,45) + JVS(158) = -B(341)-B(520) +! JVS(159) = Jac_FULL(45,57) + JVS(159) = B(179) +! JVS(160) = Jac_FULL(45,79) + JVS(160) = B(177) +! JVS(161) = Jac_FULL(45,83) + JVS(161) = -B(342) +! JVS(162) = Jac_FULL(45,84) + JVS(162) = B(178)+B(180) +! JVS(163) = Jac_FULL(46,46) + JVS(163) = -B(277)-B(293)-B(299) +! JVS(164) = Jac_FULL(46,83) + JVS(164) = -B(278) +! JVS(165) = Jac_FULL(46,87) + JVS(165) = -B(300) +! JVS(166) = Jac_FULL(46,89) + JVS(166) = -B(294) +! JVS(167) = Jac_FULL(47,40) + JVS(167) = 0.5*B(524) +! JVS(168) = Jac_FULL(47,41) + JVS(168) = 0.67*B(521) +! JVS(169) = Jac_FULL(47,46) + JVS(169) = 0.05*B(293) +! JVS(170) = Jac_FULL(47,47) + JVS(170) = -B(22) +! JVS(171) = Jac_FULL(47,48) + JVS(171) = 0.42*B(259) +! JVS(172) = Jac_FULL(47,49) + JVS(172) = B(496) +! JVS(173) = Jac_FULL(47,50) + JVS(173) = 0.4*B(265)+B(499) +! JVS(174) = Jac_FULL(47,58) + JVS(174) = 0.4*B(361) +! JVS(175) = Jac_FULL(47,59) + JVS(175) = 0.15*B(223)+0.83*B(384) +! JVS(176) = Jac_FULL(47,66) + JVS(176) = 0.61*B(109)+0.33*B(217)+0.65*B(378) +! JVS(177) = Jac_FULL(47,68) + JVS(177) = B(494) +! JVS(178) = Jac_FULL(47,69) + JVS(178) = B(36)+B(66)+B(481)+B(482) +! JVS(179) = Jac_FULL(47,71) + JVS(179) = 0.05*B(68)+B(491)+B(492) +! JVS(180) = Jac_FULL(47,75) + JVS(180) = B(271)+B(275)+B(502)+B(503) +! JVS(181) = Jac_FULL(47,77) + JVS(181) = 0.05*B(295)+B(504)+B(505) +! JVS(182) = Jac_FULL(47,80) + JVS(182) = 0.2*B(297)+B(508) +! JVS(183) = Jac_FULL(47,83) + JVS(183) = -B(23)+B(37)+0.05*B(69)+0.4*B(266)+2*B(269)+B(272)+0.5*B(339) +! JVS(184) = Jac_FULL(47,84) + JVS(184) = 0 +! JVS(185) = Jac_FULL(47,85) + JVS(185) = 0.61*B(110)+B(157) +! JVS(186) = Jac_FULL(47,86) + JVS(186) = 0.65*B(379)+0.83*B(385)+B(438) +! JVS(187) = Jac_FULL(47,87) + JVS(187) = B(67)+2*B(273)+B(276) +! JVS(188) = Jac_FULL(47,89) + JVS(188) = 0.42*B(260)+0.05*B(294)+0.05*B(296)+0.2*B(298)+0.4*B(362) +! JVS(189) = Jac_FULL(47,90) + JVS(189) = 0.33*B(218)+0.15*B(224)+B(311) +! JVS(190) = Jac_FULL(48,46) + JVS(190) = 0.07*B(293) +! JVS(191) = Jac_FULL(48,48) + JVS(191) = -B(257)-B(259)-B(267) +! JVS(192) = Jac_FULL(48,77) + JVS(192) = B(504) +! JVS(193) = Jac_FULL(48,83) + JVS(193) = -B(258) +! JVS(194) = Jac_FULL(48,87) + JVS(194) = -B(268) +! JVS(195) = Jac_FULL(48,89) + JVS(195) = -B(260)+0.07*B(294) +! JVS(196) = Jac_FULL(49,32) + JVS(196) = 0.5*B(329)+B(514) +! JVS(197) = Jac_FULL(49,49) + JVS(197) = -B(161)-B(163)-B(495)-B(496) +! JVS(198) = Jac_FULL(49,53) + JVS(198) = B(125)+0.75*B(229)+B(386)+B(426) +! JVS(199) = Jac_FULL(49,72) + JVS(199) = 0.32*B(91)+0.16*B(205)+0.32*B(368) +! JVS(200) = Jac_FULL(49,73) + JVS(200) = 0.32*B(526) +! JVS(201) = Jac_FULL(49,83) + JVS(201) = -B(162)-B(164)+0.5*B(330) +! JVS(202) = Jac_FULL(49,84) + JVS(202) = 0 +! JVS(203) = Jac_FULL(49,85) + JVS(203) = 0.32*B(92)+B(126) +! JVS(204) = Jac_FULL(49,86) + JVS(204) = 0.32*B(369)+B(387)+B(427) +! JVS(205) = Jac_FULL(49,90) + JVS(205) = 0.16*B(206)+0.75*B(230) +! JVS(206) = Jac_FULL(50,41) + JVS(206) = 0.26*B(521) +! JVS(207) = Jac_FULL(50,42) + JVS(207) = 0.7*B(523) +! JVS(208) = Jac_FULL(50,50) + JVS(208) = -B(265)-B(499) +! JVS(209) = Jac_FULL(50,51) + JVS(209) = 0.6*B(121) +! JVS(210) = Jac_FULL(50,58) + JVS(210) = 0.28*B(361) +! JVS(211) = Jac_FULL(50,64) + JVS(211) = 0.72*B(113)+0.36*B(221)+0.72*B(382) +! JVS(212) = Jac_FULL(50,65) + JVS(212) = 0.95*B(111)+0.5*B(219)+B(380) +! JVS(213) = Jac_FULL(50,66) + JVS(213) = 0.24*B(109)+0.13*B(217)+0.26*B(378) +! JVS(214) = Jac_FULL(50,83) + JVS(214) = -B(266) +! JVS(215) = Jac_FULL(50,84) + JVS(215) = 0 +! JVS(216) = Jac_FULL(50,85) + JVS(216) = 0.24*B(110)+0.95*B(112)+0.72*B(114)+0.6*B(122) +! JVS(217) = Jac_FULL(50,86) + JVS(217) = 0.26*B(379)+B(381)+0.72*B(383) +! JVS(218) = Jac_FULL(50,89) + JVS(218) = 0.28*B(362) +! JVS(219) = Jac_FULL(50,90) + JVS(219) = 0.13*B(218)+0.5*B(220)+0.36*B(222) +! JVS(220) = Jac_FULL(51,51) + JVS(220) = -B(121)-B(189)-B(225)-B(390)-B(418) +! JVS(221) = Jac_FULL(51,84) + JVS(221) = -B(190) +! JVS(222) = Jac_FULL(51,85) + JVS(222) = -B(122) +! JVS(223) = Jac_FULL(51,86) + JVS(223) = -B(391)-B(419) +! JVS(224) = Jac_FULL(51,90) + JVS(224) = -B(226) +! JVS(225) = Jac_FULL(52,16) + JVS(225) = B(83) +! JVS(226) = Jac_FULL(52,31) + JVS(226) = 0.5*B(327) +! JVS(227) = Jac_FULL(52,52) + JVS(227) = -B(85)-B(165)-B(243)-B(285)-B(289) +! JVS(228) = Jac_FULL(52,72) + JVS(228) = 0.05*B(91)+0.03*B(205)+0.05*B(368) +! JVS(229) = Jac_FULL(52,73) + JVS(229) = 0.05*B(526) +! JVS(230) = Jac_FULL(52,83) + JVS(230) = B(84)+0.5*B(328) +! JVS(231) = Jac_FULL(52,84) + JVS(231) = -B(244) +! JVS(232) = Jac_FULL(52,85) + JVS(232) = -B(86)+0.05*B(92) +! JVS(233) = Jac_FULL(52,86) + JVS(233) = -B(286)-B(290)+0.05*B(369) +! JVS(234) = Jac_FULL(52,90) + JVS(234) = -B(166)+0.03*B(206) +! JVS(235) = Jac_FULL(53,16) + JVS(235) = B(81) +! JVS(236) = Jac_FULL(53,32) + JVS(236) = 0.5*B(329) +! JVS(237) = Jac_FULL(53,53) + JVS(237) = -B(125)-B(193)-B(229)-B(386)-B(426) +! JVS(238) = Jac_FULL(53,72) + JVS(238) = 0.18*B(91)+0.09*B(205)+0.18*B(368) +! JVS(239) = Jac_FULL(53,73) + JVS(239) = 0.18*B(526) +! JVS(240) = Jac_FULL(53,83) + JVS(240) = B(82)+0.5*B(330) +! JVS(241) = Jac_FULL(53,84) + JVS(241) = -B(194) +! JVS(242) = Jac_FULL(53,85) + JVS(242) = 0.18*B(92)-B(126) +! JVS(243) = Jac_FULL(53,86) + JVS(243) = 0.18*B(369)-B(387)-B(427) +! JVS(244) = Jac_FULL(53,90) + JVS(244) = 0.09*B(206)-B(230) +! JVS(245) = Jac_FULL(54,54) + JVS(245) = -B(95)-B(171)-B(207)-B(388)-B(414) +! JVS(246) = Jac_FULL(54,73) + JVS(246) = B(133) +! JVS(247) = Jac_FULL(54,83) + JVS(247) = B(134) +! JVS(248) = Jac_FULL(54,84) + JVS(248) = -B(172) +! JVS(249) = Jac_FULL(54,85) + JVS(249) = -B(96) +! JVS(250) = Jac_FULL(54,86) + JVS(250) = -B(389)-B(415) +! JVS(251) = Jac_FULL(54,90) + JVS(251) = -B(208) +! JVS(252) = Jac_FULL(55,55) + JVS(252) = -B(123)-B(191)-B(227)-B(392)-B(420) +! JVS(253) = Jac_FULL(55,80) + JVS(253) = B(301) +! JVS(254) = Jac_FULL(55,84) + JVS(254) = -B(192) +! JVS(255) = Jac_FULL(55,85) + JVS(255) = -B(124) +! JVS(256) = Jac_FULL(55,86) + JVS(256) = -B(393)-B(421) +! JVS(257) = Jac_FULL(55,87) + JVS(257) = B(302) +! JVS(258) = Jac_FULL(55,90) + JVS(258) = -B(228) +! JVS(259) = Jac_FULL(56,22) + JVS(259) = B(131) +! JVS(260) = Jac_FULL(56,23) + JVS(260) = B(355) +! JVS(261) = Jac_FULL(56,25) + JVS(261) = 2*B(468) +! JVS(262) = Jac_FULL(56,34) + JVS(262) = B(473) +! JVS(263) = Jac_FULL(56,51) + JVS(263) = 0.1*B(121) +! JVS(264) = Jac_FULL(56,56) + JVS(264) = -B(40)-B(458)-B(483) +! JVS(265) = Jac_FULL(56,57) + JVS(265) = B(107) +! JVS(266) = Jac_FULL(56,59) + JVS(266) = B(119) +! JVS(267) = Jac_FULL(56,64) + JVS(267) = B(115) +! JVS(268) = Jac_FULL(56,65) + JVS(268) = 0.05*B(111) +! JVS(269) = Jac_FULL(56,66) + JVS(269) = 0.08*B(109) +! JVS(270) = Jac_FULL(56,67) + JVS(270) = 0.85*B(127)+0.425*B(231)+0.85*B(394) +! JVS(271) = Jac_FULL(56,68) + JVS(271) = B(159) +! JVS(272) = Jac_FULL(56,69) + JVS(272) = B(66) +! JVS(273) = Jac_FULL(56,71) + JVS(273) = B(70) +! JVS(274) = Jac_FULL(56,75) + JVS(274) = B(275) +! JVS(275) = Jac_FULL(56,76) + JVS(275) = B(203) +! JVS(276) = Jac_FULL(56,79) + JVS(276) = 0.1*B(101)+B(103) +! JVS(277) = Jac_FULL(56,80) + JVS(277) = B(303) +! JVS(278) = Jac_FULL(56,82) + JVS(278) = B(38)+0.5*B(466) +! JVS(279) = Jac_FULL(56,83) + JVS(279) = B(39)-B(41) +! JVS(280) = Jac_FULL(56,84) + JVS(280) = 0 +! JVS(281) = Jac_FULL(56,85) + JVS(281) = 0.1*B(102)+B(104)+B(108)+0.08*B(110)+0.05*B(112)+B(116)+B(120)+0.1*B(122)+0.85*B(128) +! JVS(282) = Jac_FULL(56,86) + JVS(282) = 0.85*B(395) +! JVS(283) = Jac_FULL(56,87) + JVS(283) = B(67)+B(71)+B(132)+B(160)+B(204)+B(273)+B(276)+B(304)+B(356)+B(467)+B(474) +! JVS(284) = Jac_FULL(56,90) + JVS(284) = 0.425*B(232) +! JVS(285) = Jac_FULL(57,57) + JVS(285) = -B(105)-B(107)-B(179)-B(215)-B(376)-B(406) +! JVS(286) = Jac_FULL(57,79) + JVS(286) = 0.07*B(213)+0.136*B(374) +! JVS(287) = Jac_FULL(57,84) + JVS(287) = -B(180) +! JVS(288) = Jac_FULL(57,85) + JVS(288) = -B(106)-B(108) +! JVS(289) = Jac_FULL(57,86) + JVS(289) = 0.136*B(375)-B(377)-B(407) +! JVS(290) = Jac_FULL(57,90) + JVS(290) = 0.07*B(214)-B(216) +! JVS(291) = Jac_FULL(58,45) + JVS(291) = 0.509*B(341)+0.373*B(520) +! JVS(292) = Jac_FULL(58,57) + JVS(292) = B(105)+0.5*B(215)+B(376) +! JVS(293) = Jac_FULL(58,58) + JVS(293) = -B(359)-B(361) +! JVS(294) = Jac_FULL(58,79) + JVS(294) = 0.34*B(101)+0.06*B(213)+0.127*B(374) +! JVS(295) = Jac_FULL(58,83) + JVS(295) = 0.509*B(342)-B(360) +! JVS(296) = Jac_FULL(58,84) + JVS(296) = 0 +! JVS(297) = Jac_FULL(58,85) + JVS(297) = 0.34*B(102)+B(106) +! JVS(298) = Jac_FULL(58,86) + JVS(298) = 0.127*B(375)+B(377) +! JVS(299) = Jac_FULL(58,89) + JVS(299) = -B(362) +! JVS(300) = Jac_FULL(58,90) + JVS(300) = 0.06*B(214)+0.5*B(216) +! JVS(301) = Jac_FULL(59,40) + JVS(301) = B(349) +! JVS(302) = Jac_FULL(59,59) + JVS(302) = -B(117)-B(119)-B(187)-B(223)-B(384)-B(412) +! JVS(303) = Jac_FULL(59,80) + JVS(303) = 0.43*B(281) +! JVS(304) = Jac_FULL(59,83) + JVS(304) = 0.43*B(282)+B(350) +! JVS(305) = Jac_FULL(59,84) + JVS(305) = -B(188) +! JVS(306) = Jac_FULL(59,85) + JVS(306) = -B(118)-B(120) +! JVS(307) = Jac_FULL(59,86) + JVS(307) = -B(385)-B(413) +! JVS(308) = Jac_FULL(59,90) + JVS(308) = -B(224) +! JVS(309) = Jac_FULL(60,60) + JVS(309) = -B(99)-B(175)-B(211)-B(372)-B(402) +! JVS(310) = Jac_FULL(60,76) + JVS(310) = B(199)+B(203) +! JVS(311) = Jac_FULL(60,83) + JVS(311) = B(200) +! JVS(312) = Jac_FULL(60,84) + JVS(312) = -B(176) +! JVS(313) = Jac_FULL(60,85) + JVS(313) = -B(100) +! JVS(314) = Jac_FULL(60,86) + JVS(314) = -B(373)-B(403) +! JVS(315) = Jac_FULL(60,87) + JVS(315) = B(204) +! JVS(316) = Jac_FULL(60,90) + JVS(316) = -B(212) +! JVS(317) = Jac_FULL(61,40) + JVS(317) = B(524) +! JVS(318) = Jac_FULL(61,41) + JVS(318) = 0.36*B(521) +! JVS(319) = Jac_FULL(61,44) + JVS(319) = 0.59*B(261) +! JVS(320) = Jac_FULL(61,58) + JVS(320) = 0.2*B(361) +! JVS(321) = Jac_FULL(61,59) + JVS(321) = B(117)+B(223)+0.83*B(384) +! JVS(322) = Jac_FULL(61,61) + JVS(322) = -B(283)-B(509) +! JVS(323) = Jac_FULL(61,62) + JVS(323) = 0.2*B(209) +! JVS(324) = Jac_FULL(61,65) + JVS(324) = 0.95*B(111)+0.5*B(219)+B(380) +! JVS(325) = Jac_FULL(61,66) + JVS(325) = 0.33*B(109)+0.18*B(217)+0.36*B(378) +! JVS(326) = Jac_FULL(61,70) + JVS(326) = 0.16*B(167)+0.65*B(291) +! JVS(327) = Jac_FULL(61,78) + JVS(327) = 0 +! JVS(328) = Jac_FULL(61,79) + JVS(328) = 0 +! JVS(329) = Jac_FULL(61,80) + JVS(329) = 0 +! JVS(330) = Jac_FULL(61,82) + JVS(330) = 0 +! JVS(331) = Jac_FULL(61,83) + JVS(331) = 0.59*B(262)-B(284) +! JVS(332) = Jac_FULL(61,84) + JVS(332) = 0 +! JVS(333) = Jac_FULL(61,85) + JVS(333) = 0.33*B(110)+0.95*B(112)+B(118) +! JVS(334) = Jac_FULL(61,86) + JVS(334) = 0.65*B(292)+0.36*B(379)+B(381)+0.83*B(385) +! JVS(335) = Jac_FULL(61,89) + JVS(335) = 0.2*B(362) +! JVS(336) = Jac_FULL(61,90) + JVS(336) = 0.16*B(168)+0.2*B(210)+0.18*B(218)+0.5*B(220)+B(224) +! JVS(337) = Jac_FULL(62,49) + JVS(337) = B(161)+B(163) +! JVS(338) = Jac_FULL(62,53) + JVS(338) = 0 +! JVS(339) = Jac_FULL(62,62) + JVS(339) = -B(97)-B(173)-B(209)-B(370)-B(400) +! JVS(340) = Jac_FULL(62,72) + JVS(340) = 0 +! JVS(341) = Jac_FULL(62,73) + JVS(341) = 0 +! JVS(342) = Jac_FULL(62,83) + JVS(342) = B(162)+B(164) +! JVS(343) = Jac_FULL(62,84) + JVS(343) = -B(174) +! JVS(344) = Jac_FULL(62,85) + JVS(344) = -B(98) +! JVS(345) = Jac_FULL(62,86) + JVS(345) = -B(371)-B(401) +! JVS(346) = Jac_FULL(62,90) + JVS(346) = -B(210) +! JVS(347) = Jac_FULL(63,38) + JVS(347) = B(323) +! JVS(348) = Jac_FULL(63,48) + JVS(348) = B(267) +! JVS(349) = Jac_FULL(63,63) + JVS(349) = -B(129)-B(197)-B(233)-B(396)-B(424) +! JVS(350) = Jac_FULL(63,77) + JVS(350) = 0 +! JVS(351) = Jac_FULL(63,83) + JVS(351) = B(324) +! JVS(352) = Jac_FULL(63,84) + JVS(352) = -B(198) +! JVS(353) = Jac_FULL(63,85) + JVS(353) = -B(130) +! JVS(354) = Jac_FULL(63,86) + JVS(354) = -B(397)-B(425) +! JVS(355) = Jac_FULL(63,87) + JVS(355) = B(268) +! JVS(356) = Jac_FULL(63,89) + JVS(356) = 0 +! JVS(357) = Jac_FULL(63,90) + JVS(357) = -B(234) +! JVS(358) = Jac_FULL(64,42) + JVS(358) = 0.5*B(347) +! JVS(359) = Jac_FULL(64,64) + JVS(359) = -B(113)-B(115)-B(185)-B(221)-B(382)-B(410) +! JVS(360) = Jac_FULL(64,77) + JVS(360) = B(279) +! JVS(361) = Jac_FULL(64,83) + JVS(361) = B(280)+0.5*B(348) +! JVS(362) = Jac_FULL(64,84) + JVS(362) = -B(186) +! JVS(363) = Jac_FULL(64,85) + JVS(363) = -B(114)-B(116) +! JVS(364) = Jac_FULL(64,86) + JVS(364) = -B(383)-B(411) +! JVS(365) = Jac_FULL(64,90) + JVS(365) = -B(222) +! JVS(366) = Jac_FULL(65,43) + JVS(366) = 0.5*B(345) +! JVS(367) = Jac_FULL(65,51) + JVS(367) = 0 +! JVS(368) = Jac_FULL(65,55) + JVS(368) = 0 +! JVS(369) = Jac_FULL(65,65) + JVS(369) = -B(111)-B(183)-B(219)-B(380)-B(416) +! JVS(370) = Jac_FULL(65,80) + JVS(370) = 0 +! JVS(371) = Jac_FULL(65,83) + JVS(371) = 0.5*B(346) +! JVS(372) = Jac_FULL(65,84) + JVS(372) = -B(184) +! JVS(373) = Jac_FULL(65,85) + JVS(373) = -B(112) +! JVS(374) = Jac_FULL(65,86) + JVS(374) = -B(381)-B(417) +! JVS(375) = Jac_FULL(65,87) + JVS(375) = 0 +! JVS(376) = Jac_FULL(65,90) + JVS(376) = -B(220) +! JVS(377) = Jac_FULL(66,41) + JVS(377) = B(343) +! JVS(378) = Jac_FULL(66,58) + JVS(378) = 0.44*B(359) +! JVS(379) = Jac_FULL(66,66) + JVS(379) = -B(109)-B(181)-B(217)-B(378)-B(408) +! JVS(380) = Jac_FULL(66,79) + JVS(380) = 0 +! JVS(381) = Jac_FULL(66,83) + JVS(381) = B(344)+0.44*B(360) +! JVS(382) = Jac_FULL(66,84) + JVS(382) = -B(182) +! JVS(383) = Jac_FULL(66,85) + JVS(383) = -B(110) +! JVS(384) = Jac_FULL(66,86) + JVS(384) = -B(379)-B(409) +! JVS(385) = Jac_FULL(66,89) + JVS(385) = 0 +! JVS(386) = Jac_FULL(66,90) + JVS(386) = -B(218) +! JVS(387) = Jac_FULL(67,39) + JVS(387) = B(321) +! JVS(388) = Jac_FULL(67,46) + JVS(388) = B(299) +! JVS(389) = Jac_FULL(67,67) + JVS(389) = -B(127)-B(195)-B(231)-B(394)-B(422) +! JVS(390) = Jac_FULL(67,83) + JVS(390) = B(322) +! JVS(391) = Jac_FULL(67,84) + JVS(391) = -B(196) +! JVS(392) = Jac_FULL(67,85) + JVS(392) = -B(128) +! JVS(393) = Jac_FULL(67,86) + JVS(393) = -B(395)-B(423) +! JVS(394) = Jac_FULL(67,87) + JVS(394) = B(300) +! JVS(395) = Jac_FULL(67,89) + JVS(395) = 0 +! JVS(396) = Jac_FULL(67,90) + JVS(396) = -B(232) +! JVS(397) = Jac_FULL(68,30) + JVS(397) = 0.5*B(331)+B(515) +! JVS(398) = Jac_FULL(68,31) + JVS(398) = 0.5*B(327)+B(513) +! JVS(399) = Jac_FULL(68,38) + JVS(399) = B(511) +! JVS(400) = Jac_FULL(68,39) + JVS(400) = B(510) +! JVS(401) = Jac_FULL(68,42) + JVS(401) = 0.5*B(347) +! JVS(402) = Jac_FULL(68,43) + JVS(402) = 0.5*B(345)+B(522) +! JVS(403) = Jac_FULL(68,51) + JVS(403) = 0.25*B(225)+B(418) +! JVS(404) = Jac_FULL(68,52) + JVS(404) = B(85)+0.75*B(165)+B(285)+B(289) +! JVS(405) = Jac_FULL(68,54) + JVS(405) = 0.57*B(95)+0.54*B(207)+0.57*B(388)+B(414) +! JVS(406) = Jac_FULL(68,55) + JVS(406) = 0.25*B(227)+B(420) +! JVS(407) = Jac_FULL(68,63) + JVS(407) = 0.25*B(233)+B(424) +! JVS(408) = Jac_FULL(68,64) + JVS(408) = 0 +! JVS(409) = Jac_FULL(68,65) + JVS(409) = 0.25*B(219)+B(416) +! JVS(410) = Jac_FULL(68,67) + JVS(410) = 0.25*B(231)+B(422) +! JVS(411) = Jac_FULL(68,68) + JVS(411) = -B(137)-B(159)-B(494) +! JVS(412) = Jac_FULL(68,70) + JVS(412) = 0.09*B(167)+0.35*B(291) +! JVS(413) = Jac_FULL(68,72) + JVS(413) = 0.13*B(91)+0.07*B(205)+0.13*B(368) +! JVS(414) = Jac_FULL(68,73) + JVS(414) = 0.13*B(526) +! JVS(415) = Jac_FULL(68,77) + JVS(415) = 0 +! JVS(416) = Jac_FULL(68,80) + JVS(416) = 0 +! JVS(417) = Jac_FULL(68,83) + JVS(417) = -B(138)+B(237)+0.5*B(328)+0.5*B(332)+0.5*B(346)+0.5*B(348) +! JVS(418) = Jac_FULL(68,84) + JVS(418) = 0 +! JVS(419) = Jac_FULL(68,85) + JVS(419) = B(86)+0.13*B(92)+0.57*B(96) +! JVS(420) = Jac_FULL(68,86) + JVS(420) = B(286)+B(290)+0.35*B(292)+0.13*B(369)+0.57*B(389)+B(415)+B(417)+B(419)+B(421)+B(423)+B(425) +! JVS(421) = Jac_FULL(68,87) + JVS(421) = -B(160) +! JVS(422) = Jac_FULL(68,89) + JVS(422) = 0 +! JVS(423) = Jac_FULL(68,90) + JVS(423) = 0.75*B(166)+0.09*B(168)+0.07*B(206)+0.54*B(208)+0.25*B(220)+0.25*B(226)+0.25*B(228)+0.25*B(232)+0.25*B(234) +! JVS(424) = Jac_FULL(69,26) + JVS(424) = B(525) +! JVS(425) = Jac_FULL(69,27) + JVS(425) = 0.5*B(353) +! JVS(426) = Jac_FULL(69,28) + JVS(426) = B(34)+B(480) +! JVS(427) = Jac_FULL(69,34) + JVS(427) = B(469)+B(473) +! JVS(428) = Jac_FULL(69,36) + JVS(428) = B(518) +! JVS(429) = Jac_FULL(69,37) + JVS(429) = B(516) +! JVS(430) = Jac_FULL(69,40) + JVS(430) = 0.5*B(524) +! JVS(431) = Jac_FULL(69,42) + JVS(431) = 0.3*B(523) +! JVS(432) = Jac_FULL(69,44) + JVS(432) = 2.23*B(261)+0.6*B(263) +! JVS(433) = Jac_FULL(69,45) + JVS(433) = 0.627*B(520) +! JVS(434) = Jac_FULL(69,46) + JVS(434) = 0.9*B(293) +! JVS(435) = Jac_FULL(69,48) + JVS(435) = 0.535*B(259) +! JVS(436) = Jac_FULL(69,50) + JVS(436) = B(499) +! JVS(437) = Jac_FULL(69,51) + JVS(437) = 0.3*B(121)+1.25*B(225)+B(390) +! JVS(438) = Jac_FULL(69,52) + JVS(438) = 0.75*B(165) +! JVS(439) = Jac_FULL(69,53) + JVS(439) = 0.75*B(229) +! JVS(440) = Jac_FULL(69,54) + JVS(440) = 0.39*B(95)+0.95*B(207)+0.39*B(388) +! JVS(441) = Jac_FULL(69,55) + JVS(441) = B(123)+1.25*B(227)+B(392) +! JVS(442) = Jac_FULL(69,57) + JVS(442) = 0.75*B(105)+1.13*B(215)+0.75*B(376) +! JVS(443) = Jac_FULL(69,58) + JVS(443) = 0.12*B(361) +! JVS(444) = Jac_FULL(69,59) + JVS(444) = B(117)+0.85*B(223)+0.17*B(384) +! JVS(445) = Jac_FULL(69,60) + JVS(445) = 0.75*B(211) +! JVS(446) = Jac_FULL(69,61) + JVS(446) = B(509) +! JVS(447) = Jac_FULL(69,62) + JVS(447) = 0.96*B(97)+0.5*B(209)+0.2*B(370) +! JVS(448) = Jac_FULL(69,63) + JVS(448) = B(129)+1.25*B(233)+B(396) +! JVS(449) = Jac_FULL(69,64) + JVS(449) = 0.28*B(113)+0.89*B(221)+0.28*B(382) +! JVS(450) = Jac_FULL(69,65) + JVS(450) = 0.75*B(219) +! JVS(451) = Jac_FULL(69,66) + JVS(451) = 0.35*B(109)+0.95*B(217)+0.4*B(378) +! JVS(452) = Jac_FULL(69,67) + JVS(452) = 0.15*B(127)+0.83*B(231)+0.15*B(394) +! JVS(453) = Jac_FULL(69,69) + JVS(453) = -B(36)-B(66)-B(459)-B(481)-B(482) +! JVS(454) = Jac_FULL(69,70) + JVS(454) = B(87)+1.25*B(167)+B(287) +! JVS(455) = Jac_FULL(69,71) + JVS(455) = 0.05*B(68) +! JVS(456) = Jac_FULL(69,72) + JVS(456) = 0.75*B(205) +! JVS(457) = Jac_FULL(69,73) + JVS(457) = 0 +! JVS(458) = Jac_FULL(69,74) + JVS(458) = 0.75*B(201) +! JVS(459) = Jac_FULL(69,76) + JVS(459) = 0 +! JVS(460) = Jac_FULL(69,77) + JVS(460) = 0.8*B(295)+B(505) +! JVS(461) = Jac_FULL(69,78) + JVS(461) = B(155)+2*B(309)+B(317)+B(436) +! JVS(462) = Jac_FULL(69,79) + JVS(462) = 0.56*B(101)+1.1*B(213)+0.69*B(374) +! JVS(463) = Jac_FULL(69,80) + JVS(463) = 0.7*B(297)+B(508) +! JVS(464) = Jac_FULL(69,81) + JVS(464) = B(305)+B(313) +! JVS(465) = Jac_FULL(69,82) + JVS(465) = 0 +! JVS(466) = Jac_FULL(69,83) + JVS(466) = B(35)-B(37)+B(62)+0.05*B(69)+2.23*B(262)+0.5*B(354)+B(357)+B(470) +! JVS(467) = Jac_FULL(69,84) + JVS(467) = 0.29*B(251) +! JVS(468) = Jac_FULL(69,85) + JVS(468) = B(26)+B(88)+0.39*B(96)+0.96*B(98)+0.56*B(102)+0.75*B(106)+0.35*B(110)+0.28*B(114)+B(118)+0.3*B(122)+B(124)& + &+0.15*B(128)+B(130)+B(153)+B(156) +! JVS(469) = Jac_FULL(69,86) + JVS(469) = B(288)+B(364)+B(366)+0.2*B(371)+0.69*B(375)+0.75*B(377)+0.4*B(379)+0.28*B(383)+0.17*B(385)+0.39*B(389)& + &+B(391)+B(393)+0.15*B(395)+B(397)+B(434)+B(437) +! JVS(470) = Jac_FULL(69,87) + JVS(470) = -B(67)+B(474) +! JVS(471) = Jac_FULL(69,88) + JVS(471) = B(154)+0.29*B(252)+2*B(307)+B(315)+B(435) +! JVS(472) = Jac_FULL(69,89) + JVS(472) = B(9)+0.535*B(260)+0.6*B(264)+0.9*B(294)+0.8*B(296)+0.7*B(298)+0.12*B(362) +! JVS(473) = Jac_FULL(69,90) + JVS(473) = B(10)+B(27)+B(30)+2*B(31)+0.75*B(166)+1.25*B(168)+0.75*B(202)+0.75*B(206)+0.95*B(208)+0.5*B(210)+0.75& + &*B(212)+1.1*B(214)+1.13*B(216)+0.95*B(218)+0.75*B(220)+0.89*B(222)+0.85*B(224)+1.25*B(226)+1.25*B(228)+0.75& + &*B(230)+0.83*B(232)+1.25*B(234)+B(306)+2*B(308)+2*B(310)+B(311)+B(314)+B(316)+B(318)+B(319)+B(365)+B(367) +! JVS(474) = Jac_FULL(70,37) + JVS(474) = B(335) +! JVS(475) = Jac_FULL(70,48) + JVS(475) = B(257) +! JVS(476) = Jac_FULL(70,70) + JVS(476) = -B(87)-B(167)-B(245)-B(287)-B(291) +! JVS(477) = Jac_FULL(70,77) + JVS(477) = 0 +! JVS(478) = Jac_FULL(70,83) + JVS(478) = B(258)+B(336) +! JVS(479) = Jac_FULL(70,84) + JVS(479) = -B(246) +! JVS(480) = Jac_FULL(70,85) + JVS(480) = -B(88) +! JVS(481) = Jac_FULL(70,86) + JVS(481) = -B(288)-B(292) +! JVS(482) = Jac_FULL(70,87) + JVS(482) = 0 +! JVS(483) = Jac_FULL(70,89) + JVS(483) = 0 +! JVS(484) = Jac_FULL(70,90) + JVS(484) = -B(168) +! JVS(485) = Jac_FULL(71,33) + JVS(485) = 0.5*B(333)+B(517) +! JVS(486) = Jac_FULL(71,35) + JVS(486) = 0.5*B(325)+B(512) +! JVS(487) = Jac_FULL(71,37) + JVS(487) = B(516) +! JVS(488) = Jac_FULL(71,48) + JVS(488) = 0.5*B(259) +! JVS(489) = Jac_FULL(71,54) + JVS(489) = 0.75*B(95)+0.38*B(207)+0.75*B(388) +! JVS(490) = Jac_FULL(71,60) + JVS(490) = 0.93*B(99)+0.5*B(211)+B(372) +! JVS(491) = Jac_FULL(71,63) + JVS(491) = B(129)+0.5*B(233)+B(396) +! JVS(492) = Jac_FULL(71,70) + JVS(492) = B(87)+0.5*B(167)+B(287) +! JVS(493) = Jac_FULL(71,71) + JVS(493) = -B(68)-B(70)-B(491)-B(492) +! JVS(494) = Jac_FULL(71,72) + JVS(494) = 0.32*B(91)+0.16*B(205)+0.32*B(368) +! JVS(495) = Jac_FULL(71,73) + JVS(495) = 0.32*B(526) +! JVS(496) = Jac_FULL(71,74) + JVS(496) = B(79)+0.75*B(201)+2*B(239)+B(240)+B(428)+B(430) +! JVS(497) = Jac_FULL(71,75) + JVS(497) = B(503) +! JVS(498) = Jac_FULL(71,76) + JVS(498) = 0 +! JVS(499) = Jac_FULL(71,77) + JVS(499) = 0.04*B(295) +! JVS(500) = Jac_FULL(71,81) + JVS(500) = 0 +! JVS(501) = Jac_FULL(71,83) + JVS(501) = -B(69)+B(235)+0.5*B(326)+0.5*B(334) +! JVS(502) = Jac_FULL(71,84) + JVS(502) = 0 +! JVS(503) = Jac_FULL(71,85) + JVS(503) = B(80)+B(88)+0.32*B(92)+0.75*B(96)+0.93*B(100)+B(130) +! JVS(504) = Jac_FULL(71,86) + JVS(504) = B(288)+0.32*B(369)+B(373)+0.75*B(389)+B(397)+B(429)+B(431) +! JVS(505) = Jac_FULL(71,87) + JVS(505) = -B(71) +! JVS(506) = Jac_FULL(71,89) + JVS(506) = 0.5*B(260)+0.04*B(296) +! JVS(507) = Jac_FULL(71,90) + JVS(507) = 0.5*B(168)+0.75*B(202)+0.16*B(206)+0.38*B(208)+0.5*B(212)+0.5*B(234) +! JVS(508) = Jac_FULL(72,22) + JVS(508) = B(89)+B(131) +! JVS(509) = Jac_FULL(72,30) + JVS(509) = 0.5*B(331) +! JVS(510) = Jac_FULL(72,54) + JVS(510) = 0.3*B(95)+0.15*B(207)+0.3*B(388) +! JVS(511) = Jac_FULL(72,72) + JVS(511) = -B(91)-B(93)-B(169)-B(205)-B(368)-B(398) +! JVS(512) = Jac_FULL(72,73) + JVS(512) = 0 +! JVS(513) = Jac_FULL(72,83) + JVS(513) = B(90)+0.5*B(332) +! JVS(514) = Jac_FULL(72,84) + JVS(514) = -B(170) +! JVS(515) = Jac_FULL(72,85) + JVS(515) = -B(92)-B(94)+0.3*B(96) +! JVS(516) = Jac_FULL(72,86) + JVS(516) = -B(369)+0.3*B(389)-B(399) +! JVS(517) = Jac_FULL(72,87) + JVS(517) = B(132) +! JVS(518) = Jac_FULL(72,90) + JVS(518) = -B(206)+0.15*B(208) +! JVS(519) = Jac_FULL(73,54) + JVS(519) = B(171) +! JVS(520) = Jac_FULL(73,60) + JVS(520) = 0.07*B(99) +! JVS(521) = Jac_FULL(73,62) + JVS(521) = 0.04*B(97) +! JVS(522) = Jac_FULL(73,72) + JVS(522) = B(93) +! JVS(523) = Jac_FULL(73,73) + JVS(523) = -B(133)-B(464)-B(526) +! JVS(524) = Jac_FULL(73,76) + JVS(524) = 0 +! JVS(525) = Jac_FULL(73,83) + JVS(525) = -B(134) +! JVS(526) = Jac_FULL(73,84) + JVS(526) = B(172) +! JVS(527) = Jac_FULL(73,85) + JVS(527) = B(94)+0.04*B(98)+0.07*B(100) +! JVS(528) = Jac_FULL(73,86) + JVS(528) = 0 +! JVS(529) = Jac_FULL(73,87) + JVS(529) = 0 +! JVS(530) = Jac_FULL(73,90) + JVS(530) = 0 +! JVS(531) = Jac_FULL(74,23) + JVS(531) = B(77)+B(355) +! JVS(532) = Jac_FULL(74,35) + JVS(532) = 0.5*B(325) +! JVS(533) = Jac_FULL(74,68) + JVS(533) = B(494) +! JVS(534) = Jac_FULL(74,70) + JVS(534) = 0 +! JVS(535) = Jac_FULL(74,72) + JVS(535) = 0.32*B(91)+0.16*B(205)+0.32*B(368) +! JVS(536) = Jac_FULL(74,73) + JVS(536) = 0.32*B(526) +! JVS(537) = Jac_FULL(74,74) + JVS(537) = -B(79)-B(201)-2*B(239)-2*B(240)-B(241)-B(428)-B(430) +! JVS(538) = Jac_FULL(74,76) + JVS(538) = 0.85*B(497) +! JVS(539) = Jac_FULL(74,77) + JVS(539) = 0 +! JVS(540) = Jac_FULL(74,80) + JVS(540) = 0 +! JVS(541) = Jac_FULL(74,81) + JVS(541) = B(151)+B(305)+B(432) +! JVS(542) = Jac_FULL(74,83) + JVS(542) = B(78)+0.5*B(326) +! JVS(543) = Jac_FULL(74,84) + JVS(543) = -B(242) +! JVS(544) = Jac_FULL(74,85) + JVS(544) = -B(80)+0.32*B(92)+B(152) +! JVS(545) = Jac_FULL(74,86) + JVS(545) = 0.32*B(369)-B(429)-B(431)+B(433) +! JVS(546) = Jac_FULL(74,87) + JVS(546) = B(356) +! JVS(547) = Jac_FULL(74,89) + JVS(547) = 0 +! JVS(548) = Jac_FULL(74,90) + JVS(548) = -B(202)+0.16*B(206)+B(306) +! JVS(549) = Jac_FULL(75,41) + JVS(549) = 0.58*B(521) +! JVS(550) = Jac_FULL(75,42) + JVS(550) = 0.3*B(523) +! JVS(551) = Jac_FULL(75,51) + JVS(551) = 0.3*B(121)+0.25*B(225)+0.5*B(390) +! JVS(552) = Jac_FULL(75,55) + JVS(552) = B(123)+0.5*B(227)+B(392) +! JVS(553) = Jac_FULL(75,58) + JVS(553) = 0.6*B(361) +! JVS(554) = Jac_FULL(75,59) + JVS(554) = 0.17*B(384) +! JVS(555) = Jac_FULL(75,60) + JVS(555) = B(175) +! JVS(556) = Jac_FULL(75,61) + JVS(556) = B(283) +! JVS(557) = Jac_FULL(75,62) + JVS(557) = 0.5*B(209)+0.8*B(370) +! JVS(558) = Jac_FULL(75,64) + JVS(558) = 0.28*B(113)+0.14*B(221)+0.28*B(382) +! JVS(559) = Jac_FULL(75,65) + JVS(559) = 0 +! JVS(560) = Jac_FULL(75,66) + JVS(560) = 0.53*B(109)+0.29*B(217)+0.58*B(378) +! JVS(561) = Jac_FULL(75,70) + JVS(561) = 0 +! JVS(562) = Jac_FULL(75,72) + JVS(562) = 0 +! JVS(563) = Jac_FULL(75,73) + JVS(563) = 0 +! JVS(564) = Jac_FULL(75,75) + JVS(564) = -B(271)-B(275)-B(502)-B(503) +! JVS(565) = Jac_FULL(75,76) + JVS(565) = 0 +! JVS(566) = Jac_FULL(75,77) + JVS(566) = 0.82*B(295) +! JVS(567) = Jac_FULL(75,78) + JVS(567) = 0 +! JVS(568) = Jac_FULL(75,79) + JVS(568) = 0 +! JVS(569) = Jac_FULL(75,80) + JVS(569) = 0.8*B(297) +! JVS(570) = Jac_FULL(75,82) + JVS(570) = 0 +! JVS(571) = Jac_FULL(75,83) + JVS(571) = -B(272)+B(284) +! JVS(572) = Jac_FULL(75,84) + JVS(572) = B(176) +! JVS(573) = Jac_FULL(75,85) + JVS(573) = 0.53*B(110)+0.28*B(114)+0.3*B(122)+B(124) +! JVS(574) = Jac_FULL(75,86) + JVS(574) = 0.8*B(371)+0.58*B(379)+0.28*B(383)+0.17*B(385)+0.5*B(391)+B(393) +! JVS(575) = Jac_FULL(75,87) + JVS(575) = -B(276) +! JVS(576) = Jac_FULL(75,89) + JVS(576) = 0.82*B(296)+0.8*B(298)+0.6*B(362) +! JVS(577) = Jac_FULL(75,90) + JVS(577) = 0.5*B(210)+0.29*B(218)+0.14*B(222)+0.25*B(226)+0.5*B(228) +! JVS(578) = Jac_FULL(76,57) + JVS(578) = 0.25*B(215)+B(406) +! JVS(579) = Jac_FULL(76,59) + JVS(579) = B(412) +! JVS(580) = Jac_FULL(76,60) + JVS(580) = 0.25*B(211)+B(402) +! JVS(581) = Jac_FULL(76,62) + JVS(581) = B(400) +! JVS(582) = Jac_FULL(76,64) + JVS(582) = 0.25*B(221)+B(410) +! JVS(583) = Jac_FULL(76,66) + JVS(583) = 0.25*B(217)+B(408) +! JVS(584) = Jac_FULL(76,72) + JVS(584) = 0.19*B(91)+0.35*B(205)+0.19*B(368)+B(398) +! JVS(585) = Jac_FULL(76,73) + JVS(585) = 0.19*B(526) +! JVS(586) = Jac_FULL(76,76) + JVS(586) = -B(199)-B(203)-B(497) +! JVS(587) = Jac_FULL(76,77) + JVS(587) = 0 +! JVS(588) = Jac_FULL(76,79) + JVS(588) = 0.25*B(213)+B(404) +! JVS(589) = Jac_FULL(76,80) + JVS(589) = 0 +! JVS(590) = Jac_FULL(76,83) + JVS(590) = -B(200) +! JVS(591) = Jac_FULL(76,84) + JVS(591) = 0 +! JVS(592) = Jac_FULL(76,85) + JVS(592) = 0.19*B(92) +! JVS(593) = Jac_FULL(76,86) + JVS(593) = 0.19*B(369)+B(399)+B(401)+B(403)+B(405)+B(407)+B(409)+B(411)+B(413) +! JVS(594) = Jac_FULL(76,87) + JVS(594) = -B(204) +! JVS(595) = Jac_FULL(76,89) + JVS(595) = 0 +! JVS(596) = Jac_FULL(76,90) + JVS(596) = 0.35*B(206)+0.25*B(212)+0.25*B(214)+0.25*B(216)+0.25*B(218)+0.25*B(222) +! JVS(597) = Jac_FULL(77,45) + JVS(597) = 0.368*B(520) +! JVS(598) = Jac_FULL(77,46) + JVS(598) = 0.159*B(293) +! JVS(599) = Jac_FULL(77,57) + JVS(599) = 0 +! JVS(600) = Jac_FULL(77,67) + JVS(600) = 0.05*B(127)+0.03*B(231)+0.05*B(394) +! JVS(601) = Jac_FULL(77,77) + JVS(601) = -B(279)-B(295)-B(504)-B(505)-B(506) +! JVS(602) = Jac_FULL(77,79) + JVS(602) = 0.34*B(101)+0.2*B(213)+0.402*B(374) +! JVS(603) = Jac_FULL(77,83) + JVS(603) = -B(280) +! JVS(604) = Jac_FULL(77,84) + JVS(604) = 0 +! JVS(605) = Jac_FULL(77,85) + JVS(605) = 0.34*B(102)+0.05*B(128) +! JVS(606) = Jac_FULL(77,86) + JVS(606) = 0.402*B(375)+0.05*B(395) +! JVS(607) = Jac_FULL(77,87) + JVS(607) = 0 +! JVS(608) = Jac_FULL(77,89) + JVS(608) = 0.159*B(294)-B(296) +! JVS(609) = Jac_FULL(77,90) + JVS(609) = 0.2*B(214)+0.03*B(232) +! JVS(610) = Jac_FULL(78,26) + JVS(610) = B(351) +! JVS(611) = Jac_FULL(78,44) + JVS(611) = B(147) +! JVS(612) = Jac_FULL(78,58) + JVS(612) = 0.41*B(359) +! JVS(613) = Jac_FULL(78,77) + JVS(613) = B(506) +! JVS(614) = Jac_FULL(78,78) + JVS(614) = -B(145)-B(155)-B(253)-B(309)-B(317)-B(436) +! JVS(615) = Jac_FULL(78,79) + JVS(615) = 0 +! JVS(616) = Jac_FULL(78,80) + JVS(616) = 0.57*B(281)+B(303)+B(507) +! JVS(617) = Jac_FULL(78,82) + JVS(617) = -B(146) +! JVS(618) = Jac_FULL(78,83) + JVS(618) = 0.57*B(282)+B(352)+0.41*B(360) +! JVS(619) = Jac_FULL(78,84) + JVS(619) = -B(254) +! JVS(620) = Jac_FULL(78,85) + JVS(620) = -B(156) +! JVS(621) = Jac_FULL(78,86) + JVS(621) = -B(437) +! JVS(622) = Jac_FULL(78,87) + JVS(622) = B(304) +! JVS(623) = Jac_FULL(78,89) + JVS(623) = 0 +! JVS(624) = Jac_FULL(78,90) + JVS(624) = -B(310)-B(318) +! JVS(625) = Jac_FULL(79,45) + JVS(625) = 0.491*B(341) +! JVS(626) = Jac_FULL(79,46) + JVS(626) = B(277) +! JVS(627) = Jac_FULL(79,57) + JVS(627) = 0 +! JVS(628) = Jac_FULL(79,79) + JVS(628) = -B(101)-B(103)-B(177)-B(213)-B(374)-B(404) +! JVS(629) = Jac_FULL(79,83) + JVS(629) = B(278)+0.491*B(342) +! JVS(630) = Jac_FULL(79,84) + JVS(630) = -B(178) +! JVS(631) = Jac_FULL(79,85) + JVS(631) = -B(102)-B(104) +! JVS(632) = Jac_FULL(79,86) + JVS(632) = -B(375)-B(405) +! JVS(633) = Jac_FULL(79,87) + JVS(633) = 0 +! JVS(634) = Jac_FULL(79,89) + JVS(634) = 0 +! JVS(635) = Jac_FULL(79,90) + JVS(635) = -B(214) +! JVS(636) = Jac_FULL(80,45) + JVS(636) = 0.259*B(520) +! JVS(637) = Jac_FULL(80,46) + JVS(637) = 0.387*B(293) +! JVS(638) = Jac_FULL(80,57) + JVS(638) = 0 +! JVS(639) = Jac_FULL(80,67) + JVS(639) = 0.1*B(127)+0.05*B(231)+0.1*B(394) +! JVS(640) = Jac_FULL(80,79) + JVS(640) = 0.22*B(101)+0.14*B(213)+0.288*B(374) +! JVS(641) = Jac_FULL(80,80) + JVS(641) = -B(281)-B(297)-B(301)-B(303)-B(507)-B(508) +! JVS(642) = Jac_FULL(80,83) + JVS(642) = -B(282) +! JVS(643) = Jac_FULL(80,84) + JVS(643) = 0 +! JVS(644) = Jac_FULL(80,85) + JVS(644) = 0.22*B(102)+0.1*B(128) +! JVS(645) = Jac_FULL(80,86) + JVS(645) = 0.288*B(375)+0.1*B(395) +! JVS(646) = Jac_FULL(80,87) + JVS(646) = -B(302)-B(304) +! JVS(647) = Jac_FULL(80,89) + JVS(647) = 0.387*B(294)-B(298) +! JVS(648) = Jac_FULL(80,90) + JVS(648) = 0.14*B(214)+0.05*B(232) +! JVS(649) = Jac_FULL(81,18) + JVS(649) = B(141) +! JVS(650) = Jac_FULL(81,33) + JVS(650) = 0.5*B(333) +! JVS(651) = Jac_FULL(81,68) + JVS(651) = B(137)+B(159) +! JVS(652) = Jac_FULL(81,70) + JVS(652) = 0 +! JVS(653) = Jac_FULL(81,72) + JVS(653) = 0 +! JVS(654) = Jac_FULL(81,73) + JVS(654) = 0 +! JVS(655) = Jac_FULL(81,76) + JVS(655) = 0.15*B(497) +! JVS(656) = Jac_FULL(81,77) + JVS(656) = 0 +! JVS(657) = Jac_FULL(81,79) + JVS(657) = 0 +! JVS(658) = Jac_FULL(81,80) + JVS(658) = 0 +! JVS(659) = Jac_FULL(81,81) + JVS(659) = -B(139)-B(151)-B(249)-B(305)-B(313)-B(432) +! JVS(660) = Jac_FULL(81,82) + JVS(660) = -B(140) +! JVS(661) = Jac_FULL(81,83) + JVS(661) = B(138)+0.5*B(334) +! JVS(662) = Jac_FULL(81,84) + JVS(662) = -B(250) +! JVS(663) = Jac_FULL(81,85) + JVS(663) = -B(152) +! JVS(664) = Jac_FULL(81,86) + JVS(664) = -B(433) +! JVS(665) = Jac_FULL(81,87) + JVS(665) = B(160) +! JVS(666) = Jac_FULL(81,89) + JVS(666) = 0 +! JVS(667) = Jac_FULL(81,90) + JVS(667) = -B(306)-B(314) +! JVS(668) = Jac_FULL(82,18) + JVS(668) = B(141) +! JVS(669) = Jac_FULL(82,19) + JVS(669) = B(144) +! JVS(670) = Jac_FULL(82,21) + JVS(670) = B(74)+0.6*B(493) +! JVS(671) = Jac_FULL(82,24) + JVS(671) = B(44) +! JVS(672) = Jac_FULL(82,25) + JVS(672) = B(59)+B(488) +! JVS(673) = Jac_FULL(82,29) + JVS(673) = B(48)+B(49)+B(490) +! JVS(674) = Jac_FULL(82,38) + JVS(674) = B(511) +! JVS(675) = Jac_FULL(82,39) + JVS(675) = B(510) +! JVS(676) = Jac_FULL(82,43) + JVS(676) = 0.5*B(345)+B(522) +! JVS(677) = Jac_FULL(82,44) + JVS(677) = B(147)+B(261)+B(263) +! JVS(678) = Jac_FULL(82,51) + JVS(678) = 1.9*B(121)+B(225)+B(390)+B(418) +! JVS(679) = Jac_FULL(82,52) + JVS(679) = B(85) +! JVS(680) = Jac_FULL(82,53) + JVS(680) = B(125) +! JVS(681) = Jac_FULL(82,54) + JVS(681) = 2*B(95)+B(207)+B(388)+B(414) +! JVS(682) = Jac_FULL(82,55) + JVS(682) = 2*B(123)+B(227)+B(392)+B(420) +! JVS(683) = Jac_FULL(82,56) + JVS(683) = B(483) +! JVS(684) = Jac_FULL(82,57) + JVS(684) = B(105) +! JVS(685) = Jac_FULL(82,59) + JVS(685) = B(117) +! JVS(686) = Jac_FULL(82,60) + JVS(686) = 0.93*B(99) +! JVS(687) = Jac_FULL(82,62) + JVS(687) = 0.96*B(97) +! JVS(688) = Jac_FULL(82,63) + JVS(688) = 2*B(129)+B(233)+B(396)+B(424) +! JVS(689) = Jac_FULL(82,64) + JVS(689) = B(113) +! JVS(690) = Jac_FULL(82,65) + JVS(690) = 1.95*B(111)+B(219)+B(380)+B(416) +! JVS(691) = Jac_FULL(82,66) + JVS(691) = 0.92*B(109) +! JVS(692) = Jac_FULL(82,67) + JVS(692) = 1.15*B(127)+0.575*B(231)+0.15*B(394)+B(422) +! JVS(693) = Jac_FULL(82,68) + JVS(693) = 0 +! JVS(694) = Jac_FULL(82,69) + JVS(694) = 0 +! JVS(695) = Jac_FULL(82,70) + JVS(695) = B(87) +! JVS(696) = Jac_FULL(82,71) + JVS(696) = 0 +! JVS(697) = Jac_FULL(82,72) + JVS(697) = B(91) +! JVS(698) = Jac_FULL(82,73) + JVS(698) = B(526) +! JVS(699) = Jac_FULL(82,74) + JVS(699) = B(79) +! JVS(700) = Jac_FULL(82,75) + JVS(700) = 0 +! JVS(701) = Jac_FULL(82,76) + JVS(701) = 0 +! JVS(702) = Jac_FULL(82,77) + JVS(702) = 0 +! JVS(703) = Jac_FULL(82,78) + JVS(703) = -B(145)+B(155) +! JVS(704) = Jac_FULL(82,79) + JVS(704) = 0.9*B(101) +! JVS(705) = Jac_FULL(82,80) + JVS(705) = 0 +! JVS(706) = Jac_FULL(82,81) + JVS(706) = -B(139)+B(151) +! JVS(707) = Jac_FULL(82,82) + JVS(707) = -B(7)-B(38)-B(46)-B(57)-B(72)-B(140)-B(142)-B(146)-B(148)-B(455)-B(466)-B(478) +! JVS(708) = Jac_FULL(82,83) + JVS(708) = -B(39)+B(45)+B(50)+B(55)+B(262)+0.5*B(346)+B(357) +! JVS(709) = Jac_FULL(82,84) + JVS(709) = B(17)-B(47)+B(51) +! JVS(710) = Jac_FULL(82,85) + JVS(710) = B(1)+B(18)+B(26)+2*B(53)+B(75)+B(80)+B(86)+B(88)+B(92)+2*B(96)+0.96*B(98)+0.93*B(100)+0.9*B(102)+B(106)& + &+0.92*B(110)+1.95*B(112)+B(114)+B(118)+1.9*B(122)+2*B(124)+B(126)+1.15*B(128)+2*B(130)+B(152)+B(153)+B(156)& + &+B(157) +! JVS(711) = Jac_FULL(82,86) + JVS(711) = -B(73)+B(76)+B(381)+B(389)+B(391)+B(393)+0.15*B(395)+B(397)+B(415)+B(417)+B(419)+B(421)+B(423)+B(425) +! JVS(712) = Jac_FULL(82,87) + JVS(712) = B(52)+2*B(54)+B(56)-B(58)+2*B(440)+B(486) +! JVS(713) = Jac_FULL(82,88) + JVS(713) = -B(143)+B(154) +! JVS(714) = Jac_FULL(82,89) + JVS(714) = B(2)-B(8)+B(264) +! JVS(715) = Jac_FULL(82,90) + JVS(715) = B(27)+B(208)+B(220)+B(226)+B(228)+0.575*B(232)+B(234) +! JVS(716) = Jac_FULL(83,16) + JVS(716) = -B(81)-B(83) +! JVS(717) = Jac_FULL(83,17) + JVS(717) = -B(15)+2*B(479) +! JVS(718) = Jac_FULL(83,20) + JVS(718) = -B(475) +! JVS(719) = Jac_FULL(83,22) + JVS(719) = -B(89) +! JVS(720) = Jac_FULL(83,23) + JVS(720) = -B(77) +! JVS(721) = Jac_FULL(83,24) + JVS(721) = -B(44)+B(484) +! JVS(722) = Jac_FULL(83,26) + JVS(722) = -B(351)+B(525) +! JVS(723) = Jac_FULL(83,27) + JVS(723) = -0.5*B(353)+B(527) +! JVS(724) = Jac_FULL(83,28) + JVS(724) = -B(32)+B(480) +! JVS(725) = Jac_FULL(83,29) + JVS(725) = -B(49)+B(485) +! JVS(726) = Jac_FULL(83,30) + JVS(726) = -0.5*B(331)+B(515) +! JVS(727) = Jac_FULL(83,31) + JVS(727) = -0.5*B(327)+B(513) +! JVS(728) = Jac_FULL(83,32) + JVS(728) = -0.5*B(329)+B(514) +! JVS(729) = Jac_FULL(83,33) + JVS(729) = -0.5*B(333)+B(517) +! JVS(730) = Jac_FULL(83,34) + JVS(730) = -B(469)-B(471) +! JVS(731) = Jac_FULL(83,35) + JVS(731) = -0.5*B(325)+B(512) +! JVS(732) = Jac_FULL(83,36) + JVS(732) = -B(337)+B(518) +! JVS(733) = Jac_FULL(83,37) + JVS(733) = -B(335)+B(516) +! JVS(734) = Jac_FULL(83,38) + JVS(734) = -B(323)+B(511) +! JVS(735) = Jac_FULL(83,39) + JVS(735) = -B(321)+B(510) +! JVS(736) = Jac_FULL(83,40) + JVS(736) = -B(349)+B(524) +! JVS(737) = Jac_FULL(83,41) + JVS(737) = -B(343)+B(521) +! JVS(738) = Jac_FULL(83,42) + JVS(738) = -0.5*B(347)+B(523) +! JVS(739) = Jac_FULL(83,43) + JVS(739) = -0.5*B(345)+B(522) +! JVS(740) = Jac_FULL(83,44) + JVS(740) = -B(261) +! JVS(741) = Jac_FULL(83,45) + JVS(741) = -0.491*B(341)+B(520) +! JVS(742) = Jac_FULL(83,46) + JVS(742) = -B(277)+0.27*B(293) +! JVS(743) = Jac_FULL(83,47) + JVS(743) = -B(22) +! JVS(744) = Jac_FULL(83,48) + JVS(744) = -B(257)+0.135*B(259) +! JVS(745) = Jac_FULL(83,49) + JVS(745) = -B(161)-B(163) +! JVS(746) = Jac_FULL(83,50) + JVS(746) = -B(265) +! JVS(747) = Jac_FULL(83,51) + JVS(747) = 0 +! JVS(748) = Jac_FULL(83,52) + JVS(748) = 0 +! JVS(749) = Jac_FULL(83,53) + JVS(749) = 0 +! JVS(750) = Jac_FULL(83,55) + JVS(750) = 0 +! JVS(751) = Jac_FULL(83,56) + JVS(751) = -B(40)+B(483) +! JVS(752) = Jac_FULL(83,57) + JVS(752) = 0 +! JVS(753) = Jac_FULL(83,58) + JVS(753) = -B(359)+0.1*B(361) +! JVS(754) = Jac_FULL(83,59) + JVS(754) = 0 +! JVS(755) = Jac_FULL(83,61) + JVS(755) = -B(283) +! JVS(756) = Jac_FULL(83,62) + JVS(756) = 0 +! JVS(757) = Jac_FULL(83,63) + JVS(757) = 0 +! JVS(758) = Jac_FULL(83,64) + JVS(758) = 0 +! JVS(759) = Jac_FULL(83,65) + JVS(759) = 0 +! JVS(760) = Jac_FULL(83,66) + JVS(760) = 0 +! JVS(761) = Jac_FULL(83,67) + JVS(761) = 0 +! JVS(762) = Jac_FULL(83,68) + JVS(762) = -B(137) +! JVS(763) = Jac_FULL(83,69) + JVS(763) = -B(36) +! JVS(764) = Jac_FULL(83,70) + JVS(764) = 0 +! JVS(765) = Jac_FULL(83,71) + JVS(765) = -B(68) +! JVS(766) = Jac_FULL(83,72) + JVS(766) = 0 +! JVS(767) = Jac_FULL(83,73) + JVS(767) = -B(133) +! JVS(768) = Jac_FULL(83,74) + JVS(768) = 0 +! JVS(769) = Jac_FULL(83,75) + JVS(769) = -B(271) +! JVS(770) = Jac_FULL(83,76) + JVS(770) = -B(199) +! JVS(771) = Jac_FULL(83,77) + JVS(771) = -B(279)+0.08*B(295) +! JVS(772) = Jac_FULL(83,78) + JVS(772) = 0 +! JVS(773) = Jac_FULL(83,79) + JVS(773) = 0 +! JVS(774) = Jac_FULL(83,80) + JVS(774) = -B(281)+0.215*B(297) +! JVS(775) = Jac_FULL(83,81) + JVS(775) = 0 +! JVS(776) = Jac_FULL(83,82) + JVS(776) = -B(38) +! JVS(777) = Jac_FULL(83,83) + JVS(777) = -B(3)-2*B(11)-2*B(12)-B(13)-B(16)-B(20)-B(23)-B(24)-B(33)-B(37)-B(39)-B(41)-B(42)-B(45)-B(50)-B(55)-B(60)& + &-B(62)-B(69)-B(78)-B(82)-B(84)-B(90)-B(134)-B(135)-B(138)-B(162)-B(164)-B(200)-B(235)-B(237)-B(258)-B(262)& + &-B(266)-B(269)-B(272)-B(278)-B(280)-B(282)-B(284)-B(322)-B(324)-0.5*B(326)-0.5*B(328)-0.5*B(330)-0.5*B(332)& + &-0.5*B(334)-B(336)-B(338)-0.5*B(339)-0.491*B(342)-B(344)-0.5*B(346)-0.5*B(348)-B(350)-B(352)-0.5*B(354)& + &-B(357)-B(360)-B(470)-B(472)-B(476) +! JVS(778) = Jac_FULL(83,84) + JVS(778) = B(5)-B(14)+B(17)+B(51)+0.44*B(247) +! JVS(779) = Jac_FULL(83,85) + JVS(779) = B(18)-B(43) +! JVS(780) = Jac_FULL(83,86) + JVS(780) = 0.44*B(248) +! JVS(781) = Jac_FULL(83,87) + JVS(781) = B(52)-B(56) +! JVS(782) = Jac_FULL(83,88) + JVS(782) = 0 +! JVS(783) = Jac_FULL(83,89) + JVS(783) = -B(4)+B(6)+0.135*B(260)+0.27*B(294)+0.08*B(296)+0.215*B(298)+0.1*B(362)+2*B(477) +! JVS(784) = Jac_FULL(83,90) + JVS(784) = 0 +! JVS(785) = Jac_FULL(84,17) + JVS(785) = B(15) +! JVS(786) = Jac_FULL(84,20) + JVS(786) = B(475) +! JVS(787) = Jac_FULL(84,28) + JVS(787) = B(480) +! JVS(788) = Jac_FULL(84,29) + JVS(788) = B(48)+B(490) +! JVS(789) = Jac_FULL(84,30) + JVS(789) = B(515) +! JVS(790) = Jac_FULL(84,31) + JVS(790) = B(513) +! JVS(791) = Jac_FULL(84,32) + JVS(791) = B(514) +! JVS(792) = Jac_FULL(84,33) + JVS(792) = B(517) +! JVS(793) = Jac_FULL(84,34) + JVS(793) = 0 +! JVS(794) = Jac_FULL(84,35) + JVS(794) = B(512) +! JVS(795) = Jac_FULL(84,36) + JVS(795) = B(518) +! JVS(796) = Jac_FULL(84,37) + JVS(796) = B(516) +! JVS(797) = Jac_FULL(84,38) + JVS(797) = B(511) +! JVS(798) = Jac_FULL(84,39) + JVS(798) = B(510) +! JVS(799) = Jac_FULL(84,40) + JVS(799) = B(524) +! JVS(800) = Jac_FULL(84,41) + JVS(800) = B(521) +! JVS(801) = Jac_FULL(84,42) + JVS(801) = 0.3*B(523) +! JVS(802) = Jac_FULL(84,43) + JVS(802) = B(522) +! JVS(803) = Jac_FULL(84,44) + JVS(803) = 2*B(261)+B(263) +! JVS(804) = Jac_FULL(84,45) + JVS(804) = B(520) +! JVS(805) = Jac_FULL(84,46) + JVS(805) = 0.06*B(293) +! JVS(806) = Jac_FULL(84,47) + JVS(806) = B(22) +! JVS(807) = Jac_FULL(84,48) + JVS(807) = 0.3*B(259) +! JVS(808) = Jac_FULL(84,49) + JVS(808) = 0 +! JVS(809) = Jac_FULL(84,50) + JVS(809) = 0.2*B(265)+2*B(499) +! JVS(810) = Jac_FULL(84,51) + JVS(810) = 0.3*B(121)-B(189)+0.75*B(225)+0.5*B(390) +! JVS(811) = Jac_FULL(84,52) + JVS(811) = B(85)+B(165)-B(243)+B(285) +! JVS(812) = Jac_FULL(84,53) + JVS(812) = B(125)-B(193)+B(229)+B(386) +! JVS(813) = Jac_FULL(84,54) + JVS(813) = -B(171)+0.5*B(207) +! JVS(814) = Jac_FULL(84,55) + JVS(814) = -B(191)+0.5*B(227) +! JVS(815) = Jac_FULL(84,57) + JVS(815) = B(105)-B(179)+B(215)+B(376) +! JVS(816) = Jac_FULL(84,58) + JVS(816) = 0.15*B(359) +! JVS(817) = Jac_FULL(84,59) + JVS(817) = B(117)-B(187)+1.15*B(223)+B(384) +! JVS(818) = Jac_FULL(84,60) + JVS(818) = -B(175)+0.5*B(211) +! JVS(819) = Jac_FULL(84,61) + JVS(819) = B(283)+B(509) +! JVS(820) = Jac_FULL(84,62) + JVS(820) = -B(173)+0.3*B(209)+0.8*B(370) +! JVS(821) = Jac_FULL(84,63) + JVS(821) = -B(197)+0.5*B(233) +! JVS(822) = Jac_FULL(84,64) + JVS(822) = 0.28*B(113)-B(185)+0.64*B(221)+0.28*B(382) +! JVS(823) = Jac_FULL(84,65) + JVS(823) = 0.05*B(111)-B(183)+0.5*B(219) +! JVS(824) = Jac_FULL(84,66) + JVS(824) = 0.92*B(109)-B(181)+B(217)+B(378) +! JVS(825) = Jac_FULL(84,67) + JVS(825) = 0.8*B(127)-B(195)+0.45*B(231)+0.8*B(394) +! JVS(826) = Jac_FULL(84,68) + JVS(826) = B(494) +! JVS(827) = Jac_FULL(84,69) + JVS(827) = B(36)+B(66)+2*B(481) +! JVS(828) = Jac_FULL(84,70) + JVS(828) = B(87)+B(167)-B(245)+B(287) +! JVS(829) = Jac_FULL(84,71) + JVS(829) = 0.05*B(68)+B(491) +! JVS(830) = Jac_FULL(84,72) + JVS(830) = 0.27*B(91)-B(169)+0.64*B(205)+0.27*B(368) +! JVS(831) = Jac_FULL(84,73) + JVS(831) = 0.27*B(526) +! JVS(832) = Jac_FULL(84,74) + JVS(832) = B(79)+B(201)+2*B(239)-B(241)+B(428) +! JVS(833) = Jac_FULL(84,75) + JVS(833) = B(502) +! JVS(834) = Jac_FULL(84,76) + JVS(834) = 0 +! JVS(835) = Jac_FULL(84,77) + JVS(835) = 0.06*B(295)+B(505) +! JVS(836) = Jac_FULL(84,78) + JVS(836) = -B(253)+B(309) +! JVS(837) = Jac_FULL(84,79) + JVS(837) = 0.9*B(101)-B(177)+0.92*B(213)+0.864*B(374) +! JVS(838) = Jac_FULL(84,80) + JVS(838) = 0.275*B(297)+B(507)+B(508) +! JVS(839) = Jac_FULL(84,81) + JVS(839) = -B(249)+B(305) +! JVS(840) = Jac_FULL(84,82) + JVS(840) = -B(46) +! JVS(841) = Jac_FULL(84,83) + JVS(841) = B(3)-B(13)+B(16)+B(20)+B(23)+B(37)+B(55)+B(60)+B(62)+0.05*B(69)+B(235)+B(237)+2*B(262)+0.2*B(266)+B(269)& + &+B(284)+0.15*B(360)+B(476) +! JVS(842) = Jac_FULL(84,84) + JVS(842) = -B(5)-B(14)-B(17)-2*B(19)-B(28)-B(47)-B(51)-B(170)-B(172)-B(174)-B(176)-B(178)-B(180)-B(182)-B(184)-B(186)& + &-B(188)-B(190)-B(192)-B(194)-B(196)-B(198)-B(242)-B(244)-B(246)-B(247)-B(250)-B(251)-B(254)-B(255)-B(465) +! JVS(843) = Jac_FULL(84,85) + JVS(843) = -B(18)+B(26)+B(80)+B(86)+B(88)+0.27*B(92)+0.9*B(102)+B(106)+0.92*B(110)+0.05*B(112)+0.28*B(114)+B(118)+0.3& + &*B(122)+B(126)+0.8*B(128)+B(153)+B(157) +! JVS(844) = Jac_FULL(84,86) + JVS(844) = -B(248)+B(286)+B(288)+B(364)+0.27*B(369)+0.8*B(371)+0.864*B(375)+B(377)+B(379)+0.28*B(383)+B(385)+B(387)& + &+0.5*B(391)+0.8*B(395)+B(429)+B(434)+B(438) +! JVS(845) = Jac_FULL(84,87) + JVS(845) = -B(52)+B(56)+B(67)+B(273) +! JVS(846) = Jac_FULL(84,88) + JVS(846) = B(154)-B(252)+2*B(307)+B(435) +! JVS(847) = Jac_FULL(84,89) + JVS(847) = B(4)-B(6)+B(9)+0.3*B(260)+B(264)+0.06*B(294)+0.06*B(296)+0.275*B(298) +! JVS(848) = Jac_FULL(84,90) + JVS(848) = B(10)+B(27)-B(29)+2*B(31)+B(166)+B(168)+B(202)+0.64*B(206)+0.5*B(208)+0.3*B(210)+0.5*B(212)+0.92*B(214)& + &+B(216)+B(218)+0.5*B(220)+0.64*B(222)+1.15*B(224)+0.75*B(226)+0.5*B(228)+B(230)+0.45*B(232)+0.5*B(234)& + &+B(306)+2*B(308)+B(310)+2*B(311)+B(365) +! JVS(849) = Jac_FULL(85,24) + JVS(849) = B(484) +! JVS(850) = Jac_FULL(85,25) + JVS(850) = B(489) +! JVS(851) = Jac_FULL(85,51) + JVS(851) = -B(121) +! JVS(852) = Jac_FULL(85,52) + JVS(852) = -B(85) +! JVS(853) = Jac_FULL(85,53) + JVS(853) = -B(125) +! JVS(854) = Jac_FULL(85,54) + JVS(854) = -B(95) +! JVS(855) = Jac_FULL(85,55) + JVS(855) = -B(123) +! JVS(856) = Jac_FULL(85,57) + JVS(856) = -B(105)-B(107) +! JVS(857) = Jac_FULL(85,59) + JVS(857) = -B(117)-B(119) +! JVS(858) = Jac_FULL(85,60) + JVS(858) = -B(99) +! JVS(859) = Jac_FULL(85,62) + JVS(859) = -B(97) +! JVS(860) = Jac_FULL(85,63) + JVS(860) = -B(129) +! JVS(861) = Jac_FULL(85,64) + JVS(861) = -B(113)-B(115) +! JVS(862) = Jac_FULL(85,65) + JVS(862) = -B(111) +! JVS(863) = Jac_FULL(85,66) + JVS(863) = -B(109) +! JVS(864) = Jac_FULL(85,67) + JVS(864) = -B(127) +! JVS(865) = Jac_FULL(85,70) + JVS(865) = -B(87) +! JVS(866) = Jac_FULL(85,72) + JVS(866) = -B(91)-B(93) +! JVS(867) = Jac_FULL(85,73) + JVS(867) = 0 +! JVS(868) = Jac_FULL(85,74) + JVS(868) = -B(79) +! JVS(869) = Jac_FULL(85,76) + JVS(869) = 0 +! JVS(870) = Jac_FULL(85,77) + JVS(870) = 0 +! JVS(871) = Jac_FULL(85,78) + JVS(871) = -B(155) +! JVS(872) = Jac_FULL(85,79) + JVS(872) = -B(101)-B(103) +! JVS(873) = Jac_FULL(85,80) + JVS(873) = 0 +! JVS(874) = Jac_FULL(85,81) + JVS(874) = -B(151) +! JVS(875) = Jac_FULL(85,82) + JVS(875) = B(64)+B(478) +! JVS(876) = Jac_FULL(85,83) + JVS(876) = -B(42) +! JVS(877) = Jac_FULL(85,84) + JVS(877) = -B(17) +! JVS(878) = Jac_FULL(85,85) + JVS(878) = -B(1)-B(18)-B(26)-B(43)-B(53)-B(75)-B(80)-B(86)-B(88)-B(92)-B(94)-B(96)-B(98)-B(100)-B(102)-B(104)-B(106)& + &-B(108)-B(110)-B(112)-B(114)-B(116)-B(118)-B(120)-B(122)-B(124)-B(126)-B(128)-B(130)-B(152)-B(153)-B(156)& + &-B(157) +! JVS(879) = Jac_FULL(85,86) + JVS(879) = -B(76) +! JVS(880) = Jac_FULL(85,87) + JVS(880) = -B(54)+B(65)+B(487) +! JVS(881) = Jac_FULL(85,88) + JVS(881) = -B(154) +! JVS(882) = Jac_FULL(85,89) + JVS(882) = -B(2) +! JVS(883) = Jac_FULL(85,90) + JVS(883) = -B(27) +! JVS(884) = Jac_FULL(86,21) + JVS(884) = B(74)+0.6*B(493) +! JVS(885) = Jac_FULL(86,26) + JVS(885) = B(525) +! JVS(886) = Jac_FULL(86,27) + JVS(886) = 0.5*B(353) +! JVS(887) = Jac_FULL(86,42) + JVS(887) = 0.7*B(523) +! JVS(888) = Jac_FULL(86,49) + JVS(888) = B(495) +! JVS(889) = Jac_FULL(86,51) + JVS(889) = 0.6*B(121)+0.25*B(225)-0.5*B(390)-B(418) +! JVS(890) = Jac_FULL(86,52) + JVS(890) = -B(285)-B(289) +! JVS(891) = Jac_FULL(86,53) + JVS(891) = -B(386)-B(426) +! JVS(892) = Jac_FULL(86,54) + JVS(892) = -B(388)-B(414) +! JVS(893) = Jac_FULL(86,55) + JVS(893) = -B(392)-B(420) +! JVS(894) = Jac_FULL(86,57) + JVS(894) = -B(376)-B(406) +! JVS(895) = Jac_FULL(86,59) + JVS(895) = -B(384)-B(412) +! JVS(896) = Jac_FULL(86,60) + JVS(896) = 0.93*B(99)+0.5*B(211)-B(402) +! JVS(897) = Jac_FULL(86,61) + JVS(897) = B(509) +! JVS(898) = Jac_FULL(86,62) + JVS(898) = 0.96*B(97)+B(173)+0.3*B(209)-0.8*B(370)-B(400) +! JVS(899) = Jac_FULL(86,63) + JVS(899) = -B(396)-B(424) +! JVS(900) = Jac_FULL(86,64) + JVS(900) = 0.72*B(113)+0.36*B(221)-0.28*B(382)-B(410) +! JVS(901) = Jac_FULL(86,65) + JVS(901) = -B(380)-B(416) +! JVS(902) = Jac_FULL(86,66) + JVS(902) = -B(378)-B(408) +! JVS(903) = Jac_FULL(86,67) + JVS(903) = -B(394)-B(422) +! JVS(904) = Jac_FULL(86,70) + JVS(904) = -B(287)-B(291) +! JVS(905) = Jac_FULL(86,71) + JVS(905) = 0.95*B(68)+B(70) +! JVS(906) = Jac_FULL(86,72) + JVS(906) = -B(368)-B(398) +! JVS(907) = Jac_FULL(86,73) + JVS(907) = 0 +! JVS(908) = Jac_FULL(86,74) + JVS(908) = -B(428)-B(430) +! JVS(909) = Jac_FULL(86,75) + JVS(909) = B(271)+B(275)+B(502) +! JVS(910) = Jac_FULL(86,76) + JVS(910) = 0.85*B(497) +! JVS(911) = Jac_FULL(86,77) + JVS(911) = B(505) +! JVS(912) = Jac_FULL(86,78) + JVS(912) = B(155)+B(309) +! JVS(913) = Jac_FULL(86,79) + JVS(913) = -B(374)-B(404) +! JVS(914) = Jac_FULL(86,80) + JVS(914) = B(508) +! JVS(915) = Jac_FULL(86,81) + JVS(915) = -B(432) +! JVS(916) = Jac_FULL(86,82) + JVS(916) = -B(72) +! JVS(917) = Jac_FULL(86,83) + JVS(917) = 0.95*B(69)+B(272)+0.5*B(354) +! JVS(918) = Jac_FULL(86,84) + JVS(918) = B(174)-B(247) +! JVS(919) = Jac_FULL(86,85) + JVS(919) = -B(75)+0.96*B(98)+0.93*B(100)+0.72*B(114)+0.6*B(122)+B(156) +! JVS(920) = Jac_FULL(86,86) + JVS(920) = -B(73)-B(76)-B(248)-B(286)-B(288)-B(290)-B(292)-2*B(363)-B(364)-B(366)-B(369)-0.8*B(371)-B(375)-B(377)& + &-B(379)-B(381)-0.28*B(383)-B(385)-B(387)-B(389)-0.5*B(391)-B(393)-B(395)-B(397)-B(399)-B(401)-B(403)-B(405)& + &-B(407)-B(409)-B(411)-B(413)-B(415)-B(417)-B(419)-B(421)-B(423)-B(425)-B(427)-B(429)-B(431)-B(433)-B(434)& + &-B(438) +! JVS(921) = Jac_FULL(86,87) + JVS(921) = B(71)+B(276) +! JVS(922) = Jac_FULL(86,88) + JVS(922) = -B(435) +! JVS(923) = Jac_FULL(86,89) + JVS(923) = 0 +! JVS(924) = Jac_FULL(86,90) + JVS(924) = 0.3*B(210)+0.5*B(212)+0.36*B(222)+0.25*B(226)+B(310)-B(365)-B(367) +! JVS(925) = Jac_FULL(87,21) + JVS(925) = 0.4*B(493) +! JVS(926) = Jac_FULL(87,22) + JVS(926) = -B(131) +! JVS(927) = Jac_FULL(87,23) + JVS(927) = -B(355) +! JVS(928) = Jac_FULL(87,25) + JVS(928) = B(59)+B(488)+B(489) +! JVS(929) = Jac_FULL(87,29) + JVS(929) = B(485) +! JVS(930) = Jac_FULL(87,34) + JVS(930) = -B(473) +! JVS(931) = Jac_FULL(87,46) + JVS(931) = -B(299) +! JVS(932) = Jac_FULL(87,48) + JVS(932) = -B(267) +! JVS(933) = Jac_FULL(87,56) + JVS(933) = B(40) +! JVS(934) = Jac_FULL(87,57) + JVS(934) = 0 +! JVS(935) = Jac_FULL(87,59) + JVS(935) = 0 +! JVS(936) = Jac_FULL(87,64) + JVS(936) = 0 +! JVS(937) = Jac_FULL(87,65) + JVS(937) = 0 +! JVS(938) = Jac_FULL(87,66) + JVS(938) = 0 +! JVS(939) = Jac_FULL(87,67) + JVS(939) = 0 +! JVS(940) = Jac_FULL(87,68) + JVS(940) = -B(159) +! JVS(941) = Jac_FULL(87,69) + JVS(941) = -B(66) +! JVS(942) = Jac_FULL(87,70) + JVS(942) = 0 +! JVS(943) = Jac_FULL(87,71) + JVS(943) = -B(70) +! JVS(944) = Jac_FULL(87,72) + JVS(944) = 0 +! JVS(945) = Jac_FULL(87,73) + JVS(945) = 0 +! JVS(946) = Jac_FULL(87,74) + JVS(946) = 0 +! JVS(947) = Jac_FULL(87,75) + JVS(947) = -B(275) +! JVS(948) = Jac_FULL(87,76) + JVS(948) = -B(203) +! JVS(949) = Jac_FULL(87,77) + JVS(949) = 0 +! JVS(950) = Jac_FULL(87,78) + JVS(950) = 0 +! JVS(951) = Jac_FULL(87,79) + JVS(951) = 0 +! JVS(952) = Jac_FULL(87,80) + JVS(952) = -B(301)-B(303) +! JVS(953) = Jac_FULL(87,81) + JVS(953) = 0 +! JVS(954) = Jac_FULL(87,82) + JVS(954) = B(7)-B(57)-B(64) +! JVS(955) = Jac_FULL(87,83) + JVS(955) = B(41)-B(55) +! JVS(956) = Jac_FULL(87,84) + JVS(956) = -B(51) +! JVS(957) = Jac_FULL(87,85) + JVS(957) = -B(53) +! JVS(958) = Jac_FULL(87,86) + JVS(958) = 0 +! JVS(959) = Jac_FULL(87,87) + JVS(959) = -B(52)-B(54)-B(56)-B(58)-B(65)-B(67)-B(71)-B(132)-B(160)-B(204)-B(268)-B(273)-B(276)-B(300)-B(302)-B(304)& + &-B(356)-2*B(440)-B(467)-B(474)-B(486)-B(487) +! JVS(960) = Jac_FULL(87,88) + JVS(960) = 0 +! JVS(961) = Jac_FULL(87,89) + JVS(961) = B(8) +! JVS(962) = Jac_FULL(87,90) + JVS(962) = 0 +! JVS(963) = Jac_FULL(88,19) + JVS(963) = B(144) +! JVS(964) = Jac_FULL(88,36) + JVS(964) = B(337) +! JVS(965) = Jac_FULL(88,50) + JVS(965) = 0.8*B(265) +! JVS(966) = Jac_FULL(88,51) + JVS(966) = 0 +! JVS(967) = Jac_FULL(88,58) + JVS(967) = 0 +! JVS(968) = Jac_FULL(88,64) + JVS(968) = 0 +! JVS(969) = Jac_FULL(88,65) + JVS(969) = 0 +! JVS(970) = Jac_FULL(88,66) + JVS(970) = 0 +! JVS(971) = Jac_FULL(88,77) + JVS(971) = 0 +! JVS(972) = Jac_FULL(88,79) + JVS(972) = 0 +! JVS(973) = Jac_FULL(88,80) + JVS(973) = 0 +! JVS(974) = Jac_FULL(88,82) + JVS(974) = -B(142) +! JVS(975) = Jac_FULL(88,83) + JVS(975) = 0.8*B(266)+B(338) +! JVS(976) = Jac_FULL(88,84) + JVS(976) = -B(251) +! JVS(977) = Jac_FULL(88,85) + JVS(977) = -B(153) +! JVS(978) = Jac_FULL(88,86) + JVS(978) = -B(434) +! JVS(979) = Jac_FULL(88,87) + JVS(979) = 0 +! JVS(980) = Jac_FULL(88,88) + JVS(980) = -B(143)-B(154)-B(252)-B(307)-B(315)-B(435) +! JVS(981) = Jac_FULL(88,89) + JVS(981) = 0 +! JVS(982) = Jac_FULL(88,90) + JVS(982) = -B(308)-B(316) +! JVS(983) = Jac_FULL(89,25) + JVS(983) = B(489) +! JVS(984) = Jac_FULL(89,44) + JVS(984) = -B(263) +! JVS(985) = Jac_FULL(89,46) + JVS(985) = -0.9*B(293) +! JVS(986) = Jac_FULL(89,48) + JVS(986) = -B(259) +! JVS(987) = Jac_FULL(89,58) + JVS(987) = -0.7*B(361) +! JVS(988) = Jac_FULL(89,77) + JVS(988) = -0.8*B(295) +! JVS(989) = Jac_FULL(89,78) + JVS(989) = 0.3*B(253) +! JVS(990) = Jac_FULL(89,79) + JVS(990) = 0 +! JVS(991) = Jac_FULL(89,80) + JVS(991) = -0.8*B(297) +! JVS(992) = Jac_FULL(89,81) + JVS(992) = 0.3*B(249) +! JVS(993) = Jac_FULL(89,82) + JVS(993) = -B(7)+B(478) +! JVS(994) = Jac_FULL(89,83) + JVS(994) = -B(3)+B(11) +! JVS(995) = Jac_FULL(89,84) + JVS(995) = -B(5)+0.15*B(247)+0.3*B(250)+0.29*B(251)+0.3*B(254)+0.3*B(255) +! JVS(996) = Jac_FULL(89,85) + JVS(996) = -B(1) +! JVS(997) = Jac_FULL(89,86) + JVS(997) = 0.15*B(248) +! JVS(998) = Jac_FULL(89,87) + JVS(998) = B(486) +! JVS(999) = Jac_FULL(89,88) + JVS(999) = 0.29*B(252) +! JVS(1000) = Jac_FULL(89,89) + JVS(1000) = -B(2)-B(4)-B(6)-B(8)-B(9)-B(260)-B(264)-0.9*B(294)-0.8*B(296)-0.8*B(298)-0.7*B(362)-B(456)-B(477) +! JVS(1001) = Jac_FULL(89,90) + JVS(1001) = -B(10) +! JVS(1002) = Jac_FULL(90,21) + JVS(1002) = 0.4*B(493) +! JVS(1003) = Jac_FULL(90,27) + JVS(1003) = B(527) +! JVS(1004) = Jac_FULL(90,28) + JVS(1004) = B(32) +! JVS(1005) = Jac_FULL(90,34) + JVS(1005) = B(469)+B(471)+B(473) +! JVS(1006) = Jac_FULL(90,48) + JVS(1006) = 0.305*B(259) +! JVS(1007) = Jac_FULL(90,49) + JVS(1007) = B(495)+2*B(496) +! JVS(1008) = Jac_FULL(90,51) + JVS(1008) = -B(225)+B(390) +! JVS(1009) = Jac_FULL(90,52) + JVS(1009) = -B(165)+B(285) +! JVS(1010) = Jac_FULL(90,53) + JVS(1010) = -B(229)+B(386) +! JVS(1011) = Jac_FULL(90,54) + JVS(1011) = -B(207)+B(388) +! JVS(1012) = Jac_FULL(90,55) + JVS(1012) = -B(227)+B(392) +! JVS(1013) = Jac_FULL(90,57) + JVS(1013) = -B(215)+B(376) +! JVS(1014) = Jac_FULL(90,59) + JVS(1014) = -B(223)+B(384) +! JVS(1015) = Jac_FULL(90,60) + JVS(1015) = B(175)-B(211)+B(372) +! JVS(1016) = Jac_FULL(90,62) + JVS(1016) = B(173)-B(209)+B(370) +! JVS(1017) = Jac_FULL(90,63) + JVS(1017) = -B(233)+B(396) +! JVS(1018) = Jac_FULL(90,64) + JVS(1018) = -B(221)+B(382) +! JVS(1019) = Jac_FULL(90,65) + JVS(1019) = -B(219)+B(380) +! JVS(1020) = Jac_FULL(90,66) + JVS(1020) = -B(217)+B(378) +! JVS(1021) = Jac_FULL(90,67) + JVS(1021) = -B(231)+B(394) +! JVS(1022) = Jac_FULL(90,70) + JVS(1022) = -B(167)+B(287) +! JVS(1023) = Jac_FULL(90,71) + JVS(1023) = B(491) +! JVS(1024) = Jac_FULL(90,72) + JVS(1024) = 0.18*B(91)-0.91*B(205)+1.18*B(368) +! JVS(1025) = Jac_FULL(90,73) + JVS(1025) = 0.18*B(526) +! JVS(1026) = Jac_FULL(90,74) + JVS(1026) = -B(201)+B(428) +! JVS(1027) = Jac_FULL(90,75) + JVS(1027) = 0 +! JVS(1028) = Jac_FULL(90,76) + JVS(1028) = 0.15*B(497) +! JVS(1029) = Jac_FULL(90,77) + JVS(1029) = B(506) +! JVS(1030) = Jac_FULL(90,78) + JVS(1030) = -B(309)-B(317)+B(436) +! JVS(1031) = Jac_FULL(90,79) + JVS(1031) = -B(213)+B(374) +! JVS(1032) = Jac_FULL(90,80) + JVS(1032) = 0 +! JVS(1033) = Jac_FULL(90,81) + JVS(1033) = -B(305)-B(313)+B(432) +! JVS(1034) = Jac_FULL(90,82) + JVS(1034) = 0 +! JVS(1035) = Jac_FULL(90,83) + JVS(1035) = B(24)+B(33)+B(135)+B(470)+B(472) +! JVS(1036) = Jac_FULL(90,84) + JVS(1036) = -B(28)+B(174)+B(176)+0.44*B(247) +! JVS(1037) = Jac_FULL(90,85) + JVS(1037) = -B(26)+B(75)+0.18*B(92) +! JVS(1038) = Jac_FULL(90,86) + JVS(1038) = B(76)+0.44*B(248)+B(286)+B(288)+2*B(363)-B(366)+1.18*B(369)+B(371)+B(373)+B(375)+B(377)+B(379)+B(381)& + &+B(383)+B(385)+B(387)+B(389)+B(391)+B(393)+B(395)+B(397)+B(429)+B(433)+B(434)+B(437)+B(438) +! JVS(1039) = Jac_FULL(90,87) + JVS(1039) = B(474) +! JVS(1040) = Jac_FULL(90,88) + JVS(1040) = -B(307)-B(315)+B(435) +! JVS(1041) = Jac_FULL(90,89) + JVS(1041) = -B(9)+0.305*B(260) +! JVS(1042) = Jac_FULL(90,90) + JVS(1042) = -B(10)-B(27)-B(29)-2*B(30)-2*B(31)-B(166)-B(168)-B(202)-0.91*B(206)-B(208)-B(210)-B(212)-B(214)-B(216)& + &-B(218)-B(220)-B(222)-B(224)-B(226)-B(228)-B(230)-B(232)-B(234)-B(306)-B(308)-B(310)-B(311)-B(314)-B(316)& + &-B(318)-B(319)-B(367) + +END SUBROUTINE Jac_SP + +! End of Jac_SP function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Jac_SP_Vec - function for sparse multiplication: sparse Jacobian times vector +! Arguments : +! JVS - sparse Jacobian of variables +! UV - User vector for variables +! JUV - Jacobian times user vector +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE Jac_SP_Vec ( JVS, UV, JUV ) + +! JVS - sparse Jacobian of variables + REAL(kind=dp) :: JVS(LU_NONZERO) +! UV - User vector for variables + REAL(kind=dp) :: UV(NVAR) +! JUV - Jacobian times user vector + REAL(kind=dp) :: JUV(NVAR) + + JUV(1) = JVS(1)*UV(1)+JVS(2)*UV(69) + JUV(2) = JVS(3)*UV(2)+JVS(4)*UV(17) + JUV(3) = JVS(5)*UV(3)+JVS(6)*UV(56) + JUV(4) = JVS(7)*UV(4)+JVS(8)*UV(25) + JUV(5) = JVS(9)*UV(5)+JVS(10)*UV(82) + JUV(6) = JVS(11)*UV(6)+JVS(12)*UV(89) + JUV(7) = JVS(13)*UV(7)+JVS(14)*UV(21) + JUV(8) = JVS(15)*UV(8)+JVS(16)*UV(44) + JUV(9) = JVS(17)*UV(9)+JVS(18)*UV(18) + JUV(10) = JVS(19)*UV(10)+JVS(20)*UV(73) + JUV(11) = JVS(21)*UV(11)+JVS(22)*UV(20)+JVS(23)*UV(83) + JUV(12) = JVS(24)*UV(12)+JVS(25)*UV(34)+JVS(26)*UV(83) + JUV(13) = JVS(27)*UV(13)+JVS(28)*UV(46)+JVS(29)*UV(47)+JVS(30)*UV(80)+JVS(31)*UV(83)+JVS(32)*UV(85)+JVS(33)*UV(86)& + &+JVS(34)*UV(89) + JUV(14) = JVS(35)*UV(14)+JVS(36)*UV(17)+JVS(37)*UV(18)+JVS(38)*UV(21)+JVS(39)*UV(25)+JVS(40)*UV(44)+JVS(41)*UV(56)& + &+JVS(42)*UV(69)+JVS(43)*UV(73)+JVS(44)*UV(82)+JVS(45)*UV(89) + JUV(15) = JVS(46)*UV(15)+JVS(47)*UV(46)+JVS(48)*UV(83) + JUV(16) = JVS(49)*UV(16)+JVS(50)*UV(83) + JUV(17) = JVS(51)*UV(17)+JVS(52)*UV(83)+JVS(53)*UV(84) + JUV(18) = JVS(54)*UV(18)+JVS(55)*UV(81)+JVS(56)*UV(82) + JUV(19) = JVS(57)*UV(19)+JVS(58)*UV(82)+JVS(59)*UV(88) + JUV(20) = JVS(60)*UV(20)+JVS(61)*UV(34)+JVS(62)*UV(83)+JVS(63)*UV(87) + JUV(21) = JVS(64)*UV(21)+JVS(65)*UV(82)+JVS(66)*UV(86) + JUV(22) = JVS(67)*UV(22)+JVS(68)*UV(83)+JVS(69)*UV(87) + JUV(23) = JVS(70)*UV(23)+JVS(71)*UV(83)+JVS(72)*UV(87) + JUV(24) = JVS(73)*UV(24)+JVS(74)*UV(82)+JVS(75)*UV(83)+JVS(76)*UV(85) + JUV(25) = JVS(77)*UV(25)+JVS(78)*UV(82)+JVS(79)*UV(87) + JUV(26) = JVS(80)*UV(26)+JVS(81)*UV(78)+JVS(82)*UV(83)+JVS(83)*UV(84) + JUV(27) = JVS(84)*UV(27)+JVS(85)*UV(83)+JVS(86)*UV(84)+JVS(87)*UV(86) + JUV(28) = JVS(88)*UV(28)+JVS(89)*UV(83)+JVS(90)*UV(84)+JVS(91)*UV(90) + JUV(29) = JVS(92)*UV(29)+JVS(93)*UV(82)+JVS(94)*UV(83)+JVS(95)*UV(84) + JUV(30) = JVS(96)*UV(30)+JVS(97)*UV(72)+JVS(98)*UV(83)+JVS(99)*UV(84) + JUV(31) = JVS(100)*UV(31)+JVS(101)*UV(52)+JVS(102)*UV(83)+JVS(103)*UV(84) + JUV(32) = JVS(104)*UV(32)+JVS(105)*UV(53)+JVS(106)*UV(83)+JVS(107)*UV(84) + JUV(33) = JVS(108)*UV(33)+JVS(109)*UV(81)+JVS(110)*UV(83)+JVS(111)*UV(84) + JUV(34) = JVS(112)*UV(34)+JVS(113)*UV(83)+JVS(114)*UV(87) + JUV(35) = JVS(115)*UV(35)+JVS(116)*UV(74)+JVS(117)*UV(83)+JVS(118)*UV(84) + JUV(36) = JVS(119)*UV(36)+JVS(120)*UV(83)+JVS(121)*UV(84)+JVS(122)*UV(88) + JUV(37) = JVS(123)*UV(37)+JVS(124)*UV(70)+JVS(125)*UV(83)+JVS(126)*UV(84) + JUV(38) = JVS(127)*UV(38)+JVS(128)*UV(63)+JVS(129)*UV(83)+JVS(130)*UV(84) + JUV(39) = JVS(131)*UV(39)+JVS(132)*UV(67)+JVS(133)*UV(83)+JVS(134)*UV(84) + JUV(40) = JVS(135)*UV(40)+JVS(136)*UV(59)+JVS(137)*UV(83)+JVS(138)*UV(84) + JUV(41) = JVS(139)*UV(41)+JVS(140)*UV(66)+JVS(141)*UV(83)+JVS(142)*UV(84) + JUV(42) = JVS(143)*UV(42)+JVS(144)*UV(64)+JVS(145)*UV(83)+JVS(146)*UV(84) + JUV(43) = JVS(147)*UV(43)+JVS(148)*UV(51)+JVS(149)*UV(55)+JVS(150)*UV(65)+JVS(151)*UV(83)+JVS(152)*UV(84) + JUV(44) = JVS(153)*UV(44)+JVS(154)*UV(78)+JVS(155)*UV(82)+JVS(156)*UV(83)+JVS(157)*UV(89) + JUV(45) = JVS(158)*UV(45)+JVS(159)*UV(57)+JVS(160)*UV(79)+JVS(161)*UV(83)+JVS(162)*UV(84) + JUV(46) = JVS(163)*UV(46)+JVS(164)*UV(83)+JVS(165)*UV(87)+JVS(166)*UV(89) + JUV(47) = JVS(167)*UV(40)+JVS(168)*UV(41)+JVS(169)*UV(46)+JVS(170)*UV(47)+JVS(171)*UV(48)+JVS(172)*UV(49)+JVS(173)& + &*UV(50)+JVS(174)*UV(58)+JVS(175)*UV(59)+JVS(176)*UV(66)+JVS(177)*UV(68)+JVS(178)*UV(69)+JVS(179)*UV(71)& + &+JVS(180)*UV(75)+JVS(181)*UV(77)+JVS(182)*UV(80)+JVS(183)*UV(83)+JVS(185)*UV(85)+JVS(186)*UV(86)+JVS(187)& + &*UV(87)+JVS(188)*UV(89)+JVS(189)*UV(90) + JUV(48) = JVS(190)*UV(46)+JVS(191)*UV(48)+JVS(192)*UV(77)+JVS(193)*UV(83)+JVS(194)*UV(87)+JVS(195)*UV(89) + JUV(49) = JVS(196)*UV(32)+JVS(197)*UV(49)+JVS(198)*UV(53)+JVS(199)*UV(72)+JVS(200)*UV(73)+JVS(201)*UV(83)+JVS(203)& + &*UV(85)+JVS(204)*UV(86)+JVS(205)*UV(90) + JUV(50) = JVS(206)*UV(41)+JVS(207)*UV(42)+JVS(208)*UV(50)+JVS(209)*UV(51)+JVS(210)*UV(58)+JVS(211)*UV(64)+JVS(212)& + &*UV(65)+JVS(213)*UV(66)+JVS(214)*UV(83)+JVS(216)*UV(85)+JVS(217)*UV(86)+JVS(218)*UV(89)+JVS(219)*UV(90) + JUV(51) = JVS(220)*UV(51)+JVS(221)*UV(84)+JVS(222)*UV(85)+JVS(223)*UV(86)+JVS(224)*UV(90) + JUV(52) = JVS(225)*UV(16)+JVS(226)*UV(31)+JVS(227)*UV(52)+JVS(228)*UV(72)+JVS(229)*UV(73)+JVS(230)*UV(83)+JVS(231)& + &*UV(84)+JVS(232)*UV(85)+JVS(233)*UV(86)+JVS(234)*UV(90) + JUV(53) = JVS(235)*UV(16)+JVS(236)*UV(32)+JVS(237)*UV(53)+JVS(238)*UV(72)+JVS(239)*UV(73)+JVS(240)*UV(83)+JVS(241)& + &*UV(84)+JVS(242)*UV(85)+JVS(243)*UV(86)+JVS(244)*UV(90) + JUV(54) = JVS(245)*UV(54)+JVS(246)*UV(73)+JVS(247)*UV(83)+JVS(248)*UV(84)+JVS(249)*UV(85)+JVS(250)*UV(86)+JVS(251)& + &*UV(90) + JUV(55) = JVS(252)*UV(55)+JVS(253)*UV(80)+JVS(254)*UV(84)+JVS(255)*UV(85)+JVS(256)*UV(86)+JVS(257)*UV(87)+JVS(258)& + &*UV(90) + JUV(56) = JVS(259)*UV(22)+JVS(260)*UV(23)+JVS(261)*UV(25)+JVS(262)*UV(34)+JVS(263)*UV(51)+JVS(264)*UV(56)+JVS(265)& + &*UV(57)+JVS(266)*UV(59)+JVS(267)*UV(64)+JVS(268)*UV(65)+JVS(269)*UV(66)+JVS(270)*UV(67)+JVS(271)*UV(68)& + &+JVS(272)*UV(69)+JVS(273)*UV(71)+JVS(274)*UV(75)+JVS(275)*UV(76)+JVS(276)*UV(79)+JVS(277)*UV(80)+JVS(278)& + &*UV(82)+JVS(279)*UV(83)+JVS(281)*UV(85)+JVS(282)*UV(86)+JVS(283)*UV(87)+JVS(284)*UV(90) + JUV(57) = JVS(285)*UV(57)+JVS(286)*UV(79)+JVS(287)*UV(84)+JVS(288)*UV(85)+JVS(289)*UV(86)+JVS(290)*UV(90) + JUV(58) = JVS(291)*UV(45)+JVS(292)*UV(57)+JVS(293)*UV(58)+JVS(294)*UV(79)+JVS(295)*UV(83)+JVS(297)*UV(85)+JVS(298)& + &*UV(86)+JVS(299)*UV(89)+JVS(300)*UV(90) + JUV(59) = JVS(301)*UV(40)+JVS(302)*UV(59)+JVS(303)*UV(80)+JVS(304)*UV(83)+JVS(305)*UV(84)+JVS(306)*UV(85)+JVS(307)& + &*UV(86)+JVS(308)*UV(90) + JUV(60) = JVS(309)*UV(60)+JVS(310)*UV(76)+JVS(311)*UV(83)+JVS(312)*UV(84)+JVS(313)*UV(85)+JVS(314)*UV(86)+JVS(315)& + &*UV(87)+JVS(316)*UV(90) + JUV(61) = JVS(317)*UV(40)+JVS(318)*UV(41)+JVS(319)*UV(44)+JVS(320)*UV(58)+JVS(321)*UV(59)+JVS(322)*UV(61)+JVS(323)& + &*UV(62)+JVS(324)*UV(65)+JVS(325)*UV(66)+JVS(326)*UV(70)+JVS(331)*UV(83)+JVS(333)*UV(85)+JVS(334)*UV(86)& + &+JVS(335)*UV(89)+JVS(336)*UV(90) + JUV(62) = JVS(337)*UV(49)+JVS(339)*UV(62)+JVS(342)*UV(83)+JVS(343)*UV(84)+JVS(344)*UV(85)+JVS(345)*UV(86)+JVS(346)& + &*UV(90) + JUV(63) = JVS(347)*UV(38)+JVS(348)*UV(48)+JVS(349)*UV(63)+JVS(351)*UV(83)+JVS(352)*UV(84)+JVS(353)*UV(85)+JVS(354)& + &*UV(86)+JVS(355)*UV(87)+JVS(357)*UV(90) + JUV(64) = JVS(358)*UV(42)+JVS(359)*UV(64)+JVS(360)*UV(77)+JVS(361)*UV(83)+JVS(362)*UV(84)+JVS(363)*UV(85)+JVS(364)& + &*UV(86)+JVS(365)*UV(90) + JUV(65) = JVS(366)*UV(43)+JVS(369)*UV(65)+JVS(371)*UV(83)+JVS(372)*UV(84)+JVS(373)*UV(85)+JVS(374)*UV(86)+JVS(376)& + &*UV(90) + JUV(66) = JVS(377)*UV(41)+JVS(378)*UV(58)+JVS(379)*UV(66)+JVS(381)*UV(83)+JVS(382)*UV(84)+JVS(383)*UV(85)+JVS(384)& + &*UV(86)+JVS(386)*UV(90) + JUV(67) = JVS(387)*UV(39)+JVS(388)*UV(46)+JVS(389)*UV(67)+JVS(390)*UV(83)+JVS(391)*UV(84)+JVS(392)*UV(85)+JVS(393)& + &*UV(86)+JVS(394)*UV(87)+JVS(396)*UV(90) + JUV(68) = JVS(397)*UV(30)+JVS(398)*UV(31)+JVS(399)*UV(38)+JVS(400)*UV(39)+JVS(401)*UV(42)+JVS(402)*UV(43)+JVS(403)& + &*UV(51)+JVS(404)*UV(52)+JVS(405)*UV(54)+JVS(406)*UV(55)+JVS(407)*UV(63)+JVS(409)*UV(65)+JVS(410)*UV(67)& + &+JVS(411)*UV(68)+JVS(412)*UV(70)+JVS(413)*UV(72)+JVS(414)*UV(73)+JVS(417)*UV(83)+JVS(419)*UV(85)+JVS(420)& + &*UV(86)+JVS(421)*UV(87)+JVS(423)*UV(90) + JUV(69) = JVS(424)*UV(26)+JVS(425)*UV(27)+JVS(426)*UV(28)+JVS(427)*UV(34)+JVS(428)*UV(36)+JVS(429)*UV(37)+JVS(430)& + &*UV(40)+JVS(431)*UV(42)+JVS(432)*UV(44)+JVS(433)*UV(45)+JVS(434)*UV(46)+JVS(435)*UV(48)+JVS(436)*UV(50)& + &+JVS(437)*UV(51)+JVS(438)*UV(52)+JVS(439)*UV(53)+JVS(440)*UV(54)+JVS(441)*UV(55)+JVS(442)*UV(57)+JVS(443)& + &*UV(58)+JVS(444)*UV(59)+JVS(445)*UV(60)+JVS(446)*UV(61)+JVS(447)*UV(62)+JVS(448)*UV(63)+JVS(449)*UV(64)& + &+JVS(450)*UV(65)+JVS(451)*UV(66)+JVS(452)*UV(67)+JVS(453)*UV(69)+JVS(454)*UV(70)+JVS(455)*UV(71)+JVS(456)& + &*UV(72)+JVS(458)*UV(74)+JVS(460)*UV(77)+JVS(461)*UV(78)+JVS(462)*UV(79)+JVS(463)*UV(80)+JVS(464)*UV(81)& + &+JVS(466)*UV(83)+JVS(467)*UV(84)+JVS(468)*UV(85)+JVS(469)*UV(86)+JVS(470)*UV(87)+JVS(471)*UV(88)+JVS(472)& + &*UV(89)+JVS(473)*UV(90) + JUV(70) = JVS(474)*UV(37)+JVS(475)*UV(48)+JVS(476)*UV(70)+JVS(478)*UV(83)+JVS(479)*UV(84)+JVS(480)*UV(85)+JVS(481)& + &*UV(86)+JVS(484)*UV(90) + JUV(71) = JVS(485)*UV(33)+JVS(486)*UV(35)+JVS(487)*UV(37)+JVS(488)*UV(48)+JVS(489)*UV(54)+JVS(490)*UV(60)+JVS(491)& + &*UV(63)+JVS(492)*UV(70)+JVS(493)*UV(71)+JVS(494)*UV(72)+JVS(495)*UV(73)+JVS(496)*UV(74)+JVS(497)*UV(75)& + &+JVS(499)*UV(77)+JVS(501)*UV(83)+JVS(503)*UV(85)+JVS(504)*UV(86)+JVS(505)*UV(87)+JVS(506)*UV(89)+JVS(507)& + &*UV(90) + JUV(72) = JVS(508)*UV(22)+JVS(509)*UV(30)+JVS(510)*UV(54)+JVS(511)*UV(72)+JVS(513)*UV(83)+JVS(514)*UV(84)+JVS(515)& + &*UV(85)+JVS(516)*UV(86)+JVS(517)*UV(87)+JVS(518)*UV(90) + JUV(73) = JVS(519)*UV(54)+JVS(520)*UV(60)+JVS(521)*UV(62)+JVS(522)*UV(72)+JVS(523)*UV(73)+JVS(525)*UV(83)+JVS(526)& + &*UV(84)+JVS(527)*UV(85) + JUV(74) = JVS(531)*UV(23)+JVS(532)*UV(35)+JVS(533)*UV(68)+JVS(535)*UV(72)+JVS(536)*UV(73)+JVS(537)*UV(74)+JVS(538)& + &*UV(76)+JVS(541)*UV(81)+JVS(542)*UV(83)+JVS(543)*UV(84)+JVS(544)*UV(85)+JVS(545)*UV(86)+JVS(546)*UV(87)& + &+JVS(548)*UV(90) + JUV(75) = JVS(549)*UV(41)+JVS(550)*UV(42)+JVS(551)*UV(51)+JVS(552)*UV(55)+JVS(553)*UV(58)+JVS(554)*UV(59)+JVS(555)& + &*UV(60)+JVS(556)*UV(61)+JVS(557)*UV(62)+JVS(558)*UV(64)+JVS(560)*UV(66)+JVS(564)*UV(75)+JVS(566)*UV(77)& + &+JVS(569)*UV(80)+JVS(571)*UV(83)+JVS(572)*UV(84)+JVS(573)*UV(85)+JVS(574)*UV(86)+JVS(575)*UV(87)+JVS(576)& + &*UV(89)+JVS(577)*UV(90) + JUV(76) = JVS(578)*UV(57)+JVS(579)*UV(59)+JVS(580)*UV(60)+JVS(581)*UV(62)+JVS(582)*UV(64)+JVS(583)*UV(66)+JVS(584)& + &*UV(72)+JVS(585)*UV(73)+JVS(586)*UV(76)+JVS(588)*UV(79)+JVS(590)*UV(83)+JVS(592)*UV(85)+JVS(593)*UV(86)& + &+JVS(594)*UV(87)+JVS(596)*UV(90) + JUV(77) = JVS(597)*UV(45)+JVS(598)*UV(46)+JVS(600)*UV(67)+JVS(601)*UV(77)+JVS(602)*UV(79)+JVS(603)*UV(83)+JVS(605)& + &*UV(85)+JVS(606)*UV(86)+JVS(608)*UV(89)+JVS(609)*UV(90) + JUV(78) = JVS(610)*UV(26)+JVS(611)*UV(44)+JVS(612)*UV(58)+JVS(613)*UV(77)+JVS(614)*UV(78)+JVS(616)*UV(80)+JVS(617)& + &*UV(82)+JVS(618)*UV(83)+JVS(619)*UV(84)+JVS(620)*UV(85)+JVS(621)*UV(86)+JVS(622)*UV(87)+JVS(624)*UV(90) + JUV(79) = JVS(625)*UV(45)+JVS(626)*UV(46)+JVS(628)*UV(79)+JVS(629)*UV(83)+JVS(630)*UV(84)+JVS(631)*UV(85)+JVS(632)& + &*UV(86)+JVS(635)*UV(90) + JUV(80) = JVS(636)*UV(45)+JVS(637)*UV(46)+JVS(639)*UV(67)+JVS(640)*UV(79)+JVS(641)*UV(80)+JVS(642)*UV(83)+JVS(644)& + &*UV(85)+JVS(645)*UV(86)+JVS(646)*UV(87)+JVS(647)*UV(89)+JVS(648)*UV(90) + JUV(81) = JVS(649)*UV(18)+JVS(650)*UV(33)+JVS(651)*UV(68)+JVS(655)*UV(76)+JVS(659)*UV(81)+JVS(660)*UV(82)+JVS(661)& + &*UV(83)+JVS(662)*UV(84)+JVS(663)*UV(85)+JVS(664)*UV(86)+JVS(665)*UV(87)+JVS(667)*UV(90) + JUV(82) = JVS(668)*UV(18)+JVS(669)*UV(19)+JVS(670)*UV(21)+JVS(671)*UV(24)+JVS(672)*UV(25)+JVS(673)*UV(29)+JVS(674)& + &*UV(38)+JVS(675)*UV(39)+JVS(676)*UV(43)+JVS(677)*UV(44)+JVS(678)*UV(51)+JVS(679)*UV(52)+JVS(680)*UV(53)& + &+JVS(681)*UV(54)+JVS(682)*UV(55)+JVS(683)*UV(56)+JVS(684)*UV(57)+JVS(685)*UV(59)+JVS(686)*UV(60)+JVS(687)& + &*UV(62)+JVS(688)*UV(63)+JVS(689)*UV(64)+JVS(690)*UV(65)+JVS(691)*UV(66)+JVS(692)*UV(67)+JVS(695)*UV(70)& + &+JVS(697)*UV(72)+JVS(698)*UV(73)+JVS(699)*UV(74)+JVS(703)*UV(78)+JVS(704)*UV(79)+JVS(706)*UV(81)+JVS(707)& + &*UV(82)+JVS(708)*UV(83)+JVS(709)*UV(84)+JVS(710)*UV(85)+JVS(711)*UV(86)+JVS(712)*UV(87)+JVS(713)*UV(88)& + &+JVS(714)*UV(89)+JVS(715)*UV(90) + JUV(83) = JVS(716)*UV(16)+JVS(717)*UV(17)+JVS(718)*UV(20)+JVS(719)*UV(22)+JVS(720)*UV(23)+JVS(721)*UV(24)+JVS(722)& + &*UV(26)+JVS(723)*UV(27)+JVS(724)*UV(28)+JVS(725)*UV(29)+JVS(726)*UV(30)+JVS(727)*UV(31)+JVS(728)*UV(32)& + &+JVS(729)*UV(33)+JVS(730)*UV(34)+JVS(731)*UV(35)+JVS(732)*UV(36)+JVS(733)*UV(37)+JVS(734)*UV(38)+JVS(735)& + &*UV(39)+JVS(736)*UV(40)+JVS(737)*UV(41)+JVS(738)*UV(42)+JVS(739)*UV(43)+JVS(740)*UV(44)+JVS(741)*UV(45)& + &+JVS(742)*UV(46)+JVS(743)*UV(47)+JVS(744)*UV(48)+JVS(745)*UV(49)+JVS(746)*UV(50)+JVS(751)*UV(56)+JVS(753)& + &*UV(58)+JVS(755)*UV(61)+JVS(762)*UV(68)+JVS(763)*UV(69)+JVS(765)*UV(71)+JVS(767)*UV(73)+JVS(769)*UV(75)& + &+JVS(770)*UV(76)+JVS(771)*UV(77)+JVS(774)*UV(80)+JVS(776)*UV(82)+JVS(777)*UV(83)+JVS(778)*UV(84)+JVS(779)& + &*UV(85)+JVS(780)*UV(86)+JVS(781)*UV(87)+JVS(783)*UV(89) + JUV(84) = JVS(785)*UV(17)+JVS(786)*UV(20)+JVS(787)*UV(28)+JVS(788)*UV(29)+JVS(789)*UV(30)+JVS(790)*UV(31)+JVS(791)& + &*UV(32)+JVS(792)*UV(33)+JVS(794)*UV(35)+JVS(795)*UV(36)+JVS(796)*UV(37)+JVS(797)*UV(38)+JVS(798)*UV(39)& + &+JVS(799)*UV(40)+JVS(800)*UV(41)+JVS(801)*UV(42)+JVS(802)*UV(43)+JVS(803)*UV(44)+JVS(804)*UV(45)+JVS(805)& + &*UV(46)+JVS(806)*UV(47)+JVS(807)*UV(48)+JVS(809)*UV(50)+JVS(810)*UV(51)+JVS(811)*UV(52)+JVS(812)*UV(53)& + &+JVS(813)*UV(54)+JVS(814)*UV(55)+JVS(815)*UV(57)+JVS(816)*UV(58)+JVS(817)*UV(59)+JVS(818)*UV(60)+JVS(819)& + &*UV(61)+JVS(820)*UV(62)+JVS(821)*UV(63)+JVS(822)*UV(64)+JVS(823)*UV(65)+JVS(824)*UV(66)+JVS(825)*UV(67)& + &+JVS(826)*UV(68)+JVS(827)*UV(69)+JVS(828)*UV(70)+JVS(829)*UV(71)+JVS(830)*UV(72)+JVS(831)*UV(73)+JVS(832)& + &*UV(74)+JVS(833)*UV(75)+JVS(835)*UV(77)+JVS(836)*UV(78)+JVS(837)*UV(79)+JVS(838)*UV(80)+JVS(839)*UV(81)& + &+JVS(840)*UV(82)+JVS(841)*UV(83)+JVS(842)*UV(84)+JVS(843)*UV(85)+JVS(844)*UV(86)+JVS(845)*UV(87)+JVS(846)& + &*UV(88)+JVS(847)*UV(89)+JVS(848)*UV(90) + JUV(85) = JVS(849)*UV(24)+JVS(850)*UV(25)+JVS(851)*UV(51)+JVS(852)*UV(52)+JVS(853)*UV(53)+JVS(854)*UV(54)+JVS(855)& + &*UV(55)+JVS(856)*UV(57)+JVS(857)*UV(59)+JVS(858)*UV(60)+JVS(859)*UV(62)+JVS(860)*UV(63)+JVS(861)*UV(64)& + &+JVS(862)*UV(65)+JVS(863)*UV(66)+JVS(864)*UV(67)+JVS(865)*UV(70)+JVS(866)*UV(72)+JVS(868)*UV(74)+JVS(871)& + &*UV(78)+JVS(872)*UV(79)+JVS(874)*UV(81)+JVS(875)*UV(82)+JVS(876)*UV(83)+JVS(877)*UV(84)+JVS(878)*UV(85)& + &+JVS(879)*UV(86)+JVS(880)*UV(87)+JVS(881)*UV(88)+JVS(882)*UV(89)+JVS(883)*UV(90) + JUV(86) = JVS(884)*UV(21)+JVS(885)*UV(26)+JVS(886)*UV(27)+JVS(887)*UV(42)+JVS(888)*UV(49)+JVS(889)*UV(51)+JVS(890)& + &*UV(52)+JVS(891)*UV(53)+JVS(892)*UV(54)+JVS(893)*UV(55)+JVS(894)*UV(57)+JVS(895)*UV(59)+JVS(896)*UV(60)& + &+JVS(897)*UV(61)+JVS(898)*UV(62)+JVS(899)*UV(63)+JVS(900)*UV(64)+JVS(901)*UV(65)+JVS(902)*UV(66)+JVS(903)& + &*UV(67)+JVS(904)*UV(70)+JVS(905)*UV(71)+JVS(906)*UV(72)+JVS(908)*UV(74)+JVS(909)*UV(75)+JVS(910)*UV(76)& + &+JVS(911)*UV(77)+JVS(912)*UV(78)+JVS(913)*UV(79)+JVS(914)*UV(80)+JVS(915)*UV(81)+JVS(916)*UV(82)+JVS(917)& + &*UV(83)+JVS(918)*UV(84)+JVS(919)*UV(85)+JVS(920)*UV(86)+JVS(921)*UV(87)+JVS(922)*UV(88)+JVS(924)*UV(90) + JUV(87) = JVS(925)*UV(21)+JVS(926)*UV(22)+JVS(927)*UV(23)+JVS(928)*UV(25)+JVS(929)*UV(29)+JVS(930)*UV(34)+JVS(931)& + &*UV(46)+JVS(932)*UV(48)+JVS(933)*UV(56)+JVS(940)*UV(68)+JVS(941)*UV(69)+JVS(943)*UV(71)+JVS(947)*UV(75)& + &+JVS(948)*UV(76)+JVS(952)*UV(80)+JVS(954)*UV(82)+JVS(955)*UV(83)+JVS(956)*UV(84)+JVS(957)*UV(85)+JVS(959)& + &*UV(87)+JVS(961)*UV(89) + JUV(88) = JVS(963)*UV(19)+JVS(964)*UV(36)+JVS(965)*UV(50)+JVS(974)*UV(82)+JVS(975)*UV(83)+JVS(976)*UV(84)+JVS(977)& + &*UV(85)+JVS(978)*UV(86)+JVS(980)*UV(88)+JVS(982)*UV(90) + JUV(89) = JVS(983)*UV(25)+JVS(984)*UV(44)+JVS(985)*UV(46)+JVS(986)*UV(48)+JVS(987)*UV(58)+JVS(988)*UV(77)+JVS(989)& + &*UV(78)+JVS(991)*UV(80)+JVS(992)*UV(81)+JVS(993)*UV(82)+JVS(994)*UV(83)+JVS(995)*UV(84)+JVS(996)*UV(85)& + &+JVS(997)*UV(86)+JVS(998)*UV(87)+JVS(999)*UV(88)+JVS(1000)*UV(89)+JVS(1001)*UV(90) + JUV(90) = JVS(1002)*UV(21)+JVS(1003)*UV(27)+JVS(1004)*UV(28)+JVS(1005)*UV(34)+JVS(1006)*UV(48)+JVS(1007)*UV(49)& + &+JVS(1008)*UV(51)+JVS(1009)*UV(52)+JVS(1010)*UV(53)+JVS(1011)*UV(54)+JVS(1012)*UV(55)+JVS(1013)*UV(57)& + &+JVS(1014)*UV(59)+JVS(1015)*UV(60)+JVS(1016)*UV(62)+JVS(1017)*UV(63)+JVS(1018)*UV(64)+JVS(1019)*UV(65)& + &+JVS(1020)*UV(66)+JVS(1021)*UV(67)+JVS(1022)*UV(70)+JVS(1023)*UV(71)+JVS(1024)*UV(72)+JVS(1025)*UV(73)& + &+JVS(1026)*UV(74)+JVS(1028)*UV(76)+JVS(1029)*UV(77)+JVS(1030)*UV(78)+JVS(1031)*UV(79)+JVS(1033)*UV(81)& + &+JVS(1035)*UV(83)+JVS(1036)*UV(84)+JVS(1037)*UV(85)+JVS(1038)*UV(86)+JVS(1039)*UV(87)+JVS(1040)*UV(88)& + &+JVS(1041)*UV(89)+JVS(1042)*UV(90) + +END SUBROUTINE Jac_SP_Vec + +! End of Jac_SP_Vec function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! JacTR_SP_Vec - sparse multiplication: sparse Jacobian transposed times vector +! Arguments : +! JVS - sparse Jacobian of variables +! UV - User vector for variables +! JTUV - Jacobian transposed times user vector +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE JacTR_SP_Vec ( JVS, UV, JTUV ) + +! JVS - sparse Jacobian of variables + REAL(kind=dp) :: JVS(LU_NONZERO) +! UV - User vector for variables + REAL(kind=dp) :: UV(NVAR) +! JTUV - Jacobian transposed times user vector + REAL(kind=dp) :: JTUV(NVAR) + + JTUV(1) = JVS(1)*UV(1) + JTUV(2) = JVS(3)*UV(2) + JTUV(3) = JVS(5)*UV(3) + JTUV(4) = JVS(7)*UV(4) + JTUV(5) = JVS(9)*UV(5) + JTUV(6) = JVS(11)*UV(6) + JTUV(7) = JVS(13)*UV(7) + JTUV(8) = JVS(15)*UV(8) + JTUV(9) = JVS(17)*UV(9) + JTUV(10) = JVS(19)*UV(10) + JTUV(11) = JVS(21)*UV(11) + JTUV(12) = JVS(24)*UV(12) + JTUV(13) = JVS(27)*UV(13) + JTUV(14) = JVS(35)*UV(14) + JTUV(15) = JVS(46)*UV(15) + JTUV(16) = JVS(49)*UV(16)+JVS(225)*UV(52)+JVS(235)*UV(53)+JVS(716)*UV(83) + JTUV(17) = JVS(4)*UV(2)+JVS(36)*UV(14)+JVS(51)*UV(17)+JVS(717)*UV(83)+JVS(785)*UV(84) + JTUV(18) = JVS(18)*UV(9)+JVS(37)*UV(14)+JVS(54)*UV(18)+JVS(649)*UV(81)+JVS(668)*UV(82) + JTUV(19) = JVS(57)*UV(19)+JVS(669)*UV(82)+JVS(963)*UV(88) + JTUV(20) = JVS(22)*UV(11)+JVS(60)*UV(20)+JVS(718)*UV(83)+JVS(786)*UV(84) + JTUV(21) = JVS(14)*UV(7)+JVS(38)*UV(14)+JVS(64)*UV(21)+JVS(670)*UV(82)+JVS(884)*UV(86)+JVS(925)*UV(87)+JVS(1002)& + &*UV(90) + JTUV(22) = JVS(67)*UV(22)+JVS(259)*UV(56)+JVS(508)*UV(72)+JVS(719)*UV(83)+JVS(926)*UV(87) + JTUV(23) = JVS(70)*UV(23)+JVS(260)*UV(56)+JVS(531)*UV(74)+JVS(720)*UV(83)+JVS(927)*UV(87) + JTUV(24) = JVS(73)*UV(24)+JVS(671)*UV(82)+JVS(721)*UV(83)+JVS(849)*UV(85) + JTUV(25) = JVS(8)*UV(4)+JVS(39)*UV(14)+JVS(77)*UV(25)+JVS(261)*UV(56)+JVS(672)*UV(82)+JVS(850)*UV(85)+JVS(928)*UV(87)& + &+JVS(983)*UV(89) + JTUV(26) = JVS(80)*UV(26)+JVS(424)*UV(69)+JVS(610)*UV(78)+JVS(722)*UV(83)+JVS(885)*UV(86) + JTUV(27) = JVS(84)*UV(27)+JVS(425)*UV(69)+JVS(723)*UV(83)+JVS(886)*UV(86)+JVS(1003)*UV(90) + JTUV(28) = JVS(88)*UV(28)+JVS(426)*UV(69)+JVS(724)*UV(83)+JVS(787)*UV(84)+JVS(1004)*UV(90) + JTUV(29) = JVS(92)*UV(29)+JVS(673)*UV(82)+JVS(725)*UV(83)+JVS(788)*UV(84)+JVS(929)*UV(87) + JTUV(30) = JVS(96)*UV(30)+JVS(397)*UV(68)+JVS(509)*UV(72)+JVS(726)*UV(83)+JVS(789)*UV(84) + JTUV(31) = JVS(100)*UV(31)+JVS(226)*UV(52)+JVS(398)*UV(68)+JVS(727)*UV(83)+JVS(790)*UV(84) + JTUV(32) = JVS(104)*UV(32)+JVS(196)*UV(49)+JVS(236)*UV(53)+JVS(728)*UV(83)+JVS(791)*UV(84) + JTUV(33) = JVS(108)*UV(33)+JVS(485)*UV(71)+JVS(650)*UV(81)+JVS(729)*UV(83)+JVS(792)*UV(84) + JTUV(34) = JVS(25)*UV(12)+JVS(61)*UV(20)+JVS(112)*UV(34)+JVS(262)*UV(56)+JVS(427)*UV(69)+JVS(730)*UV(83)+JVS(930)& + &*UV(87)+JVS(1005)*UV(90) + JTUV(35) = JVS(115)*UV(35)+JVS(486)*UV(71)+JVS(532)*UV(74)+JVS(731)*UV(83)+JVS(794)*UV(84) + JTUV(36) = JVS(119)*UV(36)+JVS(428)*UV(69)+JVS(732)*UV(83)+JVS(795)*UV(84)+JVS(964)*UV(88) + JTUV(37) = JVS(123)*UV(37)+JVS(429)*UV(69)+JVS(474)*UV(70)+JVS(487)*UV(71)+JVS(733)*UV(83)+JVS(796)*UV(84) + JTUV(38) = JVS(127)*UV(38)+JVS(347)*UV(63)+JVS(399)*UV(68)+JVS(674)*UV(82)+JVS(734)*UV(83)+JVS(797)*UV(84) + JTUV(39) = JVS(131)*UV(39)+JVS(387)*UV(67)+JVS(400)*UV(68)+JVS(675)*UV(82)+JVS(735)*UV(83)+JVS(798)*UV(84) + JTUV(40) = JVS(135)*UV(40)+JVS(167)*UV(47)+JVS(301)*UV(59)+JVS(317)*UV(61)+JVS(430)*UV(69)+JVS(736)*UV(83)+JVS(799)& + &*UV(84) + JTUV(41) = JVS(139)*UV(41)+JVS(168)*UV(47)+JVS(206)*UV(50)+JVS(318)*UV(61)+JVS(377)*UV(66)+JVS(549)*UV(75)+JVS(737)& + &*UV(83)+JVS(800)*UV(84) + JTUV(42) = JVS(143)*UV(42)+JVS(207)*UV(50)+JVS(358)*UV(64)+JVS(401)*UV(68)+JVS(431)*UV(69)+JVS(550)*UV(75)+JVS(738)& + &*UV(83)+JVS(801)*UV(84)+JVS(887)*UV(86) + JTUV(43) = JVS(147)*UV(43)+JVS(366)*UV(65)+JVS(402)*UV(68)+JVS(676)*UV(82)+JVS(739)*UV(83)+JVS(802)*UV(84) + JTUV(44) = JVS(16)*UV(8)+JVS(40)*UV(14)+JVS(153)*UV(44)+JVS(319)*UV(61)+JVS(432)*UV(69)+JVS(611)*UV(78)+JVS(677)& + &*UV(82)+JVS(740)*UV(83)+JVS(803)*UV(84)+JVS(984)*UV(89) + JTUV(45) = JVS(158)*UV(45)+JVS(291)*UV(58)+JVS(433)*UV(69)+JVS(597)*UV(77)+JVS(625)*UV(79)+JVS(636)*UV(80)+JVS(741)& + &*UV(83)+JVS(804)*UV(84) + JTUV(46) = JVS(28)*UV(13)+JVS(47)*UV(15)+JVS(163)*UV(46)+JVS(169)*UV(47)+JVS(190)*UV(48)+JVS(388)*UV(67)+JVS(434)& + &*UV(69)+JVS(598)*UV(77)+JVS(626)*UV(79)+JVS(637)*UV(80)+JVS(742)*UV(83)+JVS(805)*UV(84)+JVS(931)*UV(87)& + &+JVS(985)*UV(89) + JTUV(47) = JVS(29)*UV(13)+JVS(170)*UV(47)+JVS(743)*UV(83)+JVS(806)*UV(84) + JTUV(48) = JVS(171)*UV(47)+JVS(191)*UV(48)+JVS(348)*UV(63)+JVS(435)*UV(69)+JVS(475)*UV(70)+JVS(488)*UV(71)+JVS(744)& + &*UV(83)+JVS(807)*UV(84)+JVS(932)*UV(87)+JVS(986)*UV(89)+JVS(1006)*UV(90) + JTUV(49) = JVS(172)*UV(47)+JVS(197)*UV(49)+JVS(337)*UV(62)+JVS(745)*UV(83)+JVS(888)*UV(86)+JVS(1007)*UV(90) + JTUV(50) = JVS(173)*UV(47)+JVS(208)*UV(50)+JVS(436)*UV(69)+JVS(746)*UV(83)+JVS(809)*UV(84)+JVS(965)*UV(88) + JTUV(51) = JVS(148)*UV(43)+JVS(209)*UV(50)+JVS(220)*UV(51)+JVS(263)*UV(56)+JVS(403)*UV(68)+JVS(437)*UV(69)+JVS(551)& + &*UV(75)+JVS(678)*UV(82)+JVS(810)*UV(84)+JVS(851)*UV(85)+JVS(889)*UV(86)+JVS(1008)*UV(90) + JTUV(52) = JVS(101)*UV(31)+JVS(227)*UV(52)+JVS(404)*UV(68)+JVS(438)*UV(69)+JVS(679)*UV(82)+JVS(811)*UV(84)+JVS(852)& + &*UV(85)+JVS(890)*UV(86)+JVS(1009)*UV(90) + JTUV(53) = JVS(105)*UV(32)+JVS(198)*UV(49)+JVS(237)*UV(53)+JVS(439)*UV(69)+JVS(680)*UV(82)+JVS(812)*UV(84)+JVS(853)& + &*UV(85)+JVS(891)*UV(86)+JVS(1010)*UV(90) + JTUV(54) = JVS(245)*UV(54)+JVS(405)*UV(68)+JVS(440)*UV(69)+JVS(489)*UV(71)+JVS(510)*UV(72)+JVS(519)*UV(73)+JVS(681)& + &*UV(82)+JVS(813)*UV(84)+JVS(854)*UV(85)+JVS(892)*UV(86)+JVS(1011)*UV(90) + JTUV(55) = JVS(149)*UV(43)+JVS(252)*UV(55)+JVS(406)*UV(68)+JVS(441)*UV(69)+JVS(552)*UV(75)+JVS(682)*UV(82)+JVS(814)& + &*UV(84)+JVS(855)*UV(85)+JVS(893)*UV(86)+JVS(1012)*UV(90) + JTUV(56) = JVS(6)*UV(3)+JVS(41)*UV(14)+JVS(264)*UV(56)+JVS(683)*UV(82)+JVS(751)*UV(83)+JVS(933)*UV(87) + JTUV(57) = JVS(159)*UV(45)+JVS(265)*UV(56)+JVS(285)*UV(57)+JVS(292)*UV(58)+JVS(442)*UV(69)+JVS(578)*UV(76)+JVS(684)& + &*UV(82)+JVS(815)*UV(84)+JVS(856)*UV(85)+JVS(894)*UV(86)+JVS(1013)*UV(90) + JTUV(58) = JVS(174)*UV(47)+JVS(210)*UV(50)+JVS(293)*UV(58)+JVS(320)*UV(61)+JVS(378)*UV(66)+JVS(443)*UV(69)+JVS(553)& + &*UV(75)+JVS(612)*UV(78)+JVS(753)*UV(83)+JVS(816)*UV(84)+JVS(987)*UV(89) + JTUV(59) = JVS(136)*UV(40)+JVS(175)*UV(47)+JVS(266)*UV(56)+JVS(302)*UV(59)+JVS(321)*UV(61)+JVS(444)*UV(69)+JVS(554)& + &*UV(75)+JVS(579)*UV(76)+JVS(685)*UV(82)+JVS(817)*UV(84)+JVS(857)*UV(85)+JVS(895)*UV(86)+JVS(1014)*UV(90) + JTUV(60) = JVS(309)*UV(60)+JVS(445)*UV(69)+JVS(490)*UV(71)+JVS(520)*UV(73)+JVS(555)*UV(75)+JVS(580)*UV(76)+JVS(686)& + &*UV(82)+JVS(818)*UV(84)+JVS(858)*UV(85)+JVS(896)*UV(86)+JVS(1015)*UV(90) + JTUV(61) = JVS(322)*UV(61)+JVS(446)*UV(69)+JVS(556)*UV(75)+JVS(755)*UV(83)+JVS(819)*UV(84)+JVS(897)*UV(86) + JTUV(62) = JVS(323)*UV(61)+JVS(339)*UV(62)+JVS(447)*UV(69)+JVS(521)*UV(73)+JVS(557)*UV(75)+JVS(581)*UV(76)+JVS(687)& + &*UV(82)+JVS(820)*UV(84)+JVS(859)*UV(85)+JVS(898)*UV(86)+JVS(1016)*UV(90) + JTUV(63) = JVS(128)*UV(38)+JVS(349)*UV(63)+JVS(407)*UV(68)+JVS(448)*UV(69)+JVS(491)*UV(71)+JVS(688)*UV(82)+JVS(821)& + &*UV(84)+JVS(860)*UV(85)+JVS(899)*UV(86)+JVS(1017)*UV(90) + JTUV(64) = JVS(144)*UV(42)+JVS(211)*UV(50)+JVS(267)*UV(56)+JVS(359)*UV(64)+JVS(449)*UV(69)+JVS(558)*UV(75)+JVS(582)& + &*UV(76)+JVS(689)*UV(82)+JVS(822)*UV(84)+JVS(861)*UV(85)+JVS(900)*UV(86)+JVS(1018)*UV(90) + JTUV(65) = JVS(150)*UV(43)+JVS(212)*UV(50)+JVS(268)*UV(56)+JVS(324)*UV(61)+JVS(369)*UV(65)+JVS(409)*UV(68)+JVS(450)& + &*UV(69)+JVS(690)*UV(82)+JVS(823)*UV(84)+JVS(862)*UV(85)+JVS(901)*UV(86)+JVS(1019)*UV(90) + JTUV(66) = JVS(140)*UV(41)+JVS(176)*UV(47)+JVS(213)*UV(50)+JVS(269)*UV(56)+JVS(325)*UV(61)+JVS(379)*UV(66)+JVS(451)& + &*UV(69)+JVS(560)*UV(75)+JVS(583)*UV(76)+JVS(691)*UV(82)+JVS(824)*UV(84)+JVS(863)*UV(85)+JVS(902)*UV(86)& + &+JVS(1020)*UV(90) + JTUV(67) = JVS(132)*UV(39)+JVS(270)*UV(56)+JVS(389)*UV(67)+JVS(410)*UV(68)+JVS(452)*UV(69)+JVS(600)*UV(77)+JVS(639)& + &*UV(80)+JVS(692)*UV(82)+JVS(825)*UV(84)+JVS(864)*UV(85)+JVS(903)*UV(86)+JVS(1021)*UV(90) + JTUV(68) = JVS(177)*UV(47)+JVS(271)*UV(56)+JVS(411)*UV(68)+JVS(533)*UV(74)+JVS(651)*UV(81)+JVS(762)*UV(83)+JVS(826)& + &*UV(84)+JVS(940)*UV(87) + JTUV(69) = JVS(2)*UV(1)+JVS(42)*UV(14)+JVS(178)*UV(47)+JVS(272)*UV(56)+JVS(453)*UV(69)+JVS(763)*UV(83)+JVS(827)*UV(84)& + &+JVS(941)*UV(87) + JTUV(70) = JVS(124)*UV(37)+JVS(326)*UV(61)+JVS(412)*UV(68)+JVS(454)*UV(69)+JVS(476)*UV(70)+JVS(492)*UV(71)+JVS(695)& + &*UV(82)+JVS(828)*UV(84)+JVS(865)*UV(85)+JVS(904)*UV(86)+JVS(1022)*UV(90) + JTUV(71) = JVS(179)*UV(47)+JVS(273)*UV(56)+JVS(455)*UV(69)+JVS(493)*UV(71)+JVS(765)*UV(83)+JVS(829)*UV(84)+JVS(905)& + &*UV(86)+JVS(943)*UV(87)+JVS(1023)*UV(90) + JTUV(72) = JVS(97)*UV(30)+JVS(199)*UV(49)+JVS(228)*UV(52)+JVS(238)*UV(53)+JVS(413)*UV(68)+JVS(456)*UV(69)+JVS(494)& + &*UV(71)+JVS(511)*UV(72)+JVS(522)*UV(73)+JVS(535)*UV(74)+JVS(584)*UV(76)+JVS(697)*UV(82)+JVS(830)*UV(84)& + &+JVS(866)*UV(85)+JVS(906)*UV(86)+JVS(1024)*UV(90) + JTUV(73) = JVS(20)*UV(10)+JVS(43)*UV(14)+JVS(200)*UV(49)+JVS(229)*UV(52)+JVS(239)*UV(53)+JVS(246)*UV(54)+JVS(414)& + &*UV(68)+JVS(495)*UV(71)+JVS(523)*UV(73)+JVS(536)*UV(74)+JVS(585)*UV(76)+JVS(698)*UV(82)+JVS(767)*UV(83)& + &+JVS(831)*UV(84)+JVS(1025)*UV(90) + JTUV(74) = JVS(116)*UV(35)+JVS(458)*UV(69)+JVS(496)*UV(71)+JVS(537)*UV(74)+JVS(699)*UV(82)+JVS(832)*UV(84)+JVS(868)& + &*UV(85)+JVS(908)*UV(86)+JVS(1026)*UV(90) + JTUV(75) = JVS(180)*UV(47)+JVS(274)*UV(56)+JVS(497)*UV(71)+JVS(564)*UV(75)+JVS(769)*UV(83)+JVS(833)*UV(84)+JVS(909)& + &*UV(86)+JVS(947)*UV(87) + JTUV(76) = JVS(275)*UV(56)+JVS(310)*UV(60)+JVS(538)*UV(74)+JVS(586)*UV(76)+JVS(655)*UV(81)+JVS(770)*UV(83)+JVS(910)& + &*UV(86)+JVS(948)*UV(87)+JVS(1028)*UV(90) + JTUV(77) = JVS(181)*UV(47)+JVS(192)*UV(48)+JVS(360)*UV(64)+JVS(460)*UV(69)+JVS(499)*UV(71)+JVS(566)*UV(75)+JVS(601)& + &*UV(77)+JVS(613)*UV(78)+JVS(771)*UV(83)+JVS(835)*UV(84)+JVS(911)*UV(86)+JVS(988)*UV(89)+JVS(1029)*UV(90) + JTUV(78) = JVS(81)*UV(26)+JVS(154)*UV(44)+JVS(461)*UV(69)+JVS(614)*UV(78)+JVS(703)*UV(82)+JVS(836)*UV(84)+JVS(871)& + &*UV(85)+JVS(912)*UV(86)+JVS(989)*UV(89)+JVS(1030)*UV(90) + JTUV(79) = JVS(160)*UV(45)+JVS(276)*UV(56)+JVS(286)*UV(57)+JVS(294)*UV(58)+JVS(462)*UV(69)+JVS(588)*UV(76)+JVS(602)& + &*UV(77)+JVS(628)*UV(79)+JVS(640)*UV(80)+JVS(704)*UV(82)+JVS(837)*UV(84)+JVS(872)*UV(85)+JVS(913)*UV(86)& + &+JVS(1031)*UV(90) + JTUV(80) = JVS(30)*UV(13)+JVS(182)*UV(47)+JVS(253)*UV(55)+JVS(277)*UV(56)+JVS(303)*UV(59)+JVS(463)*UV(69)+JVS(569)& + &*UV(75)+JVS(616)*UV(78)+JVS(641)*UV(80)+JVS(774)*UV(83)+JVS(838)*UV(84)+JVS(914)*UV(86)+JVS(952)*UV(87)& + &+JVS(991)*UV(89) + JTUV(81) = JVS(55)*UV(18)+JVS(109)*UV(33)+JVS(464)*UV(69)+JVS(541)*UV(74)+JVS(659)*UV(81)+JVS(706)*UV(82)+JVS(839)& + &*UV(84)+JVS(874)*UV(85)+JVS(915)*UV(86)+JVS(992)*UV(89)+JVS(1033)*UV(90) + JTUV(82) = JVS(10)*UV(5)+JVS(44)*UV(14)+JVS(56)*UV(18)+JVS(58)*UV(19)+JVS(65)*UV(21)+JVS(74)*UV(24)+JVS(78)*UV(25)& + &+JVS(93)*UV(29)+JVS(155)*UV(44)+JVS(278)*UV(56)+JVS(617)*UV(78)+JVS(660)*UV(81)+JVS(707)*UV(82)+JVS(776)& + &*UV(83)+JVS(840)*UV(84)+JVS(875)*UV(85)+JVS(916)*UV(86)+JVS(954)*UV(87)+JVS(974)*UV(88)+JVS(993)*UV(89) + JTUV(83) = JVS(23)*UV(11)+JVS(26)*UV(12)+JVS(31)*UV(13)+JVS(48)*UV(15)+JVS(50)*UV(16)+JVS(52)*UV(17)+JVS(62)*UV(20)& + &+JVS(68)*UV(22)+JVS(71)*UV(23)+JVS(75)*UV(24)+JVS(82)*UV(26)+JVS(85)*UV(27)+JVS(89)*UV(28)+JVS(94)*UV(29)& + &+JVS(98)*UV(30)+JVS(102)*UV(31)+JVS(106)*UV(32)+JVS(110)*UV(33)+JVS(113)*UV(34)+JVS(117)*UV(35)+JVS(120)& + &*UV(36)+JVS(125)*UV(37)+JVS(129)*UV(38)+JVS(133)*UV(39)+JVS(137)*UV(40)+JVS(141)*UV(41)+JVS(145)*UV(42)& + &+JVS(151)*UV(43)+JVS(156)*UV(44)+JVS(161)*UV(45)+JVS(164)*UV(46)+JVS(183)*UV(47)+JVS(193)*UV(48)+JVS(201)& + &*UV(49)+JVS(214)*UV(50)+JVS(230)*UV(52)+JVS(240)*UV(53)+JVS(247)*UV(54)+JVS(279)*UV(56)+JVS(295)*UV(58)& + &+JVS(304)*UV(59)+JVS(311)*UV(60)+JVS(331)*UV(61)+JVS(342)*UV(62)+JVS(351)*UV(63)+JVS(361)*UV(64)+JVS(371)& + &*UV(65)+JVS(381)*UV(66)+JVS(390)*UV(67)+JVS(417)*UV(68)+JVS(466)*UV(69)+JVS(478)*UV(70)+JVS(501)*UV(71)& + &+JVS(513)*UV(72)+JVS(525)*UV(73)+JVS(542)*UV(74)+JVS(571)*UV(75)+JVS(590)*UV(76)+JVS(603)*UV(77)+JVS(618)& + &*UV(78)+JVS(629)*UV(79)+JVS(642)*UV(80)+JVS(661)*UV(81)+JVS(708)*UV(82)+JVS(777)*UV(83)+JVS(841)*UV(84)& + &+JVS(876)*UV(85)+JVS(917)*UV(86)+JVS(955)*UV(87)+JVS(975)*UV(88)+JVS(994)*UV(89)+JVS(1035)*UV(90) + JTUV(84) = JVS(53)*UV(17)+JVS(83)*UV(26)+JVS(86)*UV(27)+JVS(90)*UV(28)+JVS(95)*UV(29)+JVS(99)*UV(30)+JVS(103)*UV(31)& + &+JVS(107)*UV(32)+JVS(111)*UV(33)+JVS(118)*UV(35)+JVS(121)*UV(36)+JVS(126)*UV(37)+JVS(130)*UV(38)+JVS(134)& + &*UV(39)+JVS(138)*UV(40)+JVS(142)*UV(41)+JVS(146)*UV(42)+JVS(152)*UV(43)+JVS(162)*UV(45)+JVS(221)*UV(51)& + &+JVS(231)*UV(52)+JVS(241)*UV(53)+JVS(248)*UV(54)+JVS(254)*UV(55)+JVS(287)*UV(57)+JVS(305)*UV(59)+JVS(312)& + &*UV(60)+JVS(343)*UV(62)+JVS(352)*UV(63)+JVS(362)*UV(64)+JVS(372)*UV(65)+JVS(382)*UV(66)+JVS(391)*UV(67)& + &+JVS(467)*UV(69)+JVS(479)*UV(70)+JVS(514)*UV(72)+JVS(526)*UV(73)+JVS(543)*UV(74)+JVS(572)*UV(75)+JVS(619)& + &*UV(78)+JVS(630)*UV(79)+JVS(662)*UV(81)+JVS(709)*UV(82)+JVS(778)*UV(83)+JVS(842)*UV(84)+JVS(877)*UV(85)& + &+JVS(918)*UV(86)+JVS(956)*UV(87)+JVS(976)*UV(88)+JVS(995)*UV(89)+JVS(1036)*UV(90) + JTUV(85) = JVS(32)*UV(13)+JVS(76)*UV(24)+JVS(185)*UV(47)+JVS(203)*UV(49)+JVS(216)*UV(50)+JVS(222)*UV(51)+JVS(232)& + &*UV(52)+JVS(242)*UV(53)+JVS(249)*UV(54)+JVS(255)*UV(55)+JVS(281)*UV(56)+JVS(288)*UV(57)+JVS(297)*UV(58)& + &+JVS(306)*UV(59)+JVS(313)*UV(60)+JVS(333)*UV(61)+JVS(344)*UV(62)+JVS(353)*UV(63)+JVS(363)*UV(64)+JVS(373)& + &*UV(65)+JVS(383)*UV(66)+JVS(392)*UV(67)+JVS(419)*UV(68)+JVS(468)*UV(69)+JVS(480)*UV(70)+JVS(503)*UV(71)& + &+JVS(515)*UV(72)+JVS(527)*UV(73)+JVS(544)*UV(74)+JVS(573)*UV(75)+JVS(592)*UV(76)+JVS(605)*UV(77)+JVS(620)& + &*UV(78)+JVS(631)*UV(79)+JVS(644)*UV(80)+JVS(663)*UV(81)+JVS(710)*UV(82)+JVS(779)*UV(83)+JVS(843)*UV(84)& + &+JVS(878)*UV(85)+JVS(919)*UV(86)+JVS(957)*UV(87)+JVS(977)*UV(88)+JVS(996)*UV(89)+JVS(1037)*UV(90) + JTUV(86) = JVS(33)*UV(13)+JVS(66)*UV(21)+JVS(87)*UV(27)+JVS(186)*UV(47)+JVS(204)*UV(49)+JVS(217)*UV(50)+JVS(223)& + &*UV(51)+JVS(233)*UV(52)+JVS(243)*UV(53)+JVS(250)*UV(54)+JVS(256)*UV(55)+JVS(282)*UV(56)+JVS(289)*UV(57)& + &+JVS(298)*UV(58)+JVS(307)*UV(59)+JVS(314)*UV(60)+JVS(334)*UV(61)+JVS(345)*UV(62)+JVS(354)*UV(63)+JVS(364)& + &*UV(64)+JVS(374)*UV(65)+JVS(384)*UV(66)+JVS(393)*UV(67)+JVS(420)*UV(68)+JVS(469)*UV(69)+JVS(481)*UV(70)& + &+JVS(504)*UV(71)+JVS(516)*UV(72)+JVS(545)*UV(74)+JVS(574)*UV(75)+JVS(593)*UV(76)+JVS(606)*UV(77)+JVS(621)& + &*UV(78)+JVS(632)*UV(79)+JVS(645)*UV(80)+JVS(664)*UV(81)+JVS(711)*UV(82)+JVS(780)*UV(83)+JVS(844)*UV(84)& + &+JVS(879)*UV(85)+JVS(920)*UV(86)+JVS(978)*UV(88)+JVS(997)*UV(89)+JVS(1038)*UV(90) + JTUV(87) = JVS(63)*UV(20)+JVS(69)*UV(22)+JVS(72)*UV(23)+JVS(79)*UV(25)+JVS(114)*UV(34)+JVS(165)*UV(46)+JVS(187)*UV(47)& + &+JVS(194)*UV(48)+JVS(257)*UV(55)+JVS(283)*UV(56)+JVS(315)*UV(60)+JVS(355)*UV(63)+JVS(394)*UV(67)+JVS(421)& + &*UV(68)+JVS(470)*UV(69)+JVS(505)*UV(71)+JVS(517)*UV(72)+JVS(546)*UV(74)+JVS(575)*UV(75)+JVS(594)*UV(76)& + &+JVS(622)*UV(78)+JVS(646)*UV(80)+JVS(665)*UV(81)+JVS(712)*UV(82)+JVS(781)*UV(83)+JVS(845)*UV(84)+JVS(880)& + &*UV(85)+JVS(921)*UV(86)+JVS(959)*UV(87)+JVS(998)*UV(89)+JVS(1039)*UV(90) + JTUV(88) = JVS(59)*UV(19)+JVS(122)*UV(36)+JVS(471)*UV(69)+JVS(713)*UV(82)+JVS(846)*UV(84)+JVS(881)*UV(85)+JVS(922)& + &*UV(86)+JVS(980)*UV(88)+JVS(999)*UV(89)+JVS(1040)*UV(90) + JTUV(89) = JVS(12)*UV(6)+JVS(34)*UV(13)+JVS(45)*UV(14)+JVS(157)*UV(44)+JVS(166)*UV(46)+JVS(188)*UV(47)+JVS(195)*UV(48)& + &+JVS(218)*UV(50)+JVS(299)*UV(58)+JVS(335)*UV(61)+JVS(472)*UV(69)+JVS(506)*UV(71)+JVS(576)*UV(75)+JVS(608)& + &*UV(77)+JVS(647)*UV(80)+JVS(714)*UV(82)+JVS(783)*UV(83)+JVS(847)*UV(84)+JVS(882)*UV(85)+JVS(961)*UV(87)& + &+JVS(1000)*UV(89)+JVS(1041)*UV(90) + JTUV(90) = JVS(91)*UV(28)+JVS(189)*UV(47)+JVS(205)*UV(49)+JVS(219)*UV(50)+JVS(224)*UV(51)+JVS(234)*UV(52)+JVS(244)& + &*UV(53)+JVS(251)*UV(54)+JVS(258)*UV(55)+JVS(284)*UV(56)+JVS(290)*UV(57)+JVS(300)*UV(58)+JVS(308)*UV(59)& + &+JVS(316)*UV(60)+JVS(336)*UV(61)+JVS(346)*UV(62)+JVS(357)*UV(63)+JVS(365)*UV(64)+JVS(376)*UV(65)+JVS(386)& + &*UV(66)+JVS(396)*UV(67)+JVS(423)*UV(68)+JVS(473)*UV(69)+JVS(484)*UV(70)+JVS(507)*UV(71)+JVS(518)*UV(72)& + &+JVS(548)*UV(74)+JVS(577)*UV(75)+JVS(596)*UV(76)+JVS(609)*UV(77)+JVS(624)*UV(78)+JVS(635)*UV(79)+JVS(648)& + &*UV(80)+JVS(667)*UV(81)+JVS(715)*UV(82)+JVS(848)*UV(84)+JVS(883)*UV(85)+JVS(924)*UV(86)+JVS(982)*UV(88)& + &+JVS(1001)*UV(89)+JVS(1042)*UV(90) + +END SUBROUTINE JacTR_SP_Vec + +! End of JacTR_SP_Vec function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +END MODULE gckpp_adj_Jacobian + diff --git a/code/adjoint/gckpp_adj_JacobianSP.f90 b/code/adjoint/gckpp_adj_JacobianSP.f90 new file mode 100644 index 0000000..55e7735 --- /dev/null +++ b/code/adjoint/gckpp_adj_JacobianSP.f90 @@ -0,0 +1,242 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Sparse Jacobian Data Structures File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_JacobianSP.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_JacobianSP + + PUBLIC + SAVE + + +! Sparse Jacobian Data + + + INTEGER, PARAMETER, DIMENSION(360) :: LU_IROW_0 = (/ & + 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, & + 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 11, 12, & + 12, 12, 13, 13, 13, 13, 13, 13, 13, 13, 14, 14, & + 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, & + 16, 16, 17, 17, 17, 18, 18, 18, 19, 19, 19, 20, & + 20, 20, 20, 21, 21, 21, 22, 22, 22, 23, 23, 23, & + 24, 24, 24, 24, 25, 25, 25, 26, 26, 26, 26, 27, & + 27, 27, 27, 28, 28, 28, 28, 29, 29, 29, 29, 30, & + 30, 30, 30, 31, 31, 31, 31, 32, 32, 32, 32, 33, & + 33, 33, 33, 34, 34, 34, 35, 35, 35, 35, 36, 36, & + 36, 36, 37, 37, 37, 37, 38, 38, 38, 38, 39, 39, & + 39, 39, 40, 40, 40, 40, 41, 41, 41, 41, 42, 42, & + 42, 42, 43, 43, 43, 43, 43, 43, 44, 44, 44, 44, & + 44, 45, 45, 45, 45, 45, 46, 46, 46, 46, 47, 47, & + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, & + 47, 47, 47, 47, 47, 47, 47, 47, 47, 48, 48, 48, & + 48, 48, 48, 49, 49, 49, 49, 49, 49, 49, 49, 49, & + 49, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, & + 50, 50, 50, 51, 51, 51, 51, 51, 52, 52, 52, 52, & + 52, 52, 52, 52, 52, 52, 53, 53, 53, 53, 53, 53, & + 53, 53, 53, 53, 54, 54, 54, 54, 54, 54, 54, 55, & + 55, 55, 55, 55, 55, 55, 56, 56, 56, 56, 56, 56, & + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, & + 56, 56, 56, 56, 56, 56, 56, 56, 57, 57, 57, 57, & + 57, 57, 58, 58, 58, 58, 58, 58, 58, 58, 58, 58, & + 59, 59, 59, 59, 59, 59, 59, 59, 60, 60, 60, 60, & + 60, 60, 60, 60, 61, 61, 61, 61, 61, 61, 61, 61, & + 61, 61, 61, 61, 61, 61, 61, 61, 61, 61, 61, 61, & + 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, 63, 63, & + 63, 63, 63, 63, 63, 63, 63, 63, 63, 64, 64, 64 /) + INTEGER, PARAMETER, DIMENSION(360) :: LU_IROW_1 = (/ & + 64, 64, 64, 64, 64, 65, 65, 65, 65, 65, 65, 65, & + 65, 65, 65, 65, 66, 66, 66, 66, 66, 66, 66, 66, & + 66, 66, 67, 67, 67, 67, 67, 67, 67, 67, 67, 67, & + 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, & + 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, & + 68, 68, 68, 69, 69, 69, 69, 69, 69, 69, 69, 69, & + 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, & + 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, & + 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, & + 69, 69, 69, 69, 69, 70, 70, 70, 70, 70, 70, 70, & + 70, 70, 70, 70, 71, 71, 71, 71, 71, 71, 71, 71, & + 71, 71, 71, 71, 71, 71, 71, 71, 71, 71, 71, 71, & + 71, 71, 71, 72, 72, 72, 72, 72, 72, 72, 72, 72, & + 72, 72, 73, 73, 73, 73, 73, 73, 73, 73, 73, 73, & + 73, 73, 74, 74, 74, 74, 74, 74, 74, 74, 74, 74, & + 74, 74, 74, 74, 74, 74, 74, 74, 75, 75, 75, 75, & + 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, & + 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, & + 75, 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, & + 76, 76, 76, 76, 76, 76, 76, 76, 77, 77, 77, 77, & + 77, 77, 77, 77, 77, 77, 77, 77, 77, 78, 78, 78, & + 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, & + 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 80, & + 80, 80, 80, 80, 80, 80, 80, 80, 80, 80, 80, 80, & + 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, & + 81, 81, 81, 81, 81, 81, 81, 82, 82, 82, 82, 82, & + 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, & + 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, & + 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, 82, & + 82, 82, 82, 82, 82, 82, 82, 83, 83, 83, 83, 83 /) + INTEGER, PARAMETER, DIMENSION(322) :: LU_IROW_2 = (/ & + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, 83, & + 83, 83, 83, 83, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & + 84, 84, 84, 84, 84, 84, 84, 84, 85, 85, 85, 85, & + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, & + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, & + 85, 85, 85, 85, 85, 85, 85, 86, 86, 86, 86, 86, & + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, & + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, & + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, & + 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, & + 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, & + 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, & + 87, 87, 88, 88, 88, 88, 88, 88, 88, 88, 88, 88, & + 88, 88, 88, 88, 88, 88, 88, 88, 88, 88, 89, 89, & + 89, 89, 89, 89, 89, 89, 89, 89, 89, 89, 89, 89, & + 89, 89, 89, 89, 89, 90, 90, 90, 90, 90, 90, 90, & + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, & + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, & + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90 /) + INTEGER, PARAMETER, DIMENSION(1042) :: LU_IROW = (/& + LU_IROW_0, LU_IROW_1, LU_IROW_2 /) + + INTEGER, PARAMETER, DIMENSION(360) :: LU_ICOL_0 = (/ & + 1, 69, 2, 17, 3, 56, 4, 25, 5, 82, 6, 89, & + 7, 21, 8, 44, 9, 18, 10, 73, 11, 20, 83, 12, & + 34, 83, 13, 46, 47, 80, 83, 85, 86, 89, 14, 17, & + 18, 21, 25, 44, 56, 69, 73, 82, 89, 15, 46, 83, & + 16, 83, 17, 83, 84, 18, 81, 82, 19, 82, 88, 20, & + 34, 83, 87, 21, 82, 86, 22, 83, 87, 23, 83, 87, & + 24, 82, 83, 85, 25, 82, 87, 26, 78, 83, 84, 27, & + 83, 84, 86, 28, 83, 84, 90, 29, 82, 83, 84, 30, & + 72, 83, 84, 31, 52, 83, 84, 32, 53, 83, 84, 33, & + 81, 83, 84, 34, 83, 87, 35, 74, 83, 84, 36, 83, & + 84, 88, 37, 70, 83, 84, 38, 63, 83, 84, 39, 67, & + 83, 84, 40, 59, 83, 84, 41, 66, 83, 84, 42, 64, & + 83, 84, 43, 51, 55, 65, 83, 84, 44, 78, 82, 83, & + 89, 45, 57, 79, 83, 84, 46, 83, 87, 89, 40, 41, & + 46, 47, 48, 49, 50, 58, 59, 66, 68, 69, 71, 75, & + 77, 80, 83, 84, 85, 86, 87, 89, 90, 46, 48, 77, & + 83, 87, 89, 32, 49, 53, 72, 73, 83, 84, 85, 86, & + 90, 41, 42, 50, 51, 58, 64, 65, 66, 83, 84, 85, & + 86, 89, 90, 51, 84, 85, 86, 90, 16, 31, 52, 72, & + 73, 83, 84, 85, 86, 90, 16, 32, 53, 72, 73, 83, & + 84, 85, 86, 90, 54, 73, 83, 84, 85, 86, 90, 55, & + 80, 84, 85, 86, 87, 90, 22, 23, 25, 34, 51, 56, & + 57, 59, 64, 65, 66, 67, 68, 69, 71, 75, 76, 79, & + 80, 82, 83, 84, 85, 86, 87, 90, 57, 79, 84, 85, & + 86, 90, 45, 57, 58, 79, 83, 84, 85, 86, 89, 90, & + 40, 59, 80, 83, 84, 85, 86, 90, 60, 76, 83, 84, & + 85, 86, 87, 90, 40, 41, 44, 58, 59, 61, 62, 65, & + 66, 70, 78, 79, 80, 82, 83, 84, 85, 86, 89, 90, & + 49, 53, 62, 72, 73, 83, 84, 85, 86, 90, 38, 48, & + 63, 77, 83, 84, 85, 86, 87, 89, 90, 42, 64, 77 /) + INTEGER, PARAMETER, DIMENSION(360) :: LU_ICOL_1 = (/ & + 83, 84, 85, 86, 90, 43, 51, 55, 65, 80, 83, 84, & + 85, 86, 87, 90, 41, 58, 66, 79, 83, 84, 85, 86, & + 89, 90, 39, 46, 67, 83, 84, 85, 86, 87, 89, 90, & + 30, 31, 38, 39, 42, 43, 51, 52, 54, 55, 63, 64, & + 65, 67, 68, 70, 72, 73, 77, 80, 83, 84, 85, 86, & + 87, 89, 90, 26, 27, 28, 34, 36, 37, 40, 42, 44, & + 45, 46, 48, 50, 51, 52, 53, 54, 55, 57, 58, 59, & + 60, 61, 62, 63, 64, 65, 66, 67, 69, 70, 71, 72, & + 73, 74, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, & + 86, 87, 88, 89, 90, 37, 48, 70, 77, 83, 84, 85, & + 86, 87, 89, 90, 33, 35, 37, 48, 54, 60, 63, 70, & + 71, 72, 73, 74, 75, 76, 77, 81, 83, 84, 85, 86, & + 87, 89, 90, 22, 30, 54, 72, 73, 83, 84, 85, 86, & + 87, 90, 54, 60, 62, 72, 73, 76, 83, 84, 85, 86, & + 87, 90, 23, 35, 68, 70, 72, 73, 74, 76, 77, 80, & + 81, 83, 84, 85, 86, 87, 89, 90, 41, 42, 51, 55, & + 58, 59, 60, 61, 62, 64, 65, 66, 70, 72, 73, 75, & + 76, 77, 78, 79, 80, 82, 83, 84, 85, 86, 87, 89, & + 90, 57, 59, 60, 62, 64, 66, 72, 73, 76, 77, 79, & + 80, 83, 84, 85, 86, 87, 89, 90, 45, 46, 57, 67, & + 77, 79, 83, 84, 85, 86, 87, 89, 90, 26, 44, 58, & + 77, 78, 79, 80, 82, 83, 84, 85, 86, 87, 89, 90, & + 45, 46, 57, 79, 83, 84, 85, 86, 87, 89, 90, 45, & + 46, 57, 67, 79, 80, 83, 84, 85, 86, 87, 89, 90, & + 18, 33, 68, 70, 72, 73, 76, 77, 79, 80, 81, 82, & + 83, 84, 85, 86, 87, 89, 90, 18, 19, 21, 24, 25, & + 29, 38, 39, 43, 44, 51, 52, 53, 54, 55, 56, 57, & + 59, 60, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, & + 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, & + 84, 85, 86, 87, 88, 89, 90, 16, 17, 20, 22, 23 /) + INTEGER, PARAMETER, DIMENSION(322) :: LU_ICOL_2 = (/ & + 24, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, & + 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, & + 49, 50, 51, 52, 53, 55, 56, 57, 58, 59, 61, 62, & + 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, & + 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, & + 87, 88, 89, 90, 17, 20, 28, 29, 30, 31, 32, 33, & + 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, & + 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 57, 58, & + 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, & + 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, & + 83, 84, 85, 86, 87, 88, 89, 90, 24, 25, 51, 52, & + 53, 54, 55, 57, 59, 60, 62, 63, 64, 65, 66, 67, & + 70, 72, 73, 74, 76, 77, 78, 79, 80, 81, 82, 83, & + 84, 85, 86, 87, 88, 89, 90, 21, 26, 27, 42, 49, & + 51, 52, 53, 54, 55, 57, 59, 60, 61, 62, 63, 64, & + 65, 66, 67, 70, 71, 72, 73, 74, 75, 76, 77, 78, & + 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, & + 21, 22, 23, 25, 29, 34, 46, 48, 56, 57, 59, 64, & + 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, & + 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, & + 89, 90, 19, 36, 50, 51, 58, 64, 65, 66, 77, 79, & + 80, 82, 83, 84, 85, 86, 87, 88, 89, 90, 25, 44, & + 46, 48, 58, 77, 78, 79, 80, 81, 82, 83, 84, 85, & + 86, 87, 88, 89, 90, 21, 27, 28, 34, 48, 49, 51, & + 52, 53, 54, 55, 57, 59, 60, 62, 63, 64, 65, 66, & + 67, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, & + 81, 82, 83, 84, 85, 86, 87, 88, 89, 90 /) + INTEGER, PARAMETER, DIMENSION(1042) :: LU_ICOL = (/& + LU_ICOL_0, LU_ICOL_1, LU_ICOL_2 /) + + INTEGER, PARAMETER, DIMENSION(91) :: LU_CROW = (/ & + 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 24, & + 27, 35, 46, 49, 51, 54, 57, 60, 64, 67, 70, 73, & + 77, 80, 84, 88, 92, 96,100,104,108,112,115,119, & + 123,127,131,135,139,143,147,153,158,163,167,190, & + 196,206,220,225,235,245,252,259,285,291,301,309, & + 317,337,347,358,366,377,387,397,424,474,485,508, & + 519,531,549,578,597,610,625,636,649,668,716,785, & + 849,884,925,963,983,1002,1043 /) + + INTEGER, PARAMETER, DIMENSION(91) :: LU_DIAG = (/ & + 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 24, & + 27, 35, 46, 49, 51, 54, 57, 60, 64, 67, 70, 73, & + 77, 80, 84, 88, 92, 96,100,104,108,112,115,119, & + 123,127,131,135,139,143,147,153,158,163,170,191, & + 197,208,220,227,237,245,252,264,285,293,302,309, & + 322,339,349,359,369,379,389,411,453,476,493,511, & + 523,537,564,586,601,614,628,641,659,707,777,842, & + 878,920,959,980,1000,1042,1043 /) + + +END MODULE gckpp_adj_JacobianSP + diff --git a/code/adjoint/gckpp_adj_LinearAlgebra.f90 b/code/adjoint/gckpp_adj_LinearAlgebra.f90 new file mode 100644 index 0000000..db9306d --- /dev/null +++ b/code/adjoint/gckpp_adj_LinearAlgebra.f90 @@ -0,0 +1,1630 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Linear Algebra Data and Routines File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_LinearAlgebra.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_LinearAlgebra + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + IMPLICIT NONE + +CONTAINS + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! SPARSE_UTIL - SPARSE utility functions +! Arguments : +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppDecomp( JVS, IER ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Sparse LU factorization +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + INTEGER :: IER + REAL(kind=dp) :: JVS(LU_NONZERO), W(NVAR), a + INTEGER :: k, kk, j, jj + + a = 0. ! mz_rs_20050606 + IER = 0 + DO k=1,NVAR + ! mz_rs_20050606: don't check if real value == 0 + ! IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN + IF ( ABS(JVS(LU_DIAG(k))) < TINY(a) ) THEN + IER = k + RETURN + END IF + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + W( LU_ICOL(kk) ) = JVS(kk) + END DO + DO kk = LU_CROW(k), LU_DIAG(k)-1 + j = LU_ICOL(kk) + a = -W(j) / JVS( LU_DIAG(j) ) + W(j) = -a + DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1 + W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj) + END DO + END DO + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + JVS(kk) = W( LU_ICOL(kk) ) + END DO + END DO + +END SUBROUTINE KppDecomp + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppDecompCmplx( JVS, IER ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Sparse LU factorization, complex +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + INTEGER :: IER + DOUBLE COMPLEX :: JVS(LU_NONZERO), W(NVAR), a + REAL(kind=dp) :: b = 0.0 + INTEGER :: k, kk, j, jj + + IER = 0 + DO k=1,NVAR + IF ( ABS(JVS(LU_DIAG(k))) < TINY(b) ) THEN + IER = k + RETURN + END IF + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + W( LU_ICOL(kk) ) = JVS(kk) + END DO + DO kk = LU_CROW(k), LU_DIAG(k)-1 + j = LU_ICOL(kk) + a = -W(j) / JVS( LU_DIAG(j) ) + W(j) = -a + DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1 + W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj) + END DO + END DO + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + JVS(kk) = W( LU_ICOL(kk) ) + END DO + END DO + +END SUBROUTINE KppDecompCmplx + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppDecompCmplxR( JVSR, JVSI, IER ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Sparse LU factorization, complex +! (Real and Imaginary parts are used instead of complex data type) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + INTEGER :: IER + REAL(kind=dp) :: JVSR(LU_NONZERO), JVSI(LU_NONZERO) + REAL(kind=dp) :: WR(NVAR), WI(NVAR), ar, ai, den + INTEGER :: k, kk, j, jj + + IER = 0 + ar = 0.0 + DO k=1,NVAR + IF ( ( ABS(JVSR(LU_DIAG(k))) < TINY(ar) ) .AND. & + ( ABS(JVSI(LU_DIAG(k))) < TINY(ar) ) ) THEN + IER = k + RETURN + END IF + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + WR( LU_ICOL(kk) ) = JVSR(kk) + WI( LU_ICOL(kk) ) = JVSI(kk) + END DO + DO kk = LU_CROW(k), LU_DIAG(k)-1 + j = LU_ICOL(kk) + den = JVSR(LU_DIAG(j))**2 + JVSI(LU_DIAG(j))**2 + ar = -(WR(j)*JVSR(LU_DIAG(j)) + WI(j)*JVSI(LU_DIAG(j)))/den + ai = -(WI(j)*JVSR(LU_DIAG(j)) - WR(j)*JVSI(LU_DIAG(j)))/den + WR(j) = -ar + WI(j) = -ai + DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1 + WR( LU_ICOL(jj) ) = WR( LU_ICOL(jj) ) + ar*JVSR(jj) - ai*JVSI(jj) + WI( LU_ICOL(jj) ) = WI( LU_ICOL(jj) ) + ar*JVSI(jj) + ai*JVSR(jj) + END DO + END DO + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + JVSR(kk) = WR( LU_ICOL(kk) ) + JVSI(kk) = WI( LU_ICOL(kk) ) + END DO + END DO + +END SUBROUTINE KppDecompCmplxR + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppSolveIndirect( JVS, X ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Sparse solve subroutine using indirect addressing +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + INTEGER :: i, j + REAL(kind=dp) :: JVS(LU_NONZERO), X(NVAR), sum + + DO i=1,NVAR + DO j = LU_CROW(i), LU_DIAG(i)-1 + X(i) = X(i) - JVS(j)*X(LU_ICOL(j)); + END DO + END DO + + DO i=NVAR,1,-1 + sum = X(i); + DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1 + sum = sum - JVS(j)*X(LU_ICOL(j)); + END DO + X(i) = sum/JVS(LU_DIAG(i)); + END DO + +END SUBROUTINE KppSolveIndirect + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppSolveTRIndirect( JVS, X ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Complex sparse solve transpose subroutine using indirect addressing +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + INTEGER :: i, j + REAL(kind=dp) :: JVS(LU_NONZERO), X(NVAR) + + DO i=1,NVAR + X(i) = X(i)/JVS(LU_DIAG(i)) + ! subtract all nonzero elements in row i of JVS from X + DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1 + X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i) + END DO + END DO + + DO i=NVAR, 1, -1 + ! subtract all nonzero elements in row i of JVS from X + DO j=LU_CROW(i),LU_DIAG(i)-1 + X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i) + END DO + END DO + +END SUBROUTINE KppSolveTRIndirect + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppSolveCmplx( JVS, X ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Complex sparse solve subroutine using indirect addressing +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + INTEGER :: i, j + DOUBLE COMPLEX :: JVS(LU_NONZERO), X(NVAR), sum + + DO i=1,NVAR + DO j = LU_CROW(i), LU_DIAG(i)-1 + X(i) = X(i) - JVS(j)*X(LU_ICOL(j)); + END DO + END DO + + DO i=NVAR,1,-1 + sum = X(i); + DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1 + sum = sum - JVS(j)*X(LU_ICOL(j)); + END DO + X(i) = sum/JVS(LU_DIAG(i)); + END DO + +END SUBROUTINE KppSolveCmplx + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppSolveCmplxR( JVSR, JVSI, XR, XI ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Complex sparse solve subroutine using indirect addressing +! (Real and Imaginary parts are used instead of complex data type) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + INTEGER :: i, j + REAL(kind=dp) :: JVSR(LU_NONZERO), JVSI(LU_NONZERO), XR(NVAR), XI(NVAR), sumr, sumi, den + + DO i=1,NVAR + DO j = LU_CROW(i), LU_DIAG(i)-1 + XR(i) = XR(i) - (JVSR(j)*XR(LU_ICOL(j)) - JVSI(j)*XI(LU_ICOL(j))) + XI(i) = XI(i) - (JVSR(j)*XI(LU_ICOL(j)) + JVSI(j)*XR(LU_ICOL(j))) + END DO + END DO + + DO i=NVAR,1,-1 + sumr = XR(i); sumi = XI(i) + DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1 + sumr = sumr - (JVSR(j)*XR(LU_ICOL(j)) - JVSI(j)*XI(LU_ICOL(j))) + sumi = sumi - (JVSR(j)*XI(LU_ICOL(j)) + JVSI(j)*XR(LU_ICOL(j))) + END DO + den = JVSR(LU_DIAG(i))**2 + JVSI(LU_DIAG(i))**2 + XR(i) = (sumr*JVSR(LU_DIAG(i)) + sumi*JVSI(LU_DIAG(i)))/den + XI(i) = (sumi*JVSR(LU_DIAG(i)) - sumr*JVSI(LU_DIAG(i)))/den + END DO + +END SUBROUTINE KppSolveCmplxR + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppSolveTRCmplx( JVS, X ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Complex sparse solve transpose subroutine using indirect addressing +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + INTEGER :: i, j + DOUBLE COMPLEX :: JVS(LU_NONZERO), X(NVAR) + + DO i=1,NVAR + X(i) = X(i)/JVS(LU_DIAG(i)) + ! subtract all nonzero elements in row i of JVS from X + DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1 + X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i) + END DO + END DO + + DO i=NVAR, 1, -1 + ! subtract all nonzero elements in row i of JVS from X + DO j=LU_CROW(i),LU_DIAG(i)-1 + X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i) + END DO + END DO + +END SUBROUTINE KppSolveTRCmplx + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppSolveTRCmplxR( JVSR, JVSI, XR, XI ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Complex sparse solve transpose subroutine using indirect addressing +! (Real and Imaginary parts are used instead of complex data type) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE gckpp_adj_Parameters + USE gckpp_adj_JacobianSP + + INTEGER :: i, j + REAL(kind=dp) :: JVSR(LU_NONZERO), JVSI(LU_NONZERO), XR(NVAR), XI(NVAR), den + + DO i=1,NVAR + den = JVSR(LU_DIAG(i))**2 + JVSI(LU_DIAG(i))**2 + XR(i) = (XR(i)*JVSR(LU_DIAG(i)) + XI(i)*JVSI(LU_DIAG(i)))/den + XI(i) = (XI(i)*JVSR(LU_DIAG(i)) - XR(i)*JVSI(LU_DIAG(i)))/den + ! subtract all nonzero elements in row i of JVS from X + DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1 + XR(LU_ICOL(j)) = XR(LU_ICOL(j))-(JVSR(j)*XR(i) - JVSI(j)*XI(i)) + XI(LU_ICOL(j)) = XI(LU_ICOL(j))-(JVSI(j)*XR(i) + JVSR(j)*XI(i)) + END DO + END DO + + DO i=NVAR, 1, -1 + ! subtract all nonzero elements in row i of JVS from X + DO j=LU_CROW(i),LU_DIAG(i)-1 + XR(LU_ICOL(j)) = XR(LU_ICOL(j))-(JVSR(j)*XR(i) - JVSI(j)*XI(i)) + XI(LU_ICOL(j)) = XI(LU_ICOL(j))-(JVSI(j)*XR(i) + JVSR(j)*XI(i)) + END DO + END DO + +END SUBROUTINE KppSolveTRCmplxR + + +! +! Next few commented subroutines perform sparse big linear algebra +! +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!SUBROUTINE KppDecompBig( JVS, IP, IER ) +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!! Sparse LU factorization +!! for the Runge Kutta (3n)x(3n) linear system +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! USE gckpp_adj_Parameters +! USE gckpp_adj_JacobianSP +! +! INTEGER :: IP3(3), IER, IP(3,NVAR) +! REAL(kind=dp) :: JVS(3,3,LU_NONZERO), W(3,3,NVAR), a(3,3), E(3,3) +! INTEGER :: k, kk, j, jj +! +! a = 0.0d0 +! IER = 0 +! DO k=1,NVAR +! DO kk = LU_CROW(k), LU_CROW(k+1)-1 +! W( 1:3,1:3,LU_ICOL(kk) ) = JVS(1:3,1:3,kk) +! END DO +! DO kk = LU_CROW(k), LU_DIAG(k)-1 +! j = LU_ICOL(kk) +! E(1:3,1:3) = JVS( 1:3,1:3,LU_DIAG(j) ) +! ! CALL DGETRF(3,3,E,3,IP3,IER) +! CALL FAC3(E,IP3,IER) +! IF ( IER /= 0 ) RETURN +! ! a = W(j) / JVS( LU_DIAG(j) ) +! a(1:3,1:3) = W( 1:3,1:3,j ) +! ! CALL DGETRS ('N',3,3,E,3,IP3,a,3,IER) +! CALL SOL3('N',E,IP3,a(1,1)) +! CALL SOL3('N',E,IP3,a(1,2)) +! CALL SOL3('N',E,IP3,a(1,3)) +! W(1:3,1:3,j) = a(1:3,1:3) +! DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1 +! W( 1:3,1:3,LU_ICOL(jj) ) = W( 1:3,1:3,LU_ICOL(jj) ) & +! - MATMUL( a(1:3,1:3) , JVS(1:3,1:3,jj) ) +! END DO +! END DO +! DO kk = LU_CROW(k), LU_CROW(k+1)-1 +! JVS(1:3,1:3,kk) = W( 1:3,1:3,LU_ICOL(kk) ) +! END DO +! END DO +! +! DO k=1,NVAR +! ! CALL WGEFA(JVS(1,1,LU_DIAG(k)),3,3,IP(1,k),IER) +! ! CALL DGETRF(3,3,JVS(1,1,LU_DIAG(k)),3,IP(1,k),IER) +! CALL FAC3(JVS(1,1,LU_DIAG(k)),IP(1,k),IER) +! IF ( IER /= 0 ) RETURN +! END DO +! +!END SUBROUTINE KppDecompBig +! +! +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!SUBROUTINE KppSolveBig( JVS, IP, X ) +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!! Sparse solve subroutine using indirect addressing +!! for the Runge Kutta (3n)x(3n) linear system +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! USE gckpp_adj_Parameters +! USE gckpp_adj_JacobianSP +! +! INTEGER :: i, j, k, m, IP3(3), IP(3,NVAR), IER +! REAL(kind=dp) :: JVS(3,3,LU_NONZERO), X(3,NVAR), sum(3) +! +! DO i=1,NVAR +! DO j = LU_CROW(i), LU_DIAG(i)-1 +! !X(1:3,i) = X(1:3,i) - MATMUL(JVS(1:3,1:3,j),X(1:3,LU_ICOL(j))); +! DO k=1,3 +! DO m=1,3 +! X(k,i) = X(k,i) - JVS(k,m,j)*X(m,LU_ICOL(j)) +! END DO +! END DO +! END DO +! END DO +! +! DO i=NVAR,1,-1 +! sum(1:3) = X(1:3,i); +! DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1 +! !sum(1:3) = sum(1:3) - MATMUL(JVS(1:3,1:3,j),X(1:3,LU_ICOL(j))); +! DO k=1,3 +! DO m=1,3 +! sum(k) = sum(k) - JVS(k,m,j)*X(m,LU_ICOL(j)) +! END DO +! END DO +! END DO +! ! X(i) = sum/JVS(LU_DIAG(i)); +! ! CALL DGETRS ('N',3,1,JVS(1:3,1:3,LU_DIAG(i)),3,IP(1,i),sum,3,0) +! ! CALL WGESL('N',JVS(1,1,LU_DIAG(i)),3,3,IP(1,i),sum) +! CALL SOL3('N',JVS(1,1,LU_DIAG(i)),IP(1,i),sum) +! X(1:3,i) = sum(1:3) +! END DO +! +!END SUBROUTINE KppSolveBig +! +! +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!SUBROUTINE KppSolveBigTR( JVS, IP, X ) +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!! Big sparse transpose solve using indirect addressing +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! USE gckpp_adj_Parameters +! USE gckpp_adj_JacobianSP +! +! INTEGER :: i, j, k, m, IP(3,NVAR) +! REAL(kind=dp) :: JVS(3,3,LU_NONZERO), X(3,NVAR) +! +! DO i=1,NVAR +! ! X(i) = X(i)/JVS(LU_DIAG(i)) +! CALL SOL3('T',JVS(1,1,LU_DIAG(i)),IP(1,i),X(1,i)) +! DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1 +! !X(1:3,LU_ICOL(j)) = X(1:3,LU_ICOL(j)) & +! ! - MATMUL( TRANSPOSE(JVS(1:3,1:3,j)), X(1:3,i) ) +! DO k=1,3 +! DO m=1,3 +! X(k,LU_ICOL(j)) = X(k,LU_ICOL(j)) - JVS(m,k,j)*X(m,i) +! END DO +! END DO +! END DO +! END DO +! +! DO i=NVAR, 1, -1 +! DO j=LU_CROW(i),LU_DIAG(i)-1 +! !X(1:3,LU_ICOL(j)) = X(1:3,LU_ICOL(j)) & +! ! - MATMUL( TRANSPOSE(JVS(1:3,1:3,j)), X(1:3,i) ) +! DO k=1,3 +! DO m=1,3 +! X(k,LU_ICOL(j)) = X(k,LU_ICOL(j)) - JVS(m,k,j)*X(m,i) +! END DO +! END DO +! END DO +! END DO +! +!END SUBROUTINE KppSolveBigTR +! +! +! +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!SUBROUTINE FAC3(A,IPVT,INFO) +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!! FAC3 FACTORS THE MATRIX A (3,3) BY +!! GAUSS ELIMINATION WITH PARTIAL PIVOTING +!! LINPACK - LIKE +!! +!! Remove comments to perform pivoting +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!! +! REAL(kind=dp) :: A(3,3) +! INTEGER :: IPVT(3),INFO +!! INTEGER :: L +!! REAL(kind=dp) :: t, dmax, da, TMP(3) +! REAL(kind=dp), PARAMETER :: ZERO = 0.0, ONE = 1.0 +! +! info = 0 +!! t = TINY(da) +!! +!! da = ABS(A(1,1)); L = 1 +!! IF ( ABS(A(2,1))>da ) THEN +!! da = ABS(A(2,1)); L = 2 +!! IF ( ABS(A(3,1))>da ) THEN +!! L = 3 +!! END IF +!! END IF +!! IPVT(1) = L +!! IF (L /=1 ) THEN +!! TMP(1:3) = A(L,1:3) +!! A(L,1:3) = A(1,1:3) +!! A(1,1:3) = TMP(1:3) +!! END IF +!! IF (ABS(A(1,1)) < t) THEN +!! info = 1 +!! return +!! END IF +!! +! A(2,1) = A(2,1)/A(1,1) +! A(2,2) = A(2,2) - A(2,1)*A(1,2) +! A(2,3) = A(2,3) - A(2,1)*A(1,3) +! A(3,1) = A(3,1)/A(1,1) +! A(3,2) = A(3,2) - A(3,1)*A(1,2) +! A(3,3) = A(3,3) - A(3,1)*A(1,3) +! +!! IPVT(2) = 2 +!! IF (ABS(A(3,2))>ABS(A(2,2))) THEN +!! IPVT(2) = 3 +!! TMP(2:3) = A(3,2:3) +!! A(3,2:3) = A(2,2:3) +!! A(2,2:3) = TMP(2:3) +!! END IF +!! IF (ABS(A(2,2)) < t) THEN +!! info = 1 +!! return +!! END IF +!! +! A(3,2) = A(3,2)/A(2,2) +! A(3,3) = A(3,3) - A(3,2)*A(2,3) +! IPVT(3) = 3 +! +!END SUBROUTINE FAC3 +! +! +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!SUBROUTINE SOL3(Trans,A,IPVT,b) +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!! SOL3 solves the system 3x3 +!! A * x = b or trans(a) * x = b +!! using the factors computed by WGEFA. +!! +!! Trans = 'N' to solve A*x = b , +!! = 'T' to solve transpose(A)*x = b +!! LINPACK - LIKE +!! +!! Remove comments to use pivoting +!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! CHARACTER :: Trans +! REAL(kind=dp) :: a(3,3),b(3) +! INTEGER :: IPVT(3) +!! INTEGER :: L +!! REAL(kind=dp) :: TMP +! +! SELECT CASE (Trans) +! +! CASE ('n','N') ! Solve A * x = b +! +!! Solve L*y = b +!! L = IPVT(1) +!! IF (L /= 1) THEN +!! TMP = B(1); B(1) = B(L); B(L) = TMP +!! END IF +! b(2) = b(2)-A(2,1)*b(1) +! b(3) = b(3)-A(3,1)*b(1) +! +!! L = IPVT(2) +!! IF (L /= 2) THEN +!! TMP = B(2); B(2) = B(L); B(L) = TMP +!! END IF +! b(3) = b(3)-A(3,2)*b(2) +! +!! Solve U*x = y +! b(3) = b(3)/A(3,3) +! b(2) = (b(2)-A(2,3)*b(3))/A(2,2) +! b(1) = (b(1)-A(1,3)*b(3)-A(1,2)*b(2))/A(1,1) +! +! +! CASE ('t','T') ! Solve transpose(A) * x = b +! +!! Solve transpose(U)*y = b +! b(1) = b(1)/A(1,1) +! b(2) = (b(2)-A(1,2)*b(1))/A(2,2) +! b(3) = (b(3)-A(1,3)*b(1)-A(2,3)*b(2))/A(3,3) +! +!! Solve transpose(L)*x = y +! b(2) = b(2)-A(3,2)*b(3) +!! L = ipvt(2) +!! IF (L /= 2) THEN +!! TMP = B(2); B(2) = B(L); B(L) = TMP +!! END IF +! b(1) = b(1)-A(3,1)*b(3)-A(2,1)*b(2) +!! L = ipvt(1) +!! IF (L /= 1) THEN +!! TMP = B(1); B(1) = B(L); B(L) = TMP +!! END IF +! +! END SELECT +! +!END SUBROUTINE SOL3 + +! End of SPARSE_UTIL function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! KppSolve - sparse back substitution +! Arguments : +! JVS - sparse Jacobian of variables +! X - Vector for variables +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE KppSolve ( JVS, X ) + +! JVS - sparse Jacobian of variables + REAL(kind=dp) :: JVS(LU_NONZERO) +! X - Vector for variables + REAL(kind=dp) :: X(NVAR) + + X(47) = X(47)-JVS(167)*X(40)-JVS(168)*X(41)-JVS(169)*X(46) + X(48) = X(48)-JVS(190)*X(46) + X(49) = X(49)-JVS(196)*X(32) + X(50) = X(50)-JVS(206)*X(41)-JVS(207)*X(42) + X(52) = X(52)-JVS(225)*X(16)-JVS(226)*X(31) + X(53) = X(53)-JVS(235)*X(16)-JVS(236)*X(32) + X(56) = X(56)-JVS(259)*X(22)-JVS(260)*X(23)-JVS(261)*X(25)-JVS(262)*X(34)-JVS(263)*X(51) + X(58) = X(58)-JVS(291)*X(45)-JVS(292)*X(57) + X(59) = X(59)-JVS(301)*X(40) + X(61) = X(61)-JVS(317)*X(40)-JVS(318)*X(41)-JVS(319)*X(44)-JVS(320)*X(58)-JVS(321)*X(59) + X(62) = X(62)-JVS(337)*X(49)-JVS(338)*X(53) + X(63) = X(63)-JVS(347)*X(38)-JVS(348)*X(48) + X(64) = X(64)-JVS(358)*X(42) + X(65) = X(65)-JVS(366)*X(43)-JVS(367)*X(51)-JVS(368)*X(55) + X(66) = X(66)-JVS(377)*X(41)-JVS(378)*X(58) + X(67) = X(67)-JVS(387)*X(39)-JVS(388)*X(46) + X(68) = X(68)-JVS(397)*X(30)-JVS(398)*X(31)-JVS(399)*X(38)-JVS(400)*X(39)-JVS(401)*X(42)-JVS(402)*X(43)-JVS(403)*X(51)& + &-JVS(404)*X(52)-JVS(405)*X(54)-JVS(406)*X(55)-JVS(407)*X(63)-JVS(408)*X(64)-JVS(409)*X(65)-JVS(410)*X(67) + X(69) = X(69)-JVS(424)*X(26)-JVS(425)*X(27)-JVS(426)*X(28)-JVS(427)*X(34)-JVS(428)*X(36)-JVS(429)*X(37)-JVS(430)*X(40)& + &-JVS(431)*X(42)-JVS(432)*X(44)-JVS(433)*X(45)-JVS(434)*X(46)-JVS(435)*X(48)-JVS(436)*X(50)-JVS(437)*X(51)& + &-JVS(438)*X(52)-JVS(439)*X(53)-JVS(440)*X(54)-JVS(441)*X(55)-JVS(442)*X(57)-JVS(443)*X(58)-JVS(444)*X(59)& + &-JVS(445)*X(60)-JVS(446)*X(61)-JVS(447)*X(62)-JVS(448)*X(63)-JVS(449)*X(64)-JVS(450)*X(65)-JVS(451)*X(66)& + &-JVS(452)*X(67) + X(70) = X(70)-JVS(474)*X(37)-JVS(475)*X(48) + X(71) = X(71)-JVS(485)*X(33)-JVS(486)*X(35)-JVS(487)*X(37)-JVS(488)*X(48)-JVS(489)*X(54)-JVS(490)*X(60)-JVS(491)*X(63)& + &-JVS(492)*X(70) + X(72) = X(72)-JVS(508)*X(22)-JVS(509)*X(30)-JVS(510)*X(54) + X(73) = X(73)-JVS(519)*X(54)-JVS(520)*X(60)-JVS(521)*X(62)-JVS(522)*X(72) + X(74) = X(74)-JVS(531)*X(23)-JVS(532)*X(35)-JVS(533)*X(68)-JVS(534)*X(70)-JVS(535)*X(72)-JVS(536)*X(73) + X(75) = X(75)-JVS(549)*X(41)-JVS(550)*X(42)-JVS(551)*X(51)-JVS(552)*X(55)-JVS(553)*X(58)-JVS(554)*X(59)-JVS(555)*X(60)& + &-JVS(556)*X(61)-JVS(557)*X(62)-JVS(558)*X(64)-JVS(559)*X(65)-JVS(560)*X(66)-JVS(561)*X(70)-JVS(562)*X(72)& + &-JVS(563)*X(73) + X(76) = X(76)-JVS(578)*X(57)-JVS(579)*X(59)-JVS(580)*X(60)-JVS(581)*X(62)-JVS(582)*X(64)-JVS(583)*X(66)-JVS(584)*X(72)& + &-JVS(585)*X(73) + X(77) = X(77)-JVS(597)*X(45)-JVS(598)*X(46)-JVS(599)*X(57)-JVS(600)*X(67) + X(78) = X(78)-JVS(610)*X(26)-JVS(611)*X(44)-JVS(612)*X(58)-JVS(613)*X(77) + X(79) = X(79)-JVS(625)*X(45)-JVS(626)*X(46)-JVS(627)*X(57) + X(80) = X(80)-JVS(636)*X(45)-JVS(637)*X(46)-JVS(638)*X(57)-JVS(639)*X(67)-JVS(640)*X(79) + X(81) = X(81)-JVS(649)*X(18)-JVS(650)*X(33)-JVS(651)*X(68)-JVS(652)*X(70)-JVS(653)*X(72)-JVS(654)*X(73)-JVS(655)*X(76)& + &-JVS(656)*X(77)-JVS(657)*X(79)-JVS(658)*X(80) + X(82) = X(82)-JVS(668)*X(18)-JVS(669)*X(19)-JVS(670)*X(21)-JVS(671)*X(24)-JVS(672)*X(25)-JVS(673)*X(29)-JVS(674)*X(38)& + &-JVS(675)*X(39)-JVS(676)*X(43)-JVS(677)*X(44)-JVS(678)*X(51)-JVS(679)*X(52)-JVS(680)*X(53)-JVS(681)*X(54)& + &-JVS(682)*X(55)-JVS(683)*X(56)-JVS(684)*X(57)-JVS(685)*X(59)-JVS(686)*X(60)-JVS(687)*X(62)-JVS(688)*X(63)& + &-JVS(689)*X(64)-JVS(690)*X(65)-JVS(691)*X(66)-JVS(692)*X(67)-JVS(693)*X(68)-JVS(694)*X(69)-JVS(695)*X(70)& + &-JVS(696)*X(71)-JVS(697)*X(72)-JVS(698)*X(73)-JVS(699)*X(74)-JVS(700)*X(75)-JVS(701)*X(76)-JVS(702)*X(77)& + &-JVS(703)*X(78)-JVS(704)*X(79)-JVS(705)*X(80)-JVS(706)*X(81) + X(83) = X(83)-JVS(716)*X(16)-JVS(717)*X(17)-JVS(718)*X(20)-JVS(719)*X(22)-JVS(720)*X(23)-JVS(721)*X(24)-JVS(722)*X(26)& + &-JVS(723)*X(27)-JVS(724)*X(28)-JVS(725)*X(29)-JVS(726)*X(30)-JVS(727)*X(31)-JVS(728)*X(32)-JVS(729)*X(33)& + &-JVS(730)*X(34)-JVS(731)*X(35)-JVS(732)*X(36)-JVS(733)*X(37)-JVS(734)*X(38)-JVS(735)*X(39)-JVS(736)*X(40)& + &-JVS(737)*X(41)-JVS(738)*X(42)-JVS(739)*X(43)-JVS(740)*X(44)-JVS(741)*X(45)-JVS(742)*X(46)-JVS(743)*X(47)& + &-JVS(744)*X(48)-JVS(745)*X(49)-JVS(746)*X(50)-JVS(747)*X(51)-JVS(748)*X(52)-JVS(749)*X(53)-JVS(750)*X(55)& + &-JVS(751)*X(56)-JVS(752)*X(57)-JVS(753)*X(58)-JVS(754)*X(59)-JVS(755)*X(61)-JVS(756)*X(62)-JVS(757)*X(63)& + &-JVS(758)*X(64)-JVS(759)*X(65)-JVS(760)*X(66)-JVS(761)*X(67)-JVS(762)*X(68)-JVS(763)*X(69)-JVS(764)*X(70)& + &-JVS(765)*X(71)-JVS(766)*X(72)-JVS(767)*X(73)-JVS(768)*X(74)-JVS(769)*X(75)-JVS(770)*X(76)-JVS(771)*X(77)& + &-JVS(772)*X(78)-JVS(773)*X(79)-JVS(774)*X(80)-JVS(775)*X(81)-JVS(776)*X(82) + X(84) = X(84)-JVS(785)*X(17)-JVS(786)*X(20)-JVS(787)*X(28)-JVS(788)*X(29)-JVS(789)*X(30)-JVS(790)*X(31)-JVS(791)*X(32)& + &-JVS(792)*X(33)-JVS(793)*X(34)-JVS(794)*X(35)-JVS(795)*X(36)-JVS(796)*X(37)-JVS(797)*X(38)-JVS(798)*X(39)& + &-JVS(799)*X(40)-JVS(800)*X(41)-JVS(801)*X(42)-JVS(802)*X(43)-JVS(803)*X(44)-JVS(804)*X(45)-JVS(805)*X(46)& + &-JVS(806)*X(47)-JVS(807)*X(48)-JVS(808)*X(49)-JVS(809)*X(50)-JVS(810)*X(51)-JVS(811)*X(52)-JVS(812)*X(53)& + &-JVS(813)*X(54)-JVS(814)*X(55)-JVS(815)*X(57)-JVS(816)*X(58)-JVS(817)*X(59)-JVS(818)*X(60)-JVS(819)*X(61)& + &-JVS(820)*X(62)-JVS(821)*X(63)-JVS(822)*X(64)-JVS(823)*X(65)-JVS(824)*X(66)-JVS(825)*X(67)-JVS(826)*X(68)& + &-JVS(827)*X(69)-JVS(828)*X(70)-JVS(829)*X(71)-JVS(830)*X(72)-JVS(831)*X(73)-JVS(832)*X(74)-JVS(833)*X(75)& + &-JVS(834)*X(76)-JVS(835)*X(77)-JVS(836)*X(78)-JVS(837)*X(79)-JVS(838)*X(80)-JVS(839)*X(81)-JVS(840)*X(82)& + &-JVS(841)*X(83) + X(85) = X(85)-JVS(849)*X(24)-JVS(850)*X(25)-JVS(851)*X(51)-JVS(852)*X(52)-JVS(853)*X(53)-JVS(854)*X(54)-JVS(855)*X(55)& + &-JVS(856)*X(57)-JVS(857)*X(59)-JVS(858)*X(60)-JVS(859)*X(62)-JVS(860)*X(63)-JVS(861)*X(64)-JVS(862)*X(65)& + &-JVS(863)*X(66)-JVS(864)*X(67)-JVS(865)*X(70)-JVS(866)*X(72)-JVS(867)*X(73)-JVS(868)*X(74)-JVS(869)*X(76)& + &-JVS(870)*X(77)-JVS(871)*X(78)-JVS(872)*X(79)-JVS(873)*X(80)-JVS(874)*X(81)-JVS(875)*X(82)-JVS(876)*X(83)& + &-JVS(877)*X(84) + X(86) = X(86)-JVS(884)*X(21)-JVS(885)*X(26)-JVS(886)*X(27)-JVS(887)*X(42)-JVS(888)*X(49)-JVS(889)*X(51)-JVS(890)*X(52)& + &-JVS(891)*X(53)-JVS(892)*X(54)-JVS(893)*X(55)-JVS(894)*X(57)-JVS(895)*X(59)-JVS(896)*X(60)-JVS(897)*X(61)& + &-JVS(898)*X(62)-JVS(899)*X(63)-JVS(900)*X(64)-JVS(901)*X(65)-JVS(902)*X(66)-JVS(903)*X(67)-JVS(904)*X(70)& + &-JVS(905)*X(71)-JVS(906)*X(72)-JVS(907)*X(73)-JVS(908)*X(74)-JVS(909)*X(75)-JVS(910)*X(76)-JVS(911)*X(77)& + &-JVS(912)*X(78)-JVS(913)*X(79)-JVS(914)*X(80)-JVS(915)*X(81)-JVS(916)*X(82)-JVS(917)*X(83)-JVS(918)*X(84)& + &-JVS(919)*X(85) + X(87) = X(87)-JVS(925)*X(21)-JVS(926)*X(22)-JVS(927)*X(23)-JVS(928)*X(25)-JVS(929)*X(29)-JVS(930)*X(34)-JVS(931)*X(46)& + &-JVS(932)*X(48)-JVS(933)*X(56)-JVS(934)*X(57)-JVS(935)*X(59)-JVS(936)*X(64)-JVS(937)*X(65)-JVS(938)*X(66)& + &-JVS(939)*X(67)-JVS(940)*X(68)-JVS(941)*X(69)-JVS(942)*X(70)-JVS(943)*X(71)-JVS(944)*X(72)-JVS(945)*X(73)& + &-JVS(946)*X(74)-JVS(947)*X(75)-JVS(948)*X(76)-JVS(949)*X(77)-JVS(950)*X(78)-JVS(951)*X(79)-JVS(952)*X(80)& + &-JVS(953)*X(81)-JVS(954)*X(82)-JVS(955)*X(83)-JVS(956)*X(84)-JVS(957)*X(85)-JVS(958)*X(86) + X(88) = X(88)-JVS(963)*X(19)-JVS(964)*X(36)-JVS(965)*X(50)-JVS(966)*X(51)-JVS(967)*X(58)-JVS(968)*X(64)-JVS(969)*X(65)& + &-JVS(970)*X(66)-JVS(971)*X(77)-JVS(972)*X(79)-JVS(973)*X(80)-JVS(974)*X(82)-JVS(975)*X(83)-JVS(976)*X(84)& + &-JVS(977)*X(85)-JVS(978)*X(86)-JVS(979)*X(87) + X(89) = X(89)-JVS(983)*X(25)-JVS(984)*X(44)-JVS(985)*X(46)-JVS(986)*X(48)-JVS(987)*X(58)-JVS(988)*X(77)-JVS(989)*X(78)& + &-JVS(990)*X(79)-JVS(991)*X(80)-JVS(992)*X(81)-JVS(993)*X(82)-JVS(994)*X(83)-JVS(995)*X(84)-JVS(996)*X(85)& + &-JVS(997)*X(86)-JVS(998)*X(87)-JVS(999)*X(88) + X(90) = X(90)-JVS(1002)*X(21)-JVS(1003)*X(27)-JVS(1004)*X(28)-JVS(1005)*X(34)-JVS(1006)*X(48)-JVS(1007)*X(49)& + &-JVS(1008)*X(51)-JVS(1009)*X(52)-JVS(1010)*X(53)-JVS(1011)*X(54)-JVS(1012)*X(55)-JVS(1013)*X(57)-JVS(1014)& + &*X(59)-JVS(1015)*X(60)-JVS(1016)*X(62)-JVS(1017)*X(63)-JVS(1018)*X(64)-JVS(1019)*X(65)-JVS(1020)*X(66)& + &-JVS(1021)*X(67)-JVS(1022)*X(70)-JVS(1023)*X(71)-JVS(1024)*X(72)-JVS(1025)*X(73)-JVS(1026)*X(74)-JVS(1027)& + &*X(75)-JVS(1028)*X(76)-JVS(1029)*X(77)-JVS(1030)*X(78)-JVS(1031)*X(79)-JVS(1032)*X(80)-JVS(1033)*X(81)& + &-JVS(1034)*X(82)-JVS(1035)*X(83)-JVS(1036)*X(84)-JVS(1037)*X(85)-JVS(1038)*X(86)-JVS(1039)*X(87)-JVS(1040)& + &*X(88)-JVS(1041)*X(89) + X(90) = X(90)/JVS(1042) + X(89) = (X(89)-JVS(1001)*X(90))/(JVS(1000)) + X(88) = (X(88)-JVS(981)*X(89)-JVS(982)*X(90))/(JVS(980)) + X(87) = (X(87)-JVS(960)*X(88)-JVS(961)*X(89)-JVS(962)*X(90))/(JVS(959)) + X(86) = (X(86)-JVS(921)*X(87)-JVS(922)*X(88)-JVS(923)*X(89)-JVS(924)*X(90))/(JVS(920)) + X(85) = (X(85)-JVS(879)*X(86)-JVS(880)*X(87)-JVS(881)*X(88)-JVS(882)*X(89)-JVS(883)*X(90))/(JVS(878)) + X(84) = (X(84)-JVS(843)*X(85)-JVS(844)*X(86)-JVS(845)*X(87)-JVS(846)*X(88)-JVS(847)*X(89)-JVS(848)*X(90))/(JVS(842)) + X(83) = (X(83)-JVS(778)*X(84)-JVS(779)*X(85)-JVS(780)*X(86)-JVS(781)*X(87)-JVS(782)*X(88)-JVS(783)*X(89)-JVS(784)& + &*X(90))/(JVS(777)) + X(82) = (X(82)-JVS(708)*X(83)-JVS(709)*X(84)-JVS(710)*X(85)-JVS(711)*X(86)-JVS(712)*X(87)-JVS(713)*X(88)-JVS(714)& + &*X(89)-JVS(715)*X(90))/(JVS(707)) + X(81) = (X(81)-JVS(660)*X(82)-JVS(661)*X(83)-JVS(662)*X(84)-JVS(663)*X(85)-JVS(664)*X(86)-JVS(665)*X(87)-JVS(666)& + &*X(89)-JVS(667)*X(90))/(JVS(659)) + X(80) = (X(80)-JVS(642)*X(83)-JVS(643)*X(84)-JVS(644)*X(85)-JVS(645)*X(86)-JVS(646)*X(87)-JVS(647)*X(89)-JVS(648)& + &*X(90))/(JVS(641)) + X(79) = (X(79)-JVS(629)*X(83)-JVS(630)*X(84)-JVS(631)*X(85)-JVS(632)*X(86)-JVS(633)*X(87)-JVS(634)*X(89)-JVS(635)& + &*X(90))/(JVS(628)) + X(78) = (X(78)-JVS(615)*X(79)-JVS(616)*X(80)-JVS(617)*X(82)-JVS(618)*X(83)-JVS(619)*X(84)-JVS(620)*X(85)-JVS(621)& + &*X(86)-JVS(622)*X(87)-JVS(623)*X(89)-JVS(624)*X(90))/(JVS(614)) + X(77) = (X(77)-JVS(602)*X(79)-JVS(603)*X(83)-JVS(604)*X(84)-JVS(605)*X(85)-JVS(606)*X(86)-JVS(607)*X(87)-JVS(608)& + &*X(89)-JVS(609)*X(90))/(JVS(601)) + X(76) = (X(76)-JVS(587)*X(77)-JVS(588)*X(79)-JVS(589)*X(80)-JVS(590)*X(83)-JVS(591)*X(84)-JVS(592)*X(85)-JVS(593)& + &*X(86)-JVS(594)*X(87)-JVS(595)*X(89)-JVS(596)*X(90))/(JVS(586)) + X(75) = (X(75)-JVS(565)*X(76)-JVS(566)*X(77)-JVS(567)*X(78)-JVS(568)*X(79)-JVS(569)*X(80)-JVS(570)*X(82)-JVS(571)& + &*X(83)-JVS(572)*X(84)-JVS(573)*X(85)-JVS(574)*X(86)-JVS(575)*X(87)-JVS(576)*X(89)-JVS(577)*X(90))/(JVS(564)) + X(74) = (X(74)-JVS(538)*X(76)-JVS(539)*X(77)-JVS(540)*X(80)-JVS(541)*X(81)-JVS(542)*X(83)-JVS(543)*X(84)-JVS(544)& + &*X(85)-JVS(545)*X(86)-JVS(546)*X(87)-JVS(547)*X(89)-JVS(548)*X(90))/(JVS(537)) + X(73) = (X(73)-JVS(524)*X(76)-JVS(525)*X(83)-JVS(526)*X(84)-JVS(527)*X(85)-JVS(528)*X(86)-JVS(529)*X(87)-JVS(530)& + &*X(90))/(JVS(523)) + X(72) = (X(72)-JVS(512)*X(73)-JVS(513)*X(83)-JVS(514)*X(84)-JVS(515)*X(85)-JVS(516)*X(86)-JVS(517)*X(87)-JVS(518)& + &*X(90))/(JVS(511)) + X(71) = (X(71)-JVS(494)*X(72)-JVS(495)*X(73)-JVS(496)*X(74)-JVS(497)*X(75)-JVS(498)*X(76)-JVS(499)*X(77)-JVS(500)& + &*X(81)-JVS(501)*X(83)-JVS(502)*X(84)-JVS(503)*X(85)-JVS(504)*X(86)-JVS(505)*X(87)-JVS(506)*X(89)-JVS(507)& + &*X(90))/(JVS(493)) + X(70) = (X(70)-JVS(477)*X(77)-JVS(478)*X(83)-JVS(479)*X(84)-JVS(480)*X(85)-JVS(481)*X(86)-JVS(482)*X(87)-JVS(483)& + &*X(89)-JVS(484)*X(90))/(JVS(476)) + X(69) = (X(69)-JVS(454)*X(70)-JVS(455)*X(71)-JVS(456)*X(72)-JVS(457)*X(73)-JVS(458)*X(74)-JVS(459)*X(76)-JVS(460)& + &*X(77)-JVS(461)*X(78)-JVS(462)*X(79)-JVS(463)*X(80)-JVS(464)*X(81)-JVS(465)*X(82)-JVS(466)*X(83)-JVS(467)*X(84)& + &-JVS(468)*X(85)-JVS(469)*X(86)-JVS(470)*X(87)-JVS(471)*X(88)-JVS(472)*X(89)-JVS(473)*X(90))/(JVS(453)) + X(68) = (X(68)-JVS(412)*X(70)-JVS(413)*X(72)-JVS(414)*X(73)-JVS(415)*X(77)-JVS(416)*X(80)-JVS(417)*X(83)-JVS(418)& + &*X(84)-JVS(419)*X(85)-JVS(420)*X(86)-JVS(421)*X(87)-JVS(422)*X(89)-JVS(423)*X(90))/(JVS(411)) + X(67) = (X(67)-JVS(390)*X(83)-JVS(391)*X(84)-JVS(392)*X(85)-JVS(393)*X(86)-JVS(394)*X(87)-JVS(395)*X(89)-JVS(396)& + &*X(90))/(JVS(389)) + X(66) = (X(66)-JVS(380)*X(79)-JVS(381)*X(83)-JVS(382)*X(84)-JVS(383)*X(85)-JVS(384)*X(86)-JVS(385)*X(89)-JVS(386)& + &*X(90))/(JVS(379)) + X(65) = (X(65)-JVS(370)*X(80)-JVS(371)*X(83)-JVS(372)*X(84)-JVS(373)*X(85)-JVS(374)*X(86)-JVS(375)*X(87)-JVS(376)& + &*X(90))/(JVS(369)) + X(64) = (X(64)-JVS(360)*X(77)-JVS(361)*X(83)-JVS(362)*X(84)-JVS(363)*X(85)-JVS(364)*X(86)-JVS(365)*X(90))/(JVS(359)) + X(63) = (X(63)-JVS(350)*X(77)-JVS(351)*X(83)-JVS(352)*X(84)-JVS(353)*X(85)-JVS(354)*X(86)-JVS(355)*X(87)-JVS(356)& + &*X(89)-JVS(357)*X(90))/(JVS(349)) + X(62) = (X(62)-JVS(340)*X(72)-JVS(341)*X(73)-JVS(342)*X(83)-JVS(343)*X(84)-JVS(344)*X(85)-JVS(345)*X(86)-JVS(346)& + &*X(90))/(JVS(339)) + X(61) = (X(61)-JVS(323)*X(62)-JVS(324)*X(65)-JVS(325)*X(66)-JVS(326)*X(70)-JVS(327)*X(78)-JVS(328)*X(79)-JVS(329)& + &*X(80)-JVS(330)*X(82)-JVS(331)*X(83)-JVS(332)*X(84)-JVS(333)*X(85)-JVS(334)*X(86)-JVS(335)*X(89)-JVS(336)& + &*X(90))/(JVS(322)) + X(60) = (X(60)-JVS(310)*X(76)-JVS(311)*X(83)-JVS(312)*X(84)-JVS(313)*X(85)-JVS(314)*X(86)-JVS(315)*X(87)-JVS(316)& + &*X(90))/(JVS(309)) + X(59) = (X(59)-JVS(303)*X(80)-JVS(304)*X(83)-JVS(305)*X(84)-JVS(306)*X(85)-JVS(307)*X(86)-JVS(308)*X(90))/(JVS(302)) + X(58) = (X(58)-JVS(294)*X(79)-JVS(295)*X(83)-JVS(296)*X(84)-JVS(297)*X(85)-JVS(298)*X(86)-JVS(299)*X(89)-JVS(300)& + &*X(90))/(JVS(293)) + X(57) = (X(57)-JVS(286)*X(79)-JVS(287)*X(84)-JVS(288)*X(85)-JVS(289)*X(86)-JVS(290)*X(90))/(JVS(285)) + X(56) = (X(56)-JVS(265)*X(57)-JVS(266)*X(59)-JVS(267)*X(64)-JVS(268)*X(65)-JVS(269)*X(66)-JVS(270)*X(67)-JVS(271)& + &*X(68)-JVS(272)*X(69)-JVS(273)*X(71)-JVS(274)*X(75)-JVS(275)*X(76)-JVS(276)*X(79)-JVS(277)*X(80)-JVS(278)*X(82)& + &-JVS(279)*X(83)-JVS(280)*X(84)-JVS(281)*X(85)-JVS(282)*X(86)-JVS(283)*X(87)-JVS(284)*X(90))/(JVS(264)) + X(55) = (X(55)-JVS(253)*X(80)-JVS(254)*X(84)-JVS(255)*X(85)-JVS(256)*X(86)-JVS(257)*X(87)-JVS(258)*X(90))/(JVS(252)) + X(54) = (X(54)-JVS(246)*X(73)-JVS(247)*X(83)-JVS(248)*X(84)-JVS(249)*X(85)-JVS(250)*X(86)-JVS(251)*X(90))/(JVS(245)) + X(53) = (X(53)-JVS(238)*X(72)-JVS(239)*X(73)-JVS(240)*X(83)-JVS(241)*X(84)-JVS(242)*X(85)-JVS(243)*X(86)-JVS(244)& + &*X(90))/(JVS(237)) + X(52) = (X(52)-JVS(228)*X(72)-JVS(229)*X(73)-JVS(230)*X(83)-JVS(231)*X(84)-JVS(232)*X(85)-JVS(233)*X(86)-JVS(234)& + &*X(90))/(JVS(227)) + X(51) = (X(51)-JVS(221)*X(84)-JVS(222)*X(85)-JVS(223)*X(86)-JVS(224)*X(90))/(JVS(220)) + X(50) = (X(50)-JVS(209)*X(51)-JVS(210)*X(58)-JVS(211)*X(64)-JVS(212)*X(65)-JVS(213)*X(66)-JVS(214)*X(83)-JVS(215)& + &*X(84)-JVS(216)*X(85)-JVS(217)*X(86)-JVS(218)*X(89)-JVS(219)*X(90))/(JVS(208)) + X(49) = (X(49)-JVS(198)*X(53)-JVS(199)*X(72)-JVS(200)*X(73)-JVS(201)*X(83)-JVS(202)*X(84)-JVS(203)*X(85)-JVS(204)& + &*X(86)-JVS(205)*X(90))/(JVS(197)) + X(48) = (X(48)-JVS(192)*X(77)-JVS(193)*X(83)-JVS(194)*X(87)-JVS(195)*X(89))/(JVS(191)) + X(47) = (X(47)-JVS(171)*X(48)-JVS(172)*X(49)-JVS(173)*X(50)-JVS(174)*X(58)-JVS(175)*X(59)-JVS(176)*X(66)-JVS(177)& + &*X(68)-JVS(178)*X(69)-JVS(179)*X(71)-JVS(180)*X(75)-JVS(181)*X(77)-JVS(182)*X(80)-JVS(183)*X(83)-JVS(184)*X(84)& + &-JVS(185)*X(85)-JVS(186)*X(86)-JVS(187)*X(87)-JVS(188)*X(89)-JVS(189)*X(90))/(JVS(170)) + X(46) = (X(46)-JVS(164)*X(83)-JVS(165)*X(87)-JVS(166)*X(89))/(JVS(163)) + X(45) = (X(45)-JVS(159)*X(57)-JVS(160)*X(79)-JVS(161)*X(83)-JVS(162)*X(84))/(JVS(158)) + X(44) = (X(44)-JVS(154)*X(78)-JVS(155)*X(82)-JVS(156)*X(83)-JVS(157)*X(89))/(JVS(153)) + X(43) = (X(43)-JVS(148)*X(51)-JVS(149)*X(55)-JVS(150)*X(65)-JVS(151)*X(83)-JVS(152)*X(84))/(JVS(147)) + X(42) = (X(42)-JVS(144)*X(64)-JVS(145)*X(83)-JVS(146)*X(84))/(JVS(143)) + X(41) = (X(41)-JVS(140)*X(66)-JVS(141)*X(83)-JVS(142)*X(84))/(JVS(139)) + X(40) = (X(40)-JVS(136)*X(59)-JVS(137)*X(83)-JVS(138)*X(84))/(JVS(135)) + X(39) = (X(39)-JVS(132)*X(67)-JVS(133)*X(83)-JVS(134)*X(84))/(JVS(131)) + X(38) = (X(38)-JVS(128)*X(63)-JVS(129)*X(83)-JVS(130)*X(84))/(JVS(127)) + X(37) = (X(37)-JVS(124)*X(70)-JVS(125)*X(83)-JVS(126)*X(84))/(JVS(123)) + X(36) = (X(36)-JVS(120)*X(83)-JVS(121)*X(84)-JVS(122)*X(88))/(JVS(119)) + X(35) = (X(35)-JVS(116)*X(74)-JVS(117)*X(83)-JVS(118)*X(84))/(JVS(115)) + X(34) = (X(34)-JVS(113)*X(83)-JVS(114)*X(87))/(JVS(112)) + X(33) = (X(33)-JVS(109)*X(81)-JVS(110)*X(83)-JVS(111)*X(84))/(JVS(108)) + X(32) = (X(32)-JVS(105)*X(53)-JVS(106)*X(83)-JVS(107)*X(84))/(JVS(104)) + X(31) = (X(31)-JVS(101)*X(52)-JVS(102)*X(83)-JVS(103)*X(84))/(JVS(100)) + X(30) = (X(30)-JVS(97)*X(72)-JVS(98)*X(83)-JVS(99)*X(84))/(JVS(96)) + X(29) = (X(29)-JVS(93)*X(82)-JVS(94)*X(83)-JVS(95)*X(84))/(JVS(92)) + X(28) = (X(28)-JVS(89)*X(83)-JVS(90)*X(84)-JVS(91)*X(90))/(JVS(88)) + X(27) = (X(27)-JVS(85)*X(83)-JVS(86)*X(84)-JVS(87)*X(86))/(JVS(84)) + X(26) = (X(26)-JVS(81)*X(78)-JVS(82)*X(83)-JVS(83)*X(84))/(JVS(80)) + X(25) = (X(25)-JVS(78)*X(82)-JVS(79)*X(87))/(JVS(77)) + X(24) = (X(24)-JVS(74)*X(82)-JVS(75)*X(83)-JVS(76)*X(85))/(JVS(73)) + X(23) = (X(23)-JVS(71)*X(83)-JVS(72)*X(87))/(JVS(70)) + X(22) = (X(22)-JVS(68)*X(83)-JVS(69)*X(87))/(JVS(67)) + X(21) = (X(21)-JVS(65)*X(82)-JVS(66)*X(86))/(JVS(64)) + X(20) = (X(20)-JVS(61)*X(34)-JVS(62)*X(83)-JVS(63)*X(87))/(JVS(60)) + X(19) = (X(19)-JVS(58)*X(82)-JVS(59)*X(88))/(JVS(57)) + X(18) = (X(18)-JVS(55)*X(81)-JVS(56)*X(82))/(JVS(54)) + X(17) = (X(17)-JVS(52)*X(83)-JVS(53)*X(84))/(JVS(51)) + X(16) = (X(16)-JVS(50)*X(83))/(JVS(49)) + X(15) = (X(15)-JVS(47)*X(46)-JVS(48)*X(83))/(JVS(46)) + X(14) = (X(14)-JVS(36)*X(17)-JVS(37)*X(18)-JVS(38)*X(21)-JVS(39)*X(25)-JVS(40)*X(44)-JVS(41)*X(56)-JVS(42)*X(69)& + &-JVS(43)*X(73)-JVS(44)*X(82)-JVS(45)*X(89))/(JVS(35)) + X(13) = (X(13)-JVS(28)*X(46)-JVS(29)*X(47)-JVS(30)*X(80)-JVS(31)*X(83)-JVS(32)*X(85)-JVS(33)*X(86)-JVS(34)*X(89))& + &/(JVS(27)) + X(12) = (X(12)-JVS(25)*X(34)-JVS(26)*X(83))/(JVS(24)) + X(11) = (X(11)-JVS(22)*X(20)-JVS(23)*X(83))/(JVS(21)) + X(10) = (X(10)-JVS(20)*X(73))/(JVS(19)) + X(9) = (X(9)-JVS(18)*X(18))/(JVS(17)) + X(8) = (X(8)-JVS(16)*X(44))/(JVS(15)) + X(7) = (X(7)-JVS(14)*X(21))/(JVS(13)) + X(6) = (X(6)-JVS(12)*X(89))/(JVS(11)) + X(5) = (X(5)-JVS(10)*X(82))/(JVS(9)) + X(4) = (X(4)-JVS(8)*X(25))/(JVS(7)) + X(3) = (X(3)-JVS(6)*X(56))/(JVS(5)) + X(2) = (X(2)-JVS(4)*X(17))/(JVS(3)) + X(1) = (X(1)-JVS(2)*X(69))/(JVS(1)) + +END SUBROUTINE KppSolve + +! End of KppSolve function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! KppSolveTR - sparse, transposed back substitution +! Arguments : +! JVS - sparse Jacobian of variables +! X - Vector for variables +! XX - Vector for output variables +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE KppSolveTR ( JVS, X, XX ) + +! JVS - sparse Jacobian of variables + REAL(kind=dp) :: JVS(LU_NONZERO) +! X - Vector for variables + REAL(kind=dp) :: X(NVAR) +! XX - Vector for output variables + REAL(kind=dp) :: XX(NVAR) + + XX(1) = X(1)/JVS(1) + XX(2) = X(2)/JVS(3) + XX(3) = X(3)/JVS(5) + XX(4) = X(4)/JVS(7) + XX(5) = X(5)/JVS(9) + XX(6) = X(6)/JVS(11) + XX(7) = X(7)/JVS(13) + XX(8) = X(8)/JVS(15) + XX(9) = X(9)/JVS(17) + XX(10) = X(10)/JVS(19) + XX(11) = X(11)/JVS(21) + XX(12) = X(12)/JVS(24) + XX(13) = X(13)/JVS(27) + XX(14) = X(14)/JVS(35) + XX(15) = X(15)/JVS(46) + XX(16) = X(16)/JVS(49) + XX(17) = (X(17)-JVS(4)*XX(2)-JVS(36)*XX(14))/(JVS(51)) + XX(18) = (X(18)-JVS(18)*XX(9)-JVS(37)*XX(14))/(JVS(54)) + XX(19) = X(19)/JVS(57) + XX(20) = (X(20)-JVS(22)*XX(11))/(JVS(60)) + XX(21) = (X(21)-JVS(14)*XX(7)-JVS(38)*XX(14))/(JVS(64)) + XX(22) = X(22)/JVS(67) + XX(23) = X(23)/JVS(70) + XX(24) = X(24)/JVS(73) + XX(25) = (X(25)-JVS(8)*XX(4)-JVS(39)*XX(14))/(JVS(77)) + XX(26) = X(26)/JVS(80) + XX(27) = X(27)/JVS(84) + XX(28) = X(28)/JVS(88) + XX(29) = X(29)/JVS(92) + XX(30) = X(30)/JVS(96) + XX(31) = X(31)/JVS(100) + XX(32) = X(32)/JVS(104) + XX(33) = X(33)/JVS(108) + XX(34) = (X(34)-JVS(25)*XX(12)-JVS(61)*XX(20))/(JVS(112)) + XX(35) = X(35)/JVS(115) + XX(36) = X(36)/JVS(119) + XX(37) = X(37)/JVS(123) + XX(38) = X(38)/JVS(127) + XX(39) = X(39)/JVS(131) + XX(40) = X(40)/JVS(135) + XX(41) = X(41)/JVS(139) + XX(42) = X(42)/JVS(143) + XX(43) = X(43)/JVS(147) + XX(44) = (X(44)-JVS(16)*XX(8)-JVS(40)*XX(14))/(JVS(153)) + XX(45) = X(45)/JVS(158) + XX(46) = (X(46)-JVS(28)*XX(13)-JVS(47)*XX(15))/(JVS(163)) + XX(47) = (X(47)-JVS(29)*XX(13))/(JVS(170)) + XX(48) = (X(48)-JVS(171)*XX(47))/(JVS(191)) + XX(49) = (X(49)-JVS(172)*XX(47))/(JVS(197)) + XX(50) = (X(50)-JVS(173)*XX(47))/(JVS(208)) + XX(51) = (X(51)-JVS(148)*XX(43)-JVS(209)*XX(50))/(JVS(220)) + XX(52) = (X(52)-JVS(101)*XX(31))/(JVS(227)) + XX(53) = (X(53)-JVS(105)*XX(32)-JVS(198)*XX(49))/(JVS(237)) + XX(54) = X(54)/JVS(245) + XX(55) = (X(55)-JVS(149)*XX(43))/(JVS(252)) + XX(56) = (X(56)-JVS(6)*XX(3)-JVS(41)*XX(14))/(JVS(264)) + XX(57) = (X(57)-JVS(159)*XX(45)-JVS(265)*XX(56))/(JVS(285)) + XX(58) = (X(58)-JVS(174)*XX(47)-JVS(210)*XX(50))/(JVS(293)) + XX(59) = (X(59)-JVS(136)*XX(40)-JVS(175)*XX(47)-JVS(266)*XX(56))/(JVS(302)) + XX(60) = X(60)/JVS(309) + XX(61) = X(61)/JVS(322) + XX(62) = (X(62)-JVS(323)*XX(61))/(JVS(339)) + XX(63) = (X(63)-JVS(128)*XX(38))/(JVS(349)) + XX(64) = (X(64)-JVS(144)*XX(42)-JVS(211)*XX(50)-JVS(267)*XX(56))/(JVS(359)) + XX(65) = (X(65)-JVS(150)*XX(43)-JVS(212)*XX(50)-JVS(268)*XX(56)-JVS(324)*XX(61))/(JVS(369)) + XX(66) = (X(66)-JVS(140)*XX(41)-JVS(176)*XX(47)-JVS(213)*XX(50)-JVS(269)*XX(56)-JVS(325)*XX(61))/(JVS(379)) + XX(67) = (X(67)-JVS(132)*XX(39)-JVS(270)*XX(56))/(JVS(389)) + XX(68) = (X(68)-JVS(177)*XX(47)-JVS(271)*XX(56))/(JVS(411)) + XX(69) = (X(69)-JVS(2)*XX(1)-JVS(42)*XX(14)-JVS(178)*XX(47)-JVS(272)*XX(56))/(JVS(453)) + XX(70) = (X(70)-JVS(124)*XX(37)-JVS(326)*XX(61)-JVS(412)*XX(68)-JVS(454)*XX(69))/(JVS(476)) + XX(71) = (X(71)-JVS(179)*XX(47)-JVS(273)*XX(56)-JVS(455)*XX(69))/(JVS(493)) + XX(72) = (X(72)-JVS(97)*XX(30)-JVS(199)*XX(49)-JVS(228)*XX(52)-JVS(238)*XX(53)-JVS(340)*XX(62)-JVS(413)*XX(68)& + &-JVS(456)*XX(69)-JVS(494)*XX(71))/(JVS(511)) + XX(73) = (X(73)-JVS(20)*XX(10)-JVS(43)*XX(14)-JVS(200)*XX(49)-JVS(229)*XX(52)-JVS(239)*XX(53)-JVS(246)*XX(54)-JVS(341)& + &*XX(62)-JVS(414)*XX(68)-JVS(457)*XX(69)-JVS(495)*XX(71)-JVS(512)*XX(72))/(JVS(523)) + XX(74) = (X(74)-JVS(116)*XX(35)-JVS(458)*XX(69)-JVS(496)*XX(71))/(JVS(537)) + XX(75) = (X(75)-JVS(180)*XX(47)-JVS(274)*XX(56)-JVS(497)*XX(71))/(JVS(564)) + XX(76) = (X(76)-JVS(275)*XX(56)-JVS(310)*XX(60)-JVS(459)*XX(69)-JVS(498)*XX(71)-JVS(524)*XX(73)-JVS(538)*XX(74)& + &-JVS(565)*XX(75))/(JVS(586)) + XX(77) = (X(77)-JVS(181)*XX(47)-JVS(192)*XX(48)-JVS(350)*XX(63)-JVS(360)*XX(64)-JVS(415)*XX(68)-JVS(460)*XX(69)& + &-JVS(477)*XX(70)-JVS(499)*XX(71)-JVS(539)*XX(74)-JVS(566)*XX(75)-JVS(587)*XX(76))/(JVS(601)) + XX(78) = (X(78)-JVS(81)*XX(26)-JVS(154)*XX(44)-JVS(327)*XX(61)-JVS(461)*XX(69)-JVS(567)*XX(75))/(JVS(614)) + XX(79) = (X(79)-JVS(160)*XX(45)-JVS(276)*XX(56)-JVS(286)*XX(57)-JVS(294)*XX(58)-JVS(328)*XX(61)-JVS(380)*XX(66)& + &-JVS(462)*XX(69)-JVS(568)*XX(75)-JVS(588)*XX(76)-JVS(602)*XX(77)-JVS(615)*XX(78))/(JVS(628)) + XX(80) = (X(80)-JVS(30)*XX(13)-JVS(182)*XX(47)-JVS(253)*XX(55)-JVS(277)*XX(56)-JVS(303)*XX(59)-JVS(329)*XX(61)& + &-JVS(370)*XX(65)-JVS(416)*XX(68)-JVS(463)*XX(69)-JVS(540)*XX(74)-JVS(569)*XX(75)-JVS(589)*XX(76)-JVS(616)& + &*XX(78))/(JVS(641)) + XX(81) = (X(81)-JVS(55)*XX(18)-JVS(109)*XX(33)-JVS(464)*XX(69)-JVS(500)*XX(71)-JVS(541)*XX(74))/(JVS(659)) + XX(82) = (X(82)-JVS(10)*XX(5)-JVS(44)*XX(14)-JVS(56)*XX(18)-JVS(58)*XX(19)-JVS(65)*XX(21)-JVS(74)*XX(24)-JVS(78)& + &*XX(25)-JVS(93)*XX(29)-JVS(155)*XX(44)-JVS(278)*XX(56)-JVS(330)*XX(61)-JVS(465)*XX(69)-JVS(570)*XX(75)& + &-JVS(617)*XX(78)-JVS(660)*XX(81))/(JVS(707)) + XX(83) = (X(83)-JVS(23)*XX(11)-JVS(26)*XX(12)-JVS(31)*XX(13)-JVS(48)*XX(15)-JVS(50)*XX(16)-JVS(52)*XX(17)-JVS(62)& + &*XX(20)-JVS(68)*XX(22)-JVS(71)*XX(23)-JVS(75)*XX(24)-JVS(82)*XX(26)-JVS(85)*XX(27)-JVS(89)*XX(28)-JVS(94)& + &*XX(29)-JVS(98)*XX(30)-JVS(102)*XX(31)-JVS(106)*XX(32)-JVS(110)*XX(33)-JVS(113)*XX(34)-JVS(117)*XX(35)& + &-JVS(120)*XX(36)-JVS(125)*XX(37)-JVS(129)*XX(38)-JVS(133)*XX(39)-JVS(137)*XX(40)-JVS(141)*XX(41)-JVS(145)& + &*XX(42)-JVS(151)*XX(43)-JVS(156)*XX(44)-JVS(161)*XX(45)-JVS(164)*XX(46)-JVS(183)*XX(47)-JVS(193)*XX(48)& + &-JVS(201)*XX(49)-JVS(214)*XX(50)-JVS(230)*XX(52)-JVS(240)*XX(53)-JVS(247)*XX(54)-JVS(279)*XX(56)-JVS(295)& + &*XX(58)-JVS(304)*XX(59)-JVS(311)*XX(60)-JVS(331)*XX(61)-JVS(342)*XX(62)-JVS(351)*XX(63)-JVS(361)*XX(64)& + &-JVS(371)*XX(65)-JVS(381)*XX(66)-JVS(390)*XX(67)-JVS(417)*XX(68)-JVS(466)*XX(69)-JVS(478)*XX(70)-JVS(501)& + &*XX(71)-JVS(513)*XX(72)-JVS(525)*XX(73)-JVS(542)*XX(74)-JVS(571)*XX(75)-JVS(590)*XX(76)-JVS(603)*XX(77)& + &-JVS(618)*XX(78)-JVS(629)*XX(79)-JVS(642)*XX(80)-JVS(661)*XX(81)-JVS(708)*XX(82))/(JVS(777)) + XX(84) = (X(84)-JVS(53)*XX(17)-JVS(83)*XX(26)-JVS(86)*XX(27)-JVS(90)*XX(28)-JVS(95)*XX(29)-JVS(99)*XX(30)-JVS(103)& + &*XX(31)-JVS(107)*XX(32)-JVS(111)*XX(33)-JVS(118)*XX(35)-JVS(121)*XX(36)-JVS(126)*XX(37)-JVS(130)*XX(38)& + &-JVS(134)*XX(39)-JVS(138)*XX(40)-JVS(142)*XX(41)-JVS(146)*XX(42)-JVS(152)*XX(43)-JVS(162)*XX(45)-JVS(184)& + &*XX(47)-JVS(202)*XX(49)-JVS(215)*XX(50)-JVS(221)*XX(51)-JVS(231)*XX(52)-JVS(241)*XX(53)-JVS(248)*XX(54)& + &-JVS(254)*XX(55)-JVS(280)*XX(56)-JVS(287)*XX(57)-JVS(296)*XX(58)-JVS(305)*XX(59)-JVS(312)*XX(60)-JVS(332)& + &*XX(61)-JVS(343)*XX(62)-JVS(352)*XX(63)-JVS(362)*XX(64)-JVS(372)*XX(65)-JVS(382)*XX(66)-JVS(391)*XX(67)& + &-JVS(418)*XX(68)-JVS(467)*XX(69)-JVS(479)*XX(70)-JVS(502)*XX(71)-JVS(514)*XX(72)-JVS(526)*XX(73)-JVS(543)& + &*XX(74)-JVS(572)*XX(75)-JVS(591)*XX(76)-JVS(604)*XX(77)-JVS(619)*XX(78)-JVS(630)*XX(79)-JVS(643)*XX(80)& + &-JVS(662)*XX(81)-JVS(709)*XX(82)-JVS(778)*XX(83))/(JVS(842)) + XX(85) = (X(85)-JVS(32)*XX(13)-JVS(76)*XX(24)-JVS(185)*XX(47)-JVS(203)*XX(49)-JVS(216)*XX(50)-JVS(222)*XX(51)-JVS(232)& + &*XX(52)-JVS(242)*XX(53)-JVS(249)*XX(54)-JVS(255)*XX(55)-JVS(281)*XX(56)-JVS(288)*XX(57)-JVS(297)*XX(58)& + &-JVS(306)*XX(59)-JVS(313)*XX(60)-JVS(333)*XX(61)-JVS(344)*XX(62)-JVS(353)*XX(63)-JVS(363)*XX(64)-JVS(373)& + &*XX(65)-JVS(383)*XX(66)-JVS(392)*XX(67)-JVS(419)*XX(68)-JVS(468)*XX(69)-JVS(480)*XX(70)-JVS(503)*XX(71)& + &-JVS(515)*XX(72)-JVS(527)*XX(73)-JVS(544)*XX(74)-JVS(573)*XX(75)-JVS(592)*XX(76)-JVS(605)*XX(77)-JVS(620)& + &*XX(78)-JVS(631)*XX(79)-JVS(644)*XX(80)-JVS(663)*XX(81)-JVS(710)*XX(82)-JVS(779)*XX(83)-JVS(843)*XX(84))& + &/(JVS(878)) + XX(86) = (X(86)-JVS(33)*XX(13)-JVS(66)*XX(21)-JVS(87)*XX(27)-JVS(186)*XX(47)-JVS(204)*XX(49)-JVS(217)*XX(50)-JVS(223)& + &*XX(51)-JVS(233)*XX(52)-JVS(243)*XX(53)-JVS(250)*XX(54)-JVS(256)*XX(55)-JVS(282)*XX(56)-JVS(289)*XX(57)& + &-JVS(298)*XX(58)-JVS(307)*XX(59)-JVS(314)*XX(60)-JVS(334)*XX(61)-JVS(345)*XX(62)-JVS(354)*XX(63)-JVS(364)& + &*XX(64)-JVS(374)*XX(65)-JVS(384)*XX(66)-JVS(393)*XX(67)-JVS(420)*XX(68)-JVS(469)*XX(69)-JVS(481)*XX(70)& + &-JVS(504)*XX(71)-JVS(516)*XX(72)-JVS(528)*XX(73)-JVS(545)*XX(74)-JVS(574)*XX(75)-JVS(593)*XX(76)-JVS(606)& + &*XX(77)-JVS(621)*XX(78)-JVS(632)*XX(79)-JVS(645)*XX(80)-JVS(664)*XX(81)-JVS(711)*XX(82)-JVS(780)*XX(83)& + &-JVS(844)*XX(84)-JVS(879)*XX(85))/(JVS(920)) + XX(87) = (X(87)-JVS(63)*XX(20)-JVS(69)*XX(22)-JVS(72)*XX(23)-JVS(79)*XX(25)-JVS(114)*XX(34)-JVS(165)*XX(46)-JVS(187)& + &*XX(47)-JVS(194)*XX(48)-JVS(257)*XX(55)-JVS(283)*XX(56)-JVS(315)*XX(60)-JVS(355)*XX(63)-JVS(375)*XX(65)& + &-JVS(394)*XX(67)-JVS(421)*XX(68)-JVS(470)*XX(69)-JVS(482)*XX(70)-JVS(505)*XX(71)-JVS(517)*XX(72)-JVS(529)& + &*XX(73)-JVS(546)*XX(74)-JVS(575)*XX(75)-JVS(594)*XX(76)-JVS(607)*XX(77)-JVS(622)*XX(78)-JVS(633)*XX(79)& + &-JVS(646)*XX(80)-JVS(665)*XX(81)-JVS(712)*XX(82)-JVS(781)*XX(83)-JVS(845)*XX(84)-JVS(880)*XX(85)-JVS(921)& + &*XX(86))/(JVS(959)) + XX(88) = (X(88)-JVS(59)*XX(19)-JVS(122)*XX(36)-JVS(471)*XX(69)-JVS(713)*XX(82)-JVS(782)*XX(83)-JVS(846)*XX(84)& + &-JVS(881)*XX(85)-JVS(922)*XX(86)-JVS(960)*XX(87))/(JVS(980)) + XX(89) = (X(89)-JVS(12)*XX(6)-JVS(34)*XX(13)-JVS(45)*XX(14)-JVS(157)*XX(44)-JVS(166)*XX(46)-JVS(188)*XX(47)-JVS(195)& + &*XX(48)-JVS(218)*XX(50)-JVS(299)*XX(58)-JVS(335)*XX(61)-JVS(356)*XX(63)-JVS(385)*XX(66)-JVS(395)*XX(67)& + &-JVS(422)*XX(68)-JVS(472)*XX(69)-JVS(483)*XX(70)-JVS(506)*XX(71)-JVS(547)*XX(74)-JVS(576)*XX(75)-JVS(595)& + &*XX(76)-JVS(608)*XX(77)-JVS(623)*XX(78)-JVS(634)*XX(79)-JVS(647)*XX(80)-JVS(666)*XX(81)-JVS(714)*XX(82)& + &-JVS(783)*XX(83)-JVS(847)*XX(84)-JVS(882)*XX(85)-JVS(923)*XX(86)-JVS(961)*XX(87)-JVS(981)*XX(88))/(JVS(1000)) + XX(90) = (X(90)-JVS(91)*XX(28)-JVS(189)*XX(47)-JVS(205)*XX(49)-JVS(219)*XX(50)-JVS(224)*XX(51)-JVS(234)*XX(52)& + &-JVS(244)*XX(53)-JVS(251)*XX(54)-JVS(258)*XX(55)-JVS(284)*XX(56)-JVS(290)*XX(57)-JVS(300)*XX(58)-JVS(308)& + &*XX(59)-JVS(316)*XX(60)-JVS(336)*XX(61)-JVS(346)*XX(62)-JVS(357)*XX(63)-JVS(365)*XX(64)-JVS(376)*XX(65)& + &-JVS(386)*XX(66)-JVS(396)*XX(67)-JVS(423)*XX(68)-JVS(473)*XX(69)-JVS(484)*XX(70)-JVS(507)*XX(71)-JVS(518)& + &*XX(72)-JVS(530)*XX(73)-JVS(548)*XX(74)-JVS(577)*XX(75)-JVS(596)*XX(76)-JVS(609)*XX(77)-JVS(624)*XX(78)& + &-JVS(635)*XX(79)-JVS(648)*XX(80)-JVS(667)*XX(81)-JVS(715)*XX(82)-JVS(784)*XX(83)-JVS(848)*XX(84)-JVS(883)& + &*XX(85)-JVS(924)*XX(86)-JVS(962)*XX(87)-JVS(982)*XX(88)-JVS(1001)*XX(89))/(JVS(1042)) + XX(90) = XX(90) + XX(89) = XX(89)-JVS(1041)*XX(90) + XX(88) = XX(88)-JVS(999)*XX(89)-JVS(1040)*XX(90) + XX(87) = XX(87)-JVS(979)*XX(88)-JVS(998)*XX(89)-JVS(1039)*XX(90) + XX(86) = XX(86)-JVS(958)*XX(87)-JVS(978)*XX(88)-JVS(997)*XX(89)-JVS(1038)*XX(90) + XX(85) = XX(85)-JVS(919)*XX(86)-JVS(957)*XX(87)-JVS(977)*XX(88)-JVS(996)*XX(89)-JVS(1037)*XX(90) + XX(84) = XX(84)-JVS(877)*XX(85)-JVS(918)*XX(86)-JVS(956)*XX(87)-JVS(976)*XX(88)-JVS(995)*XX(89)-JVS(1036)*XX(90) + XX(83) = XX(83)-JVS(841)*XX(84)-JVS(876)*XX(85)-JVS(917)*XX(86)-JVS(955)*XX(87)-JVS(975)*XX(88)-JVS(994)*XX(89)& + &-JVS(1035)*XX(90) + XX(82) = XX(82)-JVS(776)*XX(83)-JVS(840)*XX(84)-JVS(875)*XX(85)-JVS(916)*XX(86)-JVS(954)*XX(87)-JVS(974)*XX(88)& + &-JVS(993)*XX(89)-JVS(1034)*XX(90) + XX(81) = XX(81)-JVS(706)*XX(82)-JVS(775)*XX(83)-JVS(839)*XX(84)-JVS(874)*XX(85)-JVS(915)*XX(86)-JVS(953)*XX(87)& + &-JVS(992)*XX(89)-JVS(1033)*XX(90) + XX(80) = XX(80)-JVS(658)*XX(81)-JVS(705)*XX(82)-JVS(774)*XX(83)-JVS(838)*XX(84)-JVS(873)*XX(85)-JVS(914)*XX(86)& + &-JVS(952)*XX(87)-JVS(973)*XX(88)-JVS(991)*XX(89)-JVS(1032)*XX(90) + XX(79) = XX(79)-JVS(640)*XX(80)-JVS(657)*XX(81)-JVS(704)*XX(82)-JVS(773)*XX(83)-JVS(837)*XX(84)-JVS(872)*XX(85)& + &-JVS(913)*XX(86)-JVS(951)*XX(87)-JVS(972)*XX(88)-JVS(990)*XX(89)-JVS(1031)*XX(90) + XX(78) = XX(78)-JVS(703)*XX(82)-JVS(772)*XX(83)-JVS(836)*XX(84)-JVS(871)*XX(85)-JVS(912)*XX(86)-JVS(950)*XX(87)& + &-JVS(989)*XX(89)-JVS(1030)*XX(90) + XX(77) = XX(77)-JVS(613)*XX(78)-JVS(656)*XX(81)-JVS(702)*XX(82)-JVS(771)*XX(83)-JVS(835)*XX(84)-JVS(870)*XX(85)& + &-JVS(911)*XX(86)-JVS(949)*XX(87)-JVS(971)*XX(88)-JVS(988)*XX(89)-JVS(1029)*XX(90) + XX(76) = XX(76)-JVS(655)*XX(81)-JVS(701)*XX(82)-JVS(770)*XX(83)-JVS(834)*XX(84)-JVS(869)*XX(85)-JVS(910)*XX(86)& + &-JVS(948)*XX(87)-JVS(1028)*XX(90) + XX(75) = XX(75)-JVS(700)*XX(82)-JVS(769)*XX(83)-JVS(833)*XX(84)-JVS(909)*XX(86)-JVS(947)*XX(87)-JVS(1027)*XX(90) + XX(74) = XX(74)-JVS(699)*XX(82)-JVS(768)*XX(83)-JVS(832)*XX(84)-JVS(868)*XX(85)-JVS(908)*XX(86)-JVS(946)*XX(87)& + &-JVS(1026)*XX(90) + XX(73) = XX(73)-JVS(536)*XX(74)-JVS(563)*XX(75)-JVS(585)*XX(76)-JVS(654)*XX(81)-JVS(698)*XX(82)-JVS(767)*XX(83)& + &-JVS(831)*XX(84)-JVS(867)*XX(85)-JVS(907)*XX(86)-JVS(945)*XX(87)-JVS(1025)*XX(90) + XX(72) = XX(72)-JVS(522)*XX(73)-JVS(535)*XX(74)-JVS(562)*XX(75)-JVS(584)*XX(76)-JVS(653)*XX(81)-JVS(697)*XX(82)& + &-JVS(766)*XX(83)-JVS(830)*XX(84)-JVS(866)*XX(85)-JVS(906)*XX(86)-JVS(944)*XX(87)-JVS(1024)*XX(90) + XX(71) = XX(71)-JVS(696)*XX(82)-JVS(765)*XX(83)-JVS(829)*XX(84)-JVS(905)*XX(86)-JVS(943)*XX(87)-JVS(1023)*XX(90) + XX(70) = XX(70)-JVS(492)*XX(71)-JVS(534)*XX(74)-JVS(561)*XX(75)-JVS(652)*XX(81)-JVS(695)*XX(82)-JVS(764)*XX(83)& + &-JVS(828)*XX(84)-JVS(865)*XX(85)-JVS(904)*XX(86)-JVS(942)*XX(87)-JVS(1022)*XX(90) + XX(69) = XX(69)-JVS(694)*XX(82)-JVS(763)*XX(83)-JVS(827)*XX(84)-JVS(941)*XX(87) + XX(68) = XX(68)-JVS(533)*XX(74)-JVS(651)*XX(81)-JVS(693)*XX(82)-JVS(762)*XX(83)-JVS(826)*XX(84)-JVS(940)*XX(87) + XX(67) = XX(67)-JVS(410)*XX(68)-JVS(452)*XX(69)-JVS(600)*XX(77)-JVS(639)*XX(80)-JVS(692)*XX(82)-JVS(761)*XX(83)& + &-JVS(825)*XX(84)-JVS(864)*XX(85)-JVS(903)*XX(86)-JVS(939)*XX(87)-JVS(1021)*XX(90) + XX(66) = XX(66)-JVS(451)*XX(69)-JVS(560)*XX(75)-JVS(583)*XX(76)-JVS(691)*XX(82)-JVS(760)*XX(83)-JVS(824)*XX(84)& + &-JVS(863)*XX(85)-JVS(902)*XX(86)-JVS(938)*XX(87)-JVS(970)*XX(88)-JVS(1020)*XX(90) + XX(65) = XX(65)-JVS(409)*XX(68)-JVS(450)*XX(69)-JVS(559)*XX(75)-JVS(690)*XX(82)-JVS(759)*XX(83)-JVS(823)*XX(84)& + &-JVS(862)*XX(85)-JVS(901)*XX(86)-JVS(937)*XX(87)-JVS(969)*XX(88)-JVS(1019)*XX(90) + XX(64) = XX(64)-JVS(408)*XX(68)-JVS(449)*XX(69)-JVS(558)*XX(75)-JVS(582)*XX(76)-JVS(689)*XX(82)-JVS(758)*XX(83)& + &-JVS(822)*XX(84)-JVS(861)*XX(85)-JVS(900)*XX(86)-JVS(936)*XX(87)-JVS(968)*XX(88)-JVS(1018)*XX(90) + XX(63) = XX(63)-JVS(407)*XX(68)-JVS(448)*XX(69)-JVS(491)*XX(71)-JVS(688)*XX(82)-JVS(757)*XX(83)-JVS(821)*XX(84)& + &-JVS(860)*XX(85)-JVS(899)*XX(86)-JVS(1017)*XX(90) + XX(62) = XX(62)-JVS(447)*XX(69)-JVS(521)*XX(73)-JVS(557)*XX(75)-JVS(581)*XX(76)-JVS(687)*XX(82)-JVS(756)*XX(83)& + &-JVS(820)*XX(84)-JVS(859)*XX(85)-JVS(898)*XX(86)-JVS(1016)*XX(90) + XX(61) = XX(61)-JVS(446)*XX(69)-JVS(556)*XX(75)-JVS(755)*XX(83)-JVS(819)*XX(84)-JVS(897)*XX(86) + XX(60) = XX(60)-JVS(445)*XX(69)-JVS(490)*XX(71)-JVS(520)*XX(73)-JVS(555)*XX(75)-JVS(580)*XX(76)-JVS(686)*XX(82)& + &-JVS(818)*XX(84)-JVS(858)*XX(85)-JVS(896)*XX(86)-JVS(1015)*XX(90) + XX(59) = XX(59)-JVS(321)*XX(61)-JVS(444)*XX(69)-JVS(554)*XX(75)-JVS(579)*XX(76)-JVS(685)*XX(82)-JVS(754)*XX(83)& + &-JVS(817)*XX(84)-JVS(857)*XX(85)-JVS(895)*XX(86)-JVS(935)*XX(87)-JVS(1014)*XX(90) + XX(58) = XX(58)-JVS(320)*XX(61)-JVS(378)*XX(66)-JVS(443)*XX(69)-JVS(553)*XX(75)-JVS(612)*XX(78)-JVS(753)*XX(83)& + &-JVS(816)*XX(84)-JVS(967)*XX(88)-JVS(987)*XX(89) + XX(57) = XX(57)-JVS(292)*XX(58)-JVS(442)*XX(69)-JVS(578)*XX(76)-JVS(599)*XX(77)-JVS(627)*XX(79)-JVS(638)*XX(80)& + &-JVS(684)*XX(82)-JVS(752)*XX(83)-JVS(815)*XX(84)-JVS(856)*XX(85)-JVS(894)*XX(86)-JVS(934)*XX(87)-JVS(1013)& + &*XX(90) + XX(56) = XX(56)-JVS(683)*XX(82)-JVS(751)*XX(83)-JVS(933)*XX(87) + XX(55) = XX(55)-JVS(368)*XX(65)-JVS(406)*XX(68)-JVS(441)*XX(69)-JVS(552)*XX(75)-JVS(682)*XX(82)-JVS(750)*XX(83)& + &-JVS(814)*XX(84)-JVS(855)*XX(85)-JVS(893)*XX(86)-JVS(1012)*XX(90) + XX(54) = XX(54)-JVS(405)*XX(68)-JVS(440)*XX(69)-JVS(489)*XX(71)-JVS(510)*XX(72)-JVS(519)*XX(73)-JVS(681)*XX(82)& + &-JVS(813)*XX(84)-JVS(854)*XX(85)-JVS(892)*XX(86)-JVS(1011)*XX(90) + XX(53) = XX(53)-JVS(338)*XX(62)-JVS(439)*XX(69)-JVS(680)*XX(82)-JVS(749)*XX(83)-JVS(812)*XX(84)-JVS(853)*XX(85)& + &-JVS(891)*XX(86)-JVS(1010)*XX(90) + XX(52) = XX(52)-JVS(404)*XX(68)-JVS(438)*XX(69)-JVS(679)*XX(82)-JVS(748)*XX(83)-JVS(811)*XX(84)-JVS(852)*XX(85)& + &-JVS(890)*XX(86)-JVS(1009)*XX(90) + XX(51) = XX(51)-JVS(263)*XX(56)-JVS(367)*XX(65)-JVS(403)*XX(68)-JVS(437)*XX(69)-JVS(551)*XX(75)-JVS(678)*XX(82)& + &-JVS(747)*XX(83)-JVS(810)*XX(84)-JVS(851)*XX(85)-JVS(889)*XX(86)-JVS(966)*XX(88)-JVS(1008)*XX(90) + XX(50) = XX(50)-JVS(436)*XX(69)-JVS(746)*XX(83)-JVS(809)*XX(84)-JVS(965)*XX(88) + XX(49) = XX(49)-JVS(337)*XX(62)-JVS(745)*XX(83)-JVS(808)*XX(84)-JVS(888)*XX(86)-JVS(1007)*XX(90) + XX(48) = XX(48)-JVS(348)*XX(63)-JVS(435)*XX(69)-JVS(475)*XX(70)-JVS(488)*XX(71)-JVS(744)*XX(83)-JVS(807)*XX(84)& + &-JVS(932)*XX(87)-JVS(986)*XX(89)-JVS(1006)*XX(90) + XX(47) = XX(47)-JVS(743)*XX(83)-JVS(806)*XX(84) + XX(46) = XX(46)-JVS(169)*XX(47)-JVS(190)*XX(48)-JVS(388)*XX(67)-JVS(434)*XX(69)-JVS(598)*XX(77)-JVS(626)*XX(79)& + &-JVS(637)*XX(80)-JVS(742)*XX(83)-JVS(805)*XX(84)-JVS(931)*XX(87)-JVS(985)*XX(89) + XX(45) = XX(45)-JVS(291)*XX(58)-JVS(433)*XX(69)-JVS(597)*XX(77)-JVS(625)*XX(79)-JVS(636)*XX(80)-JVS(741)*XX(83)& + &-JVS(804)*XX(84) + XX(44) = XX(44)-JVS(319)*XX(61)-JVS(432)*XX(69)-JVS(611)*XX(78)-JVS(677)*XX(82)-JVS(740)*XX(83)-JVS(803)*XX(84)& + &-JVS(984)*XX(89) + XX(43) = XX(43)-JVS(366)*XX(65)-JVS(402)*XX(68)-JVS(676)*XX(82)-JVS(739)*XX(83)-JVS(802)*XX(84) + XX(42) = XX(42)-JVS(207)*XX(50)-JVS(358)*XX(64)-JVS(401)*XX(68)-JVS(431)*XX(69)-JVS(550)*XX(75)-JVS(738)*XX(83)& + &-JVS(801)*XX(84)-JVS(887)*XX(86) + XX(41) = XX(41)-JVS(168)*XX(47)-JVS(206)*XX(50)-JVS(318)*XX(61)-JVS(377)*XX(66)-JVS(549)*XX(75)-JVS(737)*XX(83)& + &-JVS(800)*XX(84) + XX(40) = XX(40)-JVS(167)*XX(47)-JVS(301)*XX(59)-JVS(317)*XX(61)-JVS(430)*XX(69)-JVS(736)*XX(83)-JVS(799)*XX(84) + XX(39) = XX(39)-JVS(387)*XX(67)-JVS(400)*XX(68)-JVS(675)*XX(82)-JVS(735)*XX(83)-JVS(798)*XX(84) + XX(38) = XX(38)-JVS(347)*XX(63)-JVS(399)*XX(68)-JVS(674)*XX(82)-JVS(734)*XX(83)-JVS(797)*XX(84) + XX(37) = XX(37)-JVS(429)*XX(69)-JVS(474)*XX(70)-JVS(487)*XX(71)-JVS(733)*XX(83)-JVS(796)*XX(84) + XX(36) = XX(36)-JVS(428)*XX(69)-JVS(732)*XX(83)-JVS(795)*XX(84)-JVS(964)*XX(88) + XX(35) = XX(35)-JVS(486)*XX(71)-JVS(532)*XX(74)-JVS(731)*XX(83)-JVS(794)*XX(84) + XX(34) = XX(34)-JVS(262)*XX(56)-JVS(427)*XX(69)-JVS(730)*XX(83)-JVS(793)*XX(84)-JVS(930)*XX(87)-JVS(1005)*XX(90) + XX(33) = XX(33)-JVS(485)*XX(71)-JVS(650)*XX(81)-JVS(729)*XX(83)-JVS(792)*XX(84) + XX(32) = XX(32)-JVS(196)*XX(49)-JVS(236)*XX(53)-JVS(728)*XX(83)-JVS(791)*XX(84) + XX(31) = XX(31)-JVS(226)*XX(52)-JVS(398)*XX(68)-JVS(727)*XX(83)-JVS(790)*XX(84) + XX(30) = XX(30)-JVS(397)*XX(68)-JVS(509)*XX(72)-JVS(726)*XX(83)-JVS(789)*XX(84) + XX(29) = XX(29)-JVS(673)*XX(82)-JVS(725)*XX(83)-JVS(788)*XX(84)-JVS(929)*XX(87) + XX(28) = XX(28)-JVS(426)*XX(69)-JVS(724)*XX(83)-JVS(787)*XX(84)-JVS(1004)*XX(90) + XX(27) = XX(27)-JVS(425)*XX(69)-JVS(723)*XX(83)-JVS(886)*XX(86)-JVS(1003)*XX(90) + XX(26) = XX(26)-JVS(424)*XX(69)-JVS(610)*XX(78)-JVS(722)*XX(83)-JVS(885)*XX(86) + XX(25) = XX(25)-JVS(261)*XX(56)-JVS(672)*XX(82)-JVS(850)*XX(85)-JVS(928)*XX(87)-JVS(983)*XX(89) + XX(24) = XX(24)-JVS(671)*XX(82)-JVS(721)*XX(83)-JVS(849)*XX(85) + XX(23) = XX(23)-JVS(260)*XX(56)-JVS(531)*XX(74)-JVS(720)*XX(83)-JVS(927)*XX(87) + XX(22) = XX(22)-JVS(259)*XX(56)-JVS(508)*XX(72)-JVS(719)*XX(83)-JVS(926)*XX(87) + XX(21) = XX(21)-JVS(670)*XX(82)-JVS(884)*XX(86)-JVS(925)*XX(87)-JVS(1002)*XX(90) + XX(20) = XX(20)-JVS(718)*XX(83)-JVS(786)*XX(84) + XX(19) = XX(19)-JVS(669)*XX(82)-JVS(963)*XX(88) + XX(18) = XX(18)-JVS(649)*XX(81)-JVS(668)*XX(82) + XX(17) = XX(17)-JVS(717)*XX(83)-JVS(785)*XX(84) + XX(16) = XX(16)-JVS(225)*XX(52)-JVS(235)*XX(53)-JVS(716)*XX(83) + XX(15) = XX(15) + XX(14) = XX(14) + XX(13) = XX(13) + XX(12) = XX(12) + XX(11) = XX(11) + XX(10) = XX(10) + XX(9) = XX(9) + XX(8) = XX(8) + XX(7) = XX(7) + XX(6) = XX(6) + XX(5) = XX(5) + XX(4) = XX(4) + XX(3) = XX(3) + XX(2) = XX(2) + XX(1) = XX(1) + +END SUBROUTINE KppSolveTR + +! End of KppSolveTR function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! BLAS_UTIL - BLAS-LIKE utility functions +! Arguments : +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!-------------------------------------------------------------- +! +! BLAS/LAPACK-like subroutines used by the integration algorithms +! It is recommended to replace them by calls to the optimized +! BLAS/LAPACK library for your machine +! +! (C) Adrian Sandu, Aug. 2004 +! Virginia Polytechnic Institute and State University +!-------------------------------------------------------------- + + +!-------------------------------------------------------------- + SUBROUTINE WCOPY(N,X,incX,Y,incY) +!-------------------------------------------------------------- +! copies a vector, x, to a vector, y: y <- x +! only for incX=incY=1 +! after BLAS +! replace this by the function from the optimized BLAS implementation: +! CALL SCOPY(N,X,1,Y,1) or CALL DCOPY(N,X,1,Y,1) +!-------------------------------------------------------------- +! USE gckpp_adj_Precision + + INTEGER :: i,incX,incY,M,MP1,N + REAL(kind=dp) :: X(N),Y(N) + + IF (N.LE.0) RETURN + + M = MOD(N,8) + IF( M .NE. 0 ) THEN + DO i = 1,M + Y(i) = X(i) + END DO + IF( N .LT. 8 ) RETURN + END IF + MP1 = M+1 + DO i = MP1,N,8 + Y(i) = X(i) + Y(i + 1) = X(i + 1) + Y(i + 2) = X(i + 2) + Y(i + 3) = X(i + 3) + Y(i + 4) = X(i + 4) + Y(i + 5) = X(i + 5) + Y(i + 6) = X(i + 6) + Y(i + 7) = X(i + 7) + END DO + + END SUBROUTINE WCOPY + + +!-------------------------------------------------------------- + SUBROUTINE WAXPY(N,Alpha,X,incX,Y,incY) +!-------------------------------------------------------------- +! constant times a vector plus a vector: y <- y + Alpha*x +! only for incX=incY=1 +! after BLAS +! replace this by the function from the optimized BLAS implementation: +! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1) +!-------------------------------------------------------------- + + INTEGER :: i,incX,incY,M,MP1,N + REAL(kind=dp) :: X(N),Y(N),Alpha + REAL(kind=dp), PARAMETER :: ZERO = 0.0_dp + + IF (Alpha .EQ. ZERO) RETURN + IF (N .LE. 0) RETURN + + M = MOD(N,4) + IF( M .NE. 0 ) THEN + DO i = 1,M + Y(i) = Y(i) + Alpha*X(i) + END DO + IF( N .LT. 4 ) RETURN + END IF + MP1 = M + 1 + DO i = MP1,N,4 + Y(i) = Y(i) + Alpha*X(i) + Y(i + 1) = Y(i + 1) + Alpha*X(i + 1) + Y(i + 2) = Y(i + 2) + Alpha*X(i + 2) + Y(i + 3) = Y(i + 3) + Alpha*X(i + 3) + END DO + + END SUBROUTINE WAXPY + + + +!-------------------------------------------------------------- + SUBROUTINE WSCAL(N,Alpha,X,incX) +!-------------------------------------------------------------- +! constant times a vector: x(1:N) <- Alpha*x(1:N) +! only for incX=incY=1 +! after BLAS +! replace this by the function from the optimized BLAS implementation: +! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1) +!-------------------------------------------------------------- + + INTEGER :: i,incX,M,MP1,N + REAL(kind=dp) :: X(N),Alpha + REAL(kind=dp), PARAMETER :: ZERO=0.0_dp, ONE=1.0_dp + + IF (Alpha .EQ. ONE) RETURN + IF (N .LE. 0) RETURN + + M = MOD(N,5) + IF( M .NE. 0 ) THEN + IF (Alpha .EQ. (-ONE)) THEN + DO i = 1,M + X(i) = -X(i) + END DO + ELSEIF (Alpha .EQ. ZERO) THEN + DO i = 1,M + X(i) = ZERO + END DO + ELSE + DO i = 1,M + X(i) = Alpha*X(i) + END DO + END IF + IF( N .LT. 5 ) RETURN + END IF + MP1 = M + 1 + IF (Alpha .EQ. (-ONE)) THEN + DO i = MP1,N,5 + X(i) = -X(i) + X(i + 1) = -X(i + 1) + X(i + 2) = -X(i + 2) + X(i + 3) = -X(i + 3) + X(i + 4) = -X(i + 4) + END DO + ELSEIF (Alpha .EQ. ZERO) THEN + DO i = MP1,N,5 + X(i) = ZERO + X(i + 1) = ZERO + X(i + 2) = ZERO + X(i + 3) = ZERO + X(i + 4) = ZERO + END DO + ELSE + DO i = MP1,N,5 + X(i) = Alpha*X(i) + X(i + 1) = Alpha*X(i + 1) + X(i + 2) = Alpha*X(i + 2) + X(i + 3) = Alpha*X(i + 3) + X(i + 4) = Alpha*X(i + 4) + END DO + END IF + + END SUBROUTINE WSCAL + +!-------------------------------------------------------------- + REAL(kind=dp) FUNCTION WLAMCH( C ) +!-------------------------------------------------------------- +! returns epsilon machine +! after LAPACK +! replace this by the function from the optimized LAPACK implementation: +! CALL SLAMCH('E') or CALL DLAMCH('E') +!-------------------------------------------------------------- +! USE gckpp_adj_Precision + + CHARACTER :: C + INTEGER :: i + REAL(kind=dp), SAVE :: Eps + REAL(kind=dp) :: Suma + REAL(kind=dp), PARAMETER :: ONE=1.0_dp, HALF=0.5_dp + LOGICAL, SAVE :: First=.TRUE. + + IF (First) THEN + First = .FALSE. + Eps = HALF**(16) + DO i = 17, 80 + Eps = Eps*HALF + CALL WLAMCH_ADD(ONE,Eps,Suma) + IF (Suma.LE.ONE) GOTO 10 + END DO + PRINT*,'ERROR IN WLAMCH. EPS < ',Eps + RETURN +10 Eps = Eps*2 + i = i-1 + END IF + + WLAMCH = Eps + + END FUNCTION WLAMCH + + SUBROUTINE WLAMCH_ADD( A, B, Suma ) +! USE gckpp_adj_Precision + + REAL(kind=dp) A, B, Suma + Suma = A + B + + END SUBROUTINE WLAMCH_ADD +!-------------------------------------------------------------- + + +!-------------------------------------------------------------- + SUBROUTINE SET2ZERO(N,Y) +!-------------------------------------------------------------- +! copies zeros into the vector y: y <- 0 +! after BLAS +!-------------------------------------------------------------- + + INTEGER :: i,M,MP1,N + REAL(kind=dp) :: Y(N) + REAL(kind=dp), PARAMETER :: ZERO = 0.0d0 + + IF (N.LE.0) RETURN + + M = MOD(N,8) + IF( M .NE. 0 ) THEN + DO i = 1,M + Y(i) = ZERO + END DO + IF( N .LT. 8 ) RETURN + END IF + MP1 = M+1 + DO i = MP1,N,8 + Y(i) = ZERO + Y(i + 1) = ZERO + Y(i + 2) = ZERO + Y(i + 3) = ZERO + Y(i + 4) = ZERO + Y(i + 5) = ZERO + Y(i + 6) = ZERO + Y(i + 7) = ZERO + END DO + + END SUBROUTINE SET2ZERO + + +!-------------------------------------------------------------- + REAL(kind=dp) FUNCTION WDOT (N, DX, incX, DY, incY) +!-------------------------------------------------------------- +! dot produce: wdot = x(1:N)*y(1:N) +! only for incX=incY=1 +! after BLAS +! replace this by the function from the optimized BLAS implementation: +! CALL SDOT(N,X,1,Y,1) or CALL DDOT(N,X,1,Y,1) +!-------------------------------------------------------------- +! USE messy_mecca_kpp_Precision +!-------------------------------------------------------------- + IMPLICIT NONE + INTEGER :: N, incX, incY + REAL(kind=dp) :: DX(N), DY(N) + + INTEGER :: i, IX, IY, M, MP1, NS + + WDOT = 0.0D0 + IF (N .LE. 0) RETURN + IF (incX .EQ. incY) IF (incX-1) 5,20,60 +! +! Code for unequal or nonpositive increments. +! + 5 IX = 1 + IY = 1 + IF (incX .LT. 0) IX = (-N+1)*incX + 1 + IF (incY .LT. 0) IY = (-N+1)*incY + 1 + DO i = 1,N + WDOT = WDOT + DX(IX)*DY(IY) + IX = IX + incX + IY = IY + incY + END DO + RETURN +! +! Code for both increments equal to 1. +! +! Clean-up loop so remaining vector length is a multiple of 5. +! + 20 M = MOD(N,5) + IF (M .EQ. 0) GO TO 40 + DO i = 1,M + WDOT = WDOT + DX(i)*DY(i) + END DO + IF (N .LT. 5) RETURN + 40 MP1 = M + 1 + DO i = MP1,N,5 + WDOT = WDOT + DX(i)*DY(i) + DX(i+1)*DY(i+1) + DX(i+2)*DY(i+2) + & + DX(i+3)*DY(i+3) + DX(i+4)*DY(i+4) + END DO + RETURN +! +! Code for equal, positive, non-unit increments. +! + 60 NS = N*incX + DO i = 1,NS,incX + WDOT = WDOT + DX(i)*DY(i) + END DO + + END FUNCTION WDOT + + +!-------------------------------------------------------------- + SUBROUTINE WADD(N,X,Y,Z) +!-------------------------------------------------------------- +! adds two vectors: z <- x + y +! BLAS - like +!-------------------------------------------------------------- +! USE gckpp_adj_Precision + + INTEGER :: i, M, MP1, N + REAL(kind=dp) :: X(N),Y(N),Z(N) + + IF (N.LE.0) RETURN + + M = MOD(N,5) + IF( M /= 0 ) THEN + DO i = 1,M + Z(i) = X(i) + Y(i) + END DO + IF( N < 5 ) RETURN + END IF + MP1 = M+1 + DO i = MP1,N,5 + Z(i) = X(i) + Y(i) + Z(i + 1) = X(i + 1) + Y(i + 1) + Z(i + 2) = X(i + 2) + Y(i + 2) + Z(i + 3) = X(i + 3) + Y(i + 3) + Z(i + 4) = X(i + 4) + Y(i + 4) + END DO + + END SUBROUTINE WADD + + + +!-------------------------------------------------------------- + SUBROUTINE WGEFA(N,A,Ipvt,info) +!-------------------------------------------------------------- +! WGEFA FACTORS THE MATRIX A (N,N) BY +! GAUSS ELIMINATION WITH PARTIAL PIVOTING +! LINPACK - LIKE +!-------------------------------------------------------------- +! + INTEGER :: N,Ipvt(N),info + REAL(kind=dp) :: A(N,N) + REAL(kind=dp) :: t, dmax, da + INTEGER :: j,k,l + REAL(kind=dp), PARAMETER :: ZERO = 0.0, ONE = 1.0 + + info = 0 + +size: IF (n > 1) THEN + +col: DO k = 1, n-1 + +! find l = pivot index +! l = idamax(n-k+1,A(k,k),1) + k - 1 + l = k; dmax = abs(A(k,k)) + DO j = k+1,n + da = ABS(A(j,k)) + IF (da > dmax) THEN + l = j; dmax = da + END IF + END DO + Ipvt(k) = l + +! zero pivot implies this column already triangularized + IF (ABS(A(l,k)) < TINY(ZERO)) THEN + info = k + return + ELSE + IF (l /= k) THEN + t = A(l,k); A(l,k) = A(k,k); A(k,k) = t + END IF + t = -ONE/A(k,k) + CALL WSCAL(n-k,t,A(k+1,k),1) + DO j = k+1, n + t = A(l,j) + IF (l /= k) THEN + A(l,j) = A(k,j); A(k,j) = t + END IF + CALL WAXPY(n-k,t,A(k+1,k),1,A(k+1,j),1) + END DO + END IF + + END DO col + + END IF size + + Ipvt(N) = N + IF (ABS(A(N,N)) == ZERO) info = N + + END SUBROUTINE WGEFA + + +!-------------------------------------------------------------- + SUBROUTINE WGESL(Trans,N,A,Ipvt,b) +!-------------------------------------------------------------- +! WGESL solves the system +! a * x = b or trans(a) * x = b +! using the factors computed by WGEFA. +! +! Trans = 'N' to solve A*x = b , +! = 'T' to solve transpose(A)*x = b +! LINPACK - LIKE +!-------------------------------------------------------------- + + INTEGER :: N,Ipvt(N) + CHARACTER :: trans + REAL(kind=dp) :: A(N,N),b(N) + REAL(kind=dp) :: t + INTEGER :: k,kb,l + + + SELECT CASE (Trans) + + CASE ('n','N') ! Solve A * x = b + +! first solve L*y = b + IF (n >= 2) THEN + DO k = 1, n-1 + l = Ipvt(k) + t = b(l) + IF (l /= k) THEN + b(l) = b(k) + b(k) = t + END IF + CALL WAXPY(n-k,t,a(k+1,k),1,b(k+1),1) + END DO + END IF +! now solve U*x = y + DO kb = 1, n + k = n + 1 - kb + b(k) = b(k)/a(k,k) + t = -b(k) + CALL WAXPY(k-1,t,a(1,k),1,b(1),1) + END DO + + CASE ('t','T') ! Solve transpose(A) * x = b + +! first solve trans(U)*y = b + DO k = 1, n + t = WDOT(k-1,a(1,k),1,b(1),1) + b(k) = (b(k) - t)/a(k,k) + END DO +! now solve trans(L)*x = y + IF (n >= 2) THEN + DO kb = 1, n-1 + k = n - kb + b(k) = b(k) + WDOT(n-k,a(k+1,k),1,b(k+1),1) + l = Ipvt(k) + IF (l /= k) THEN + t = b(l); b(l) = b(k); b(k) = t + END IF + END DO + END IF + + END SELECT + + END SUBROUTINE WGESL +! End of BLAS_UTIL function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +END MODULE gckpp_adj_LinearAlgebra + diff --git a/code/adjoint/gckpp_adj_Model.f90 b/code/adjoint/gckpp_adj_Model.f90 new file mode 100644 index 0000000..32231a1 --- /dev/null +++ b/code/adjoint/gckpp_adj_Model.f90 @@ -0,0 +1,22 @@ +MODULE gckpp_adj_Model + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Completely defines the model gckpp_adj +! by using all the associated modules +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE gckpp_adj_Precision + USE gckpp_adj_Parameters + USE gckpp_adj_Global + USE gckpp_adj_Function + USE gckpp_adj_Integrator + USE gckpp_adj_Rates + USE gckpp_adj_Jacobian + USE gckpp_adj_Hessian + USE gckpp_adj_Stoichiom + USE gckpp_adj_LinearAlgebra + USE gckpp_adj_Monitor + USE gckpp_adj_Util + +END MODULE gckpp_adj_Model + diff --git a/code/adjoint/gckpp_adj_Monitor.f90 b/code/adjoint/gckpp_adj_Monitor.f90 new file mode 100644 index 0000000..c1830ac --- /dev/null +++ b/code/adjoint/gckpp_adj_Monitor.f90 @@ -0,0 +1,414 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Utility Data Module File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Monitor.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_Monitor + + + CHARACTER(LEN=12), PARAMETER, DIMENSION(90) :: SPC_NAMES_0 = (/ & + 'DRYCH2O ','DRYH2O2 ','DRYHNO3 ', & + 'DRYN2O5 ','DRYNO2 ','DRYO3 ', & + 'DRYPAN ','DRYPMN ','DRYPPN ', & + 'DRYR4N2 ','SO4 ','MSA ', & + 'CO2 ','DRYDEP ','LISOPOH ', & + 'C3H8 ','H2O2 ','PPN ', & + 'GPAN ','SO2 ','PAN ', & + 'ALK4 ','C2H6 ','HNO2 ', & + 'N2O5 ','MAOP ','MAP ', & + 'MP ','HNO4 ','R4P ', & + 'RA3P ','RB3P ','RP ', & + 'DMS ','ETP ','GP ', & + 'PP ','PRPN ','INPN ', & + 'MRP ','IAP ','VRP ', & + 'ISNP ','PMN ','RIP ', & + 'ISOP ','CO ','PRPE ', & + 'ACET ','GLYC ','MVN2 ', & + 'A3O2 ','B3O2 ','R4N1 ', & + 'MAN2 ','HNO3 ','RIO1 ', & + 'IALD ','MRO2 ','KO2 ', & + 'HAC ','ATO2 ','PRN1 ', & + 'VRO2 ','ISN1 ','IAO2 ', & + 'INO2 ','RCHO ','CH2O ', & + 'PO2 ','ALD2 ','R4O2 ', & + 'R4N2 ','ETO2 ','MGLY ', & + 'MEK ','MVK ','MAO3 ', & + 'RIO2 ','MACR ','RCO3 ', & + 'NO2 ','OH ','HO2 ', & + 'NO ','MCO3 ','NO3 ', & + 'GCO3 ','O3 ','MO2 ' /) + CHARACTER(LEN=12), PARAMETER, DIMENSION(16) :: SPC_NAMES_1 = (/ & + 'ACTA ','CH4 ','EMISSION ', & + 'EOH ','GLCO3 ','GLP ', & + 'GLPAN ','GLYX ','H2 ', & + 'H2O ','HCOOH ','MNO3 ', & + 'MOH ','O2 ','RCOOH ', & + 'ROH ' /) + CHARACTER(LEN=12), PARAMETER, DIMENSION(106) :: SPC_NAMES = (/& + SPC_NAMES_0, SPC_NAMES_1 /) + + INTEGER, PARAMETER, DIMENSION(106) :: LOOKAT = (/ & + 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, & + 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, & + 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, & + 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, & + 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, & + 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, & + 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, & + 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, & + 97, 98, 99,100,101,102,103,104,105,106 /) + + INTEGER, DIMENSION(1) :: MONITOR + CHARACTER(LEN=12), DIMENSION(1) :: SMASS + CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_0 = (/ & + ' NO + O3 --> NO2 + O2 ', & + ' OH + O3 --> HO2 + O2 ', & + ' HO2 + O3 --> OH + 2 O2 ', & + ' NO2 + O3 --> NO3 + O2 ', & + ' O3 + MO2 --> CH2O + HO2 + 2 O2 ', & + ' 2 OH --> O3 + H2O ', & + ' 2 OH --> H2O2 ', & + ' OH + HO2 --> H2O + O2 ', & + ' H2O2 + OH --> HO2 + H2O ', & + ' HO2 + NO --> NO2 + OH ', & + ' 2 HO2 --> H2O2 ', & + ' OH + H2 --> HO2 + H2O ', & + ' CO + OH --> CO2 + HO2 ', & + ' OH + CH4 --> MO2 + H2O ', & + ' NO + MO2 --> CH2O + NO2 + HO2 ', & + ' HO2 + MO2 --> MP + O2 ', & + ' 2 MO2 --> CH2O + MOH + O2 ', & + ' 2 MO2 --> 2 CH2O + 2 HO2 ', & + ' MP + OH --> MO2 + H2O ', & + ' MP + OH --> CH2O + OH + H2O ', & + ' CH2O + OH --> CO + HO2 + H2O ', & + ' NO2 + OH --> HNO3 ', & + ' HNO3 + OH --> NO3 + H2O ', & + ' OH + NO --> HNO2 ', & + ' HNO2 + OH --> NO2 + H2O ', & + ' NO2 + HO2 --> HNO4 ', & + ' HNO4 --> NO2 + HO2 ', & + ' HNO4 + OH --> NO2 + H2O + O2 ', & + ' HO2 + NO3 --> NO2 + OH + O2 ', & + ' NO + NO3 --> 2 NO2 ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_1 = (/ & + ' OH + NO3 --> NO2 + HO2 ', & + ' NO2 + NO3 --> N2O5 ', & + ' N2O5 --> NO2 + NO3 ', & + ' OH + HCOOH --> CO2 + HO2 + H2O ', & + ' OH + MOH --> CH2O + HO2 ', & + ' NO2 + NO3 --> NO2 + NO + O2 ', & + ' CH2O + NO3 --> CO + HNO3 + HO2 ', & + ' ALD2 + OH --> 0.05 CO + 0.05 CH2O + 0.05 HO2 + 0.95 MCO3 ', & + ' ALD2 + NO3 --> HNO3 + MCO3 ', & + ' NO2 + MCO3 --> PAN ', & + ' PAN --> NO2 + MCO3 ', & + ' NO + MCO3 --> CO2 + NO2 + MO2 ', & + ' C2H6 + OH --> ETO2 + H2O ', & + ' ETO2 + NO --> ALD2 + NO2 + HO2 ', & + ' C3H8 + OH --> B3O2 ', & + ' C3H8 + OH --> A3O2 ', & + ' A3O2 + NO --> RCHO + NO2 + HO2 ', & + ' PO2 + NO --> CH2O + ALD2 + NO2 + HO2 ', & + ' ALK4 + OH --> R4O2 ', & + ' R4O2 + NO --> 0.32 ACET + 0.05 A3O2 + 0.18 B3O2 + 0.13 RCHO + 0.32 ALD2 ... etc. ', & + ' R4O2 + NO --> R4N2 ', & + ' R4N1 + NO --> 0.57 RCHO + 0.39 CH2O + 0.75 ALD2 + 0.3 R4O2 + 2 NO2 ... etc. ', & + ' ATO2 + NO --> 0.96 CH2O + 0.04 R4N2 + 0.96 NO2 + 0.96 MCO3 ', & + ' KO2 + NO --> 0.93 ALD2 + 0.07 R4N2 + 0.93 NO2 + 0.93 MCO3 ', & + ' RIO2 + NO --> 0.1 HNO3 + 0.34 IALD + 0.56 CH2O + 0.34 MVK + 0.22 MACR ... etc. ', & + ' RIO2 + NO --> HNO3 ', & + ' RIO1 + NO --> IALD + 0.75 CH2O + NO2 + HO2 ', & + ' RIO1 + NO --> HNO3 ', & + ' IAO2 + NO --> 0.61 CO + 0.24 GLYC + 0.08 HNO3 + 0.33 HAC + 0.35 CH2O ... etc. ', & + ' ISN1 + NO --> 0.95 GLYC + 0.05 HNO3 + 0.95 HAC + 1.95 NO2 + 0.05 HO2 ... etc. ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_2 = (/ & + ' VRO2 + NO --> 0.72 GLYC + 0.28 CH2O + 0.28 MGLY + NO2 + 0.28 HO2 + 0.72 MCO3 ... etc. ', & + ' VRO2 + NO --> HNO3 ', & + ' MRO2 + NO --> HAC + CH2O + NO2 + HO2 ', & + ' MRO2 + NO --> HNO3 ', & + ' MVN2 + NO --> 0.6 GLYC + 0.1 HNO3 + 0.3 CH2O + 0.3 MGLY + 1.9 NO2 ... etc. ', & + ' MAN2 + NO --> CH2O + MGLY + 2 NO2 ', & + ' B3O2 + NO --> ACET + NO2 + HO2 ', & + ' INO2 + NO --> 0.85 HNO3 + 0.15 CH2O + 0.05 MVK + 0.1 MACR + 1.15 NO2 ... etc. ', & + ' PRN1 + NO --> CH2O + ALD2 + 2 NO2 ', & + ' ALK4 + NO3 --> HNO3 + R4O2 ', & + ' R4N2 + OH --> R4N1 + H2O ', & + ' OH + ACTA --> CO2 + MO2 + H2O ', & + ' RCHO + OH --> RCO3 + H2O ', & + ' RCO3 + NO2 --> PPN ', & + ' PPN --> RCO3 + NO2 ', & + ' NO2 + GCO3 --> GPAN ', & + ' GPAN --> NO2 + GCO3 ', & + ' MAO3 + NO2 --> PMN ', & + ' PMN --> MAO3 + NO2 ', & + ' NO2 + GLCO3 --> GLPAN ', & + ' GLPAN --> NO2 + GLCO3 ', & + ' RCO3 + NO --> ETO2 + NO2 ', & + ' NO + GCO3 --> CH2O + NO2 + HO2 ', & + ' MAO3 + NO --> CH2O + NO2 + MCO3 ', & + ' NO + GLCO3 --> CO + NO2 + HO2 ', & + ' RCHO + NO3 --> HNO3 + RCO3 ', & + ' ACET + OH --> ATO2 + H2O ', & + ' ACET + OH --> ATO2 + H2O ', & + ' A3O2 + MO2 --> 0.75 RCHO + 0.75 CH2O + HO2 + 0.25 MOH + 0.25 ROH ', & + ' PO2 + MO2 --> 0.16 HAC + 0.09 RCHO + 1.25 CH2O + 0.5 ALD2 + HO2 + 0.25 MOH ... etc. ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_3 = (/ & + ' R4O2 + HO2 --> R4P ', & + ' R4N1 + HO2 --> R4N2 ', & + ' ATO2 + HO2 --> MCO3 + MO2 ', & + ' KO2 + HO2 --> MGLY + MO2 ', & + ' RIO2 + HO2 --> RIP ', & + ' RIO1 + HO2 --> RIP ', & + ' IAO2 + HO2 --> IAP ', & + ' ISN1 + HO2 --> ISNP ', & + ' VRO2 + HO2 --> VRP ', & + ' MRO2 + HO2 --> MRP ', & + ' MVN2 + HO2 --> ISNP ', & + ' MAN2 + HO2 --> ISNP ', & + ' B3O2 + HO2 --> RB3P ', & + ' INO2 + HO2 --> INPN ', & + ' PRN1 + HO2 --> PRPN ', & + ' MEK + OH --> KO2 + H2O ', & + ' ETO2 + MO2 --> 0.75 CH2O + 0.75 ALD2 + HO2 + 0.25 EOH + 0.25 MOH ', & + ' MEK + NO3 --> HNO3 + KO2 ', & + ' R4O2 + MO2 --> 0.16 ACET + 0.03 A3O2 + 0.09 B3O2 + 0.07 RCHO + 0.75 CH2O ... etc. ', & + ' R4N1 + MO2 --> 0.54 RCHO + 0.95 CH2O + 0.38 ALD2 + 0.15 R4O2 + NO2 ... etc. ', & + ' ATO2 + MO2 --> 0.2 HAC + 0.5 CH2O + 0.5 MGLY + 0.3 HO2 + 0.3 MCO3 + 0.5 MOH ... etc. ', & + ' KO2 + MO2 --> 0.75 CH2O + 0.5 ALD2 + 0.25 MEK + 0.5 HO2 + 0.5 MCO3 ... etc. ', & + ' RIO2 + MO2 --> 0.07 RIO1 + 0.06 IALD + 1.1 CH2O + 0.25 MEK + 0.2 MVK ... etc. ', & + ' RIO1 + MO2 --> 0.5 IALD + 1.13 CH2O + 0.25 MEK + HO2 + 0.25 MOH + 0.25 ROH ... etc. ', & + ' IAO2 + MO2 --> 0.33 CO + 0.13 GLYC + 0.18 HAC + 0.95 CH2O + 0.29 MGLY ... etc. ', & + ' ISN1 + MO2 --> 0.5 GLYC + 0.5 HAC + 0.25 RCHO + 0.75 CH2O + NO2 + 0.5 HO2 ... etc. ', & + ' VRO2 + MO2 --> 0.36 GLYC + 0.89 CH2O + 0.14 MGLY + 0.25 MEK + 0.64 HO2 ... etc. ', & + ' MRO2 + MO2 --> 0.15 CO + HAC + 0.85 CH2O + 1.15 HO2 ', & + ' MVN2 + MO2 --> 0.25 RCHO + 1.25 CH2O + 0.25 MGLY + NO2 + 0.75 HO2 + 0.25 MCO3 ... etc. ', & + ' MAN2 + MO2 --> 0.25 RCHO + 1.25 CH2O + 0.5 MGLY + NO2 + 0.5 HO2 + 0.25 MOH ... etc. ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_4 = (/ & + ' B3O2 + MO2 --> 0.75 ACET + 0.75 CH2O + HO2 + 0.25 MOH + 0.25 ROH ', & + ' INO2 + MO2 --> 0.425 HNO3 + 0.25 RCHO + 0.83 CH2O + 0.03 MVK + 0.05 MACR ... etc. ', & + ' PRN1 + MO2 --> 0.25 RCHO + 1.25 CH2O + 0.5 ALD2 + NO2 + 0.5 HO2 + 0.25 MOH ... etc. ', & + ' OH + EOH --> ALD2 + HO2 ', & + ' OH + ROH --> RCHO + HO2 ', & + ' 2 ETO2 --> 2 ALD2 + 2 HO2 ', & + ' 2 ETO2 --> ALD2 + EOH ', & + ' ETO2 + HO2 --> ETP ', & + ' A3O2 + HO2 --> RA3P ', & + ' PO2 + HO2 --> PP ', & + ' HO2 + MCO3 --> 0.41 MAP + 0.44 OH + 0.15 O3 + 0.44 MO2 + 0.15 ACTA ... etc. ', & + ' RCO3 + HO2 --> 0.7 RP + 0.3 O3 + 0.3 RCOOH ', & + ' HO2 + GCO3 --> 0.71 GP + 0.29 CH2O + 0.29 O3 ', & + ' MAO3 + HO2 --> 0.7 MAOP + 0.3 O3 + 0.3 RCOOH ', & + ' HO2 + GLCO3 --> 0.3 O3 + 0.7 GLP + 0.3 RCOOH ', & + ' PRPE + OH --> PO2 ', & + ' PRPE + O3 --> 0.42 CO + 0.535 CH2O + 0.5 ALD2 + 0.135 OH + 0.3 HO2 ... etc. ', & + ' PMN + OH --> 0.59 HAC + 2.23 CH2O + NO2 + 2 HO2 ', & + ' PMN + O3 --> 0.6 CH2O + NO2 + HO2 ', & + ' GLYC + OH --> 0.4 CO + 0.2 HO2 + 0.8 GCO3 + 0.2 H2 ', & + ' PRPE + NO3 --> PRN1 ', & + ' OH + GLYX --> 2 CO + HO2 ', & + ' MGLY + OH --> CO + MCO3 ', & + ' NO3 + GLYX --> 2 CO + HNO3 + HO2 ', & + ' MGLY + NO3 --> CO + HNO3 + MCO3 ', & + ' ISOP + OH --> LISOPOH + RIO2 ', & + ' MVK + OH --> VRO2 ', & + ' MACR + OH --> 0.43 MRO2 + 0.57 MAO3 ', & + ' HAC + OH --> MGLY + HO2 ', & + ' A3O2 + MCO3 --> RCHO + HO2 + MO2 ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_5 = (/ & + ' PO2 + MCO3 --> CH2O + ALD2 + HO2 + MO2 ', & + ' A3O2 + MCO3 --> RCHO + ACTA ', & + ' PO2 + MCO3 --> 0.65 HAC + 0.35 RCHO + ACTA ', & + ' ISOP + O3 --> 0.15 CO2 + 0.05 CO + 0.07 PRPE + 0.9 CH2O + 0.159 MVK ... etc. ', & + ' MVK + O3 --> 0.05 CO + 0.8 CH2O + 0.04 ALD2 + 0.82 MGLY + 0.08 OH ... etc. ', & + ' MACR + O3 --> 0.16 CO2 + 0.2 CO + 0.7 CH2O + 0.8 MGLY + 0.215 OH + 0.275 HO2 ... etc. ', & + ' ISOP + NO3 --> INO2 ', & + ' MACR + NO3 --> MAN2 ', & + ' MACR + NO3 --> HNO3 + MAO3 ', & + ' RCO3 + MO2 --> CH2O + ETO2 + HO2 ', & + ' GCO3 + MO2 --> 2 CH2O + 2 HO2 ', & + ' MAO3 + MO2 --> 2 CH2O + HO2 + MCO3 ', & + ' MO2 + GLCO3 --> CO + CH2O + 2 HO2 ', & + ' RCO3 + MO2 --> CH2O + RCOOH ', & + ' GCO3 + MO2 --> CH2O + RCOOH ', & + ' MAO3 + MO2 --> CH2O + RCOOH ', & + ' MO2 + GLCO3 --> CH2O + RCOOH ', & + ' INPN + OH --> INO2 ', & + ' PRPN + OH --> PRN1 ', & + ' ETP + OH --> 0.5 ALD2 + 0.5 ETO2 + 0.5 OH ', & + ' RA3P + OH --> 0.5 A3O2 + 0.5 RCHO + 0.5 OH ', & + ' RB3P + OH --> 0.5 ACET + 0.5 B3O2 + 0.5 OH ', & + ' R4P + OH --> 0.5 RCHO + 0.5 R4O2 + 0.5 OH ', & + ' RP + OH --> 0.5 ALD2 + 0.5 RCO3 + 0.5 OH ', & + ' PP + OH --> PO2 ', & + ' GP + OH --> GCO3 ', & + ' OH + GLP --> 0.5 CO + 0.5 OH + 0.5 GLCO3 ', & + ' RIP + OH --> 0.509 IALD + 0.491 RIO2 + 0.509 OH ', & + ' IAP + OH --> IAO2 ', & + ' ISNP + OH --> 0.5 ISN1 + 0.5 RCHO + 0.5 NO2 + 0.5 OH ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_6 = (/ & + ' VRP + OH --> 0.5 VRO2 + 0.5 RCHO + 0.5 OH ', & + ' MRP + OH --> MRO2 ', & + ' MAOP + OH --> MAO3 ', & + ' MAP + OH --> 0.5 CH2O + 0.5 OH + 0.5 MCO3 ', & + ' C2H6 + NO3 --> HNO3 + ETO2 ', & + ' OH + MNO3 --> CH2O + NO2 ', & + ' IALD + OH --> 0.44 IAO2 + 0.41 MAO3 + 0.15 HO2 ', & + ' IALD + O3 --> 0.4 CO + 0.28 GLYC + 0.2 HAC + 0.12 CH2O + 0.6 MGLY ... etc. ', & + ' 2 MCO3 --> 2 MO2 ', & + ' MCO3 + MO2 --> CH2O + HO2 + MO2 ', & + ' MCO3 + MO2 --> CH2O + ACTA ', & + ' R4O2 + MCO3 --> 0.32 ACET + 0.05 A3O2 + 0.18 B3O2 + 0.13 RCHO + 0.32 ALD2 ... etc. ', & + ' ATO2 + MCO3 --> 0.2 CH2O + 0.8 MGLY + 0.8 HO2 + 0.2 MCO3 + MO2 ', & + ' KO2 + MCO3 --> ALD2 + MCO3 + MO2 ', & + ' RIO2 + MCO3 --> 0.136 RIO1 + 0.127 IALD + 0.69 CH2O + 0.402 MVK + 0.288 MACR ... etc. ', & + ' RIO1 + MCO3 --> IALD + 0.75 CH2O + HO2 + MO2 ', & + ' IAO2 + MCO3 --> 0.65 CO + 0.26 GLYC + 0.36 HAC + 0.4 CH2O + 0.58 MGLY ... etc. ', & + ' ISN1 + MCO3 --> GLYC + HAC + NO2 + MO2 ', & + ' VRO2 + MCO3 --> 0.72 GLYC + 0.28 CH2O + 0.28 MGLY + 0.28 HO2 + 0.72 MCO3 ... etc. ', & + ' MRO2 + MCO3 --> 0.83 CO + 0.83 HAC + 0.17 CH2O + 0.17 MGLY + HO2 + MO2 ... etc. ', & + ' B3O2 + MCO3 --> ACET + HO2 + MO2 ', & + ' R4N1 + MCO3 --> 0.57 RCHO + 0.39 CH2O + 0.75 ALD2 + 0.3 R4O2 + NO2 + MO2 ... etc. ', & + ' MVN2 + MCO3 --> CH2O + 0.5 MGLY + NO2 + 0.5 HO2 + 0.5 MCO3 + MO2 ', & + ' MAN2 + MCO3 --> CH2O + MGLY + NO2 + MO2 ', & + ' INO2 + MCO3 --> 0.85 HNO3 + 0.15 CH2O + 0.05 MVK + 0.1 MACR + 0.15 NO2 ... etc. ', & + ' PRN1 + MCO3 --> CH2O + ALD2 + NO2 + MO2 ', & + ' R4O2 + MCO3 --> MEK + ACTA ', & + ' ATO2 + MCO3 --> MEK + ACTA ', & + ' KO2 + MCO3 --> MEK + ACTA ', & + ' RIO2 + MCO3 --> MEK + ACTA ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_7 = (/ & + ' RIO1 + MCO3 --> MEK + ACTA ', & + ' IAO2 + MCO3 --> MEK + ACTA ', & + ' VRO2 + MCO3 --> MEK + ACTA ', & + ' MRO2 + MCO3 --> MEK + ACTA ', & + ' R4N1 + MCO3 --> RCHO + NO2 + ACTA ', & + ' ISN1 + MCO3 --> RCHO + NO2 + ACTA ', & + ' MVN2 + MCO3 --> RCHO + NO2 + ACTA ', & + ' MAN2 + MCO3 --> RCHO + NO2 + ACTA ', & + ' INO2 + MCO3 --> RCHO + NO2 + ACTA ', & + ' PRN1 + MCO3 --> RCHO + NO2 + ACTA ', & + ' B3O2 + MCO3 --> ACET + ACTA ', & + ' ETO2 + MCO3 --> ALD2 + HO2 + MO2 ', & + ' ETO2 + MCO3 --> ALD2 + ACTA ', & + ' RCO3 + MCO3 --> ETO2 + MO2 ', & + ' MCO3 + GCO3 --> CH2O + HO2 + MO2 ', & + ' MAO3 + MCO3 --> CH2O + MCO3 + MO2 ', & + 'MCO3 + GLCO3 --> CO + HO2 + MO2 ', & + ' 2 NO3 --> 2 NO2 + O2 ', & + ' EMISSION --> NO ', & + ' EMISSION --> NO2 ', & + ' EMISSION --> CO ', & + ' EMISSION --> ALK4 ', & + ' EMISSION --> ISOP ', & + ' EMISSION --> ACET ', & + ' EMISSION --> PRPE ', & + ' EMISSION --> C3H8 ', & + ' EMISSION --> C2H6 ', & + ' EMISSION --> MEK ', & + ' EMISSION --> ALD2 ', & + ' EMISSION --> CH2O ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_8 = (/ & + ' EMISSION --> O3 ', & + ' EMISSION --> HNO3 ', & + ' NO2 --> DRYNO2 + DRYDEP ', & + ' O3 --> DRYO3 + DRYDEP ', & + ' PAN --> DRYPAN + DRYDEP ', & + ' HNO3 --> DRYHNO3 + DRYDEP ', & + ' CH2O --> DRYCH2O + DRYDEP ', & + ' N2O5 --> DRYN2O5 + DRYDEP ', & + ' H2O2 --> DRYH2O2 + DRYDEP ', & + ' PMN --> DRYPMN + DRYDEP ', & + ' PPN --> DRYPPN + DRYDEP ', & + ' R4N2 --> DRYR4N2 + DRYDEP ', & + ' HO2 --> 0.5 H2O2 ', & + ' NO2 --> 0.5 HNO2 + 0.5 HNO3 ', & + ' NO3 --> HNO3 ', & + ' N2O5 --> 2 HNO3 ', & + ' DMS + OH --> SO2 + CH2O + MO2 ', & + ' DMS + OH --> 0.25 MSA + 0.75 SO2 + MO2 ', & + ' DMS + NO3 --> SO2 + HNO3 + CH2O + MO2 ', & + ' SO2 + OH --> SO4 + HO2 ', & + ' O3 --> 2 OH ', & + ' NO2 --> NO + O3 ', & + ' H2O2 --> 2 OH ', & + ' MP --> CH2O + OH + HO2 ', & + ' CH2O --> CO + 2 HO2 ', & + ' CH2O --> CO + H2 ', & + ' HNO3 --> NO2 + OH ', & + ' HNO2 --> OH + NO ', & + ' HNO4 --> OH + NO3 ', & + ' NO3 --> NO2 + O3 ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_9 = (/ & + ' NO3 --> NO + O2 ', & + ' N2O5 --> NO2 + NO3 ', & + ' N2O5 --> NO + NO3 + O3 ', & + ' HNO4 --> NO2 + HO2 ', & + ' ALD2 --> CO + HO2 + MO2 ', & + ' ALD2 --> CO + CH4 ', & + ' PAN --> 0.6 NO2 + 0.6 MCO3 + 0.4 NO3 + 0.4 MO2 ', & + ' RCHO --> CO + ETO2 + HO2 ', & + ' ACET --> MCO3 + MO2 ', & + ' ACET --> CO + 2 MO2 ', & + ' MEK --> 0.85 ETO2 + 0.15 RCO3 + 0.85 MCO3 + 0.15 MO2 ', & + ' MNO3 --> CH2O + NO2 + H2O ', & + ' GLYC --> CO + CH2O + 2 HO2 ', & + ' GLYX --> 1.5 CO + 0.5 CH2O + 0.5 H2 ', & + ' GLYX --> 2 CO + 2 HO2 ', & + ' MGLY --> CO + HO2 + MCO3 ', & + ' MGLY --> CO + ALD2 ', & + ' MVK --> CO + PRPE ', & + ' MVK --> CO + CH2O + HO2 + MCO3 ', & + ' MVK --> MAO3 + MO2 ', & + ' MACR --> MAO3 + HO2 ', & + ' MACR --> CO + CH2O + HO2 + MCO3 ', & + ' HAC --> CH2O + HO2 + MCO3 ', & + ' INPN --> RCHO + NO2 + OH + HO2 ', & + ' PRPN --> RCHO + NO2 + OH + HO2 ', & + ' ETP --> ALD2 + OH + HO2 ', & + ' RA3P --> RCHO + OH + HO2 ', & + ' RB3P --> ACET + OH + HO2 ', & + ' R4P --> RCHO + OH + HO2 ', & + ' PP --> CH2O + ALD2 + OH + HO2 ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(11) :: EQN_NAMES_10 = (/ & + ' RP --> ALD2 + OH + HO2 ', & + ' GP --> CH2O + OH + HO2 ', & + ' GLP --> CO + OH + HO2 ', & + ' RIP --> 0.373 IALD + 0.627 CH2O + 0.368 MVK + 0.259 MACR + OH ... etc. ', & + ' IAP --> 0.67 CO + 0.26 GLYC + 0.36 HAC + 0.58 MGLY + OH + HO2 ... etc. ', & + ' ISNP --> RCHO + NO2 + OH + HO2 ', & + ' VRP --> 0.7 GLYC + 0.3 CH2O + 0.3 MGLY + OH + 0.3 HO2 + 0.7 MCO3 ... etc. ', & + ' MRP --> 0.5 CO + HAC + 0.5 CH2O + OH + HO2 ', & + ' MAOP --> CH2O + OH + MCO3 ', & + ' R4N2 --> 0.32 ACET + 0.05 A3O2 + 0.18 B3O2 + 0.13 RCHO + 0.32 ALD2 ... etc. ', & + ' MAP --> OH + MO2 ' /) + CHARACTER(LEN=100), PARAMETER, DIMENSION(311) :: EQN_NAMES = (/& + EQN_NAMES_0, EQN_NAMES_1, EQN_NAMES_2, EQN_NAMES_3, EQN_NAMES_4, & + EQN_NAMES_5, EQN_NAMES_6, EQN_NAMES_7, EQN_NAMES_8, EQN_NAMES_9, & + EQN_NAMES_10 /) + +! INLINED global variables + +! End INLINED global variables + + +END MODULE gckpp_adj_Monitor diff --git a/code/adjoint/gckpp_adj_Parameters.f90 b/code/adjoint/gckpp_adj_Parameters.f90 new file mode 100644 index 0000000..4b64511 --- /dev/null +++ b/code/adjoint/gckpp_adj_Parameters.f90 @@ -0,0 +1,204 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Parameter Module File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Parameters.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_Parameters + + USE gckpp_adj_Precision + PUBLIC + SAVE + + +! NSPEC - Number of chemical species + INTEGER, PARAMETER :: NSPEC = 106 +! NVAR - Number of Variable species + INTEGER, PARAMETER :: NVAR = 90 +! NVARACT - Number of Active species + INTEGER, PARAMETER :: NVARACT = 75 +! NFIX - Number of Fixed species + INTEGER, PARAMETER :: NFIX = 16 +! NREACT - Number of reactions + INTEGER, PARAMETER :: NREACT = 311 +! NVARST - Starting of variables in conc. vect. + INTEGER, PARAMETER :: NVARST = 1 +! NFIXST - Starting of fixed in conc. vect. + INTEGER, PARAMETER :: NFIXST = 91 +! NONZERO - Number of nonzero entries in Jacobian + INTEGER, PARAMETER :: NONZERO = 901 +! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian + INTEGER, PARAMETER :: LU_NONZERO = 1042 +! CNVAR - (NVAR+1) Number of elements in compressed row format + INTEGER, PARAMETER :: CNVAR = 91 +! CNEQN - (NREACT+1) Number stoicm elements in compressed col format + INTEGER, PARAMETER :: CNEQN = 312 +! NHESS - Length of Sparse Hessian + INTEGER, PARAMETER :: NHESS = 855 +! NLOOKAT - Number of species to look at + INTEGER, PARAMETER :: NLOOKAT = 106 +! NMONITOR - Number of species to monitor + INTEGER, PARAMETER :: NMONITOR = 0 +! NMASS - Number of atoms to check mass balance + INTEGER, PARAMETER :: NMASS = 1 + +! Index declaration for variable species in C and VAR +! VAR(ind_spc) = C(ind_spc) + + INTEGER, PARAMETER :: ind_DRYCH2O = 1 + INTEGER, PARAMETER :: ind_DRYH2O2 = 2 + INTEGER, PARAMETER :: ind_DRYHNO3 = 3 + INTEGER, PARAMETER :: ind_DRYN2O5 = 4 + INTEGER, PARAMETER :: ind_DRYNO2 = 5 + INTEGER, PARAMETER :: ind_DRYO3 = 6 + INTEGER, PARAMETER :: ind_DRYPAN = 7 + INTEGER, PARAMETER :: ind_DRYPMN = 8 + INTEGER, PARAMETER :: ind_DRYPPN = 9 + INTEGER, PARAMETER :: ind_DRYR4N2 = 10 + INTEGER, PARAMETER :: ind_SO4 = 11 + INTEGER, PARAMETER :: ind_MSA = 12 + INTEGER, PARAMETER :: ind_CO2 = 13 + INTEGER, PARAMETER :: ind_DRYDEP = 14 + INTEGER, PARAMETER :: ind_LISOPOH = 15 + INTEGER, PARAMETER :: ind_C3H8 = 16 + INTEGER, PARAMETER :: ind_H2O2 = 17 + INTEGER, PARAMETER :: ind_PPN = 18 + INTEGER, PARAMETER :: ind_GPAN = 19 + INTEGER, PARAMETER :: ind_SO2 = 20 + INTEGER, PARAMETER :: ind_PAN = 21 + INTEGER, PARAMETER :: ind_ALK4 = 22 + INTEGER, PARAMETER :: ind_C2H6 = 23 + INTEGER, PARAMETER :: ind_HNO2 = 24 + INTEGER, PARAMETER :: ind_N2O5 = 25 + INTEGER, PARAMETER :: ind_MAOP = 26 + INTEGER, PARAMETER :: ind_MAP = 27 + INTEGER, PARAMETER :: ind_MP = 28 + INTEGER, PARAMETER :: ind_HNO4 = 29 + INTEGER, PARAMETER :: ind_R4P = 30 + INTEGER, PARAMETER :: ind_RA3P = 31 + INTEGER, PARAMETER :: ind_RB3P = 32 + INTEGER, PARAMETER :: ind_RP = 33 + INTEGER, PARAMETER :: ind_DMS = 34 + INTEGER, PARAMETER :: ind_ETP = 35 + INTEGER, PARAMETER :: ind_GP = 36 + INTEGER, PARAMETER :: ind_PP = 37 + INTEGER, PARAMETER :: ind_PRPN = 38 + INTEGER, PARAMETER :: ind_INPN = 39 + INTEGER, PARAMETER :: ind_MRP = 40 + INTEGER, PARAMETER :: ind_IAP = 41 + INTEGER, PARAMETER :: ind_VRP = 42 + INTEGER, PARAMETER :: ind_ISNP = 43 + INTEGER, PARAMETER :: ind_PMN = 44 + INTEGER, PARAMETER :: ind_RIP = 45 + INTEGER, PARAMETER :: ind_ISOP = 46 + INTEGER, PARAMETER :: ind_CO = 47 + INTEGER, PARAMETER :: ind_PRPE = 48 + INTEGER, PARAMETER :: ind_ACET = 49 + INTEGER, PARAMETER :: ind_GLYC = 50 + INTEGER, PARAMETER :: ind_MVN2 = 51 + INTEGER, PARAMETER :: ind_A3O2 = 52 + INTEGER, PARAMETER :: ind_B3O2 = 53 + INTEGER, PARAMETER :: ind_R4N1 = 54 + INTEGER, PARAMETER :: ind_MAN2 = 55 + INTEGER, PARAMETER :: ind_HNO3 = 56 + INTEGER, PARAMETER :: ind_RIO1 = 57 + INTEGER, PARAMETER :: ind_IALD = 58 + INTEGER, PARAMETER :: ind_MRO2 = 59 + INTEGER, PARAMETER :: ind_KO2 = 60 + INTEGER, PARAMETER :: ind_HAC = 61 + INTEGER, PARAMETER :: ind_ATO2 = 62 + INTEGER, PARAMETER :: ind_PRN1 = 63 + INTEGER, PARAMETER :: ind_VRO2 = 64 + INTEGER, PARAMETER :: ind_ISN1 = 65 + INTEGER, PARAMETER :: ind_IAO2 = 66 + INTEGER, PARAMETER :: ind_INO2 = 67 + INTEGER, PARAMETER :: ind_RCHO = 68 + INTEGER, PARAMETER :: ind_CH2O = 69 + INTEGER, PARAMETER :: ind_PO2 = 70 + INTEGER, PARAMETER :: ind_ALD2 = 71 + INTEGER, PARAMETER :: ind_R4O2 = 72 + INTEGER, PARAMETER :: ind_R4N2 = 73 + INTEGER, PARAMETER :: ind_ETO2 = 74 + INTEGER, PARAMETER :: ind_MGLY = 75 + INTEGER, PARAMETER :: ind_MEK = 76 + INTEGER, PARAMETER :: ind_MVK = 77 + INTEGER, PARAMETER :: ind_MAO3 = 78 + INTEGER, PARAMETER :: ind_RIO2 = 79 + INTEGER, PARAMETER :: ind_MACR = 80 + INTEGER, PARAMETER :: ind_RCO3 = 81 + INTEGER, PARAMETER :: ind_NO2 = 82 + INTEGER, PARAMETER :: ind_OH = 83 + INTEGER, PARAMETER :: ind_HO2 = 84 + INTEGER, PARAMETER :: ind_NO = 85 + INTEGER, PARAMETER :: ind_MCO3 = 86 + INTEGER, PARAMETER :: ind_NO3 = 87 + INTEGER, PARAMETER :: ind_GCO3 = 88 + INTEGER, PARAMETER :: ind_O3 = 89 + INTEGER, PARAMETER :: ind_MO2 = 90 + +! Index declaration for fixed species in C +! C(ind_spc) + + INTEGER, PARAMETER :: ind_ACTA = 91 + INTEGER, PARAMETER :: ind_CH4 = 92 + INTEGER, PARAMETER :: ind_EMISSION = 93 + INTEGER, PARAMETER :: ind_EOH = 94 + INTEGER, PARAMETER :: ind_GLCO3 = 95 + INTEGER, PARAMETER :: ind_GLP = 96 + INTEGER, PARAMETER :: ind_GLPAN = 97 + INTEGER, PARAMETER :: ind_GLYX = 98 + INTEGER, PARAMETER :: ind_H2 = 99 + INTEGER, PARAMETER :: ind_H2O = 100 + INTEGER, PARAMETER :: ind_HCOOH = 101 + INTEGER, PARAMETER :: ind_MNO3 = 102 + INTEGER, PARAMETER :: ind_MOH = 103 + INTEGER, PARAMETER :: ind_O2 = 104 + INTEGER, PARAMETER :: ind_RCOOH = 105 + INTEGER, PARAMETER :: ind_ROH = 106 + +! Index declaration for fixed species in FIX +! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc) + + INTEGER, PARAMETER :: indf_ACTA = 1 + INTEGER, PARAMETER :: indf_CH4 = 2 + INTEGER, PARAMETER :: indf_EMISSION = 3 + INTEGER, PARAMETER :: indf_EOH = 4 + INTEGER, PARAMETER :: indf_GLCO3 = 5 + INTEGER, PARAMETER :: indf_GLP = 6 + INTEGER, PARAMETER :: indf_GLPAN = 7 + INTEGER, PARAMETER :: indf_GLYX = 8 + INTEGER, PARAMETER :: indf_H2 = 9 + INTEGER, PARAMETER :: indf_H2O = 10 + INTEGER, PARAMETER :: indf_HCOOH = 11 + INTEGER, PARAMETER :: indf_MNO3 = 12 + INTEGER, PARAMETER :: indf_MOH = 13 + INTEGER, PARAMETER :: indf_O2 = 14 + INTEGER, PARAMETER :: indf_RCOOH = 15 + INTEGER, PARAMETER :: indf_ROH = 16 + +! NJVRP - Length of sparse Jacobian JVRP + INTEGER, PARAMETER :: NJVRP = 491 + +! NSTOICM - Length of Sparse Stoichiometric Matrix + INTEGER, PARAMETER :: NSTOICM = 1259 + +END MODULE gckpp_adj_Parameters + diff --git a/code/adjoint/gckpp_adj_Precision.f90 b/code/adjoint/gckpp_adj_Precision.f90 new file mode 100644 index 0000000..91023ac --- /dev/null +++ b/code/adjoint/gckpp_adj_Precision.f90 @@ -0,0 +1,17 @@ + +MODULE gckpp_adj_Precision + +! +! Definition of different levels of accuracy +! for REAL variables using KIND parameterization +! +! KPP SP - Single precision kind + INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND(6,30) +! KPP DP - Double precision kind + INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14,300) +! KPP QP - Quadruple precision kind + INTEGER, PARAMETER :: qp = SELECTED_REAL_KIND(18,400) + +END MODULE gckpp_adj_Precision + + diff --git a/code/adjoint/gckpp_adj_Rates.f90 b/code/adjoint/gckpp_adj_Rates.f90 new file mode 100644 index 0000000..16c6fac --- /dev/null +++ b/code/adjoint/gckpp_adj_Rates.f90 @@ -0,0 +1,65 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! The Reaction Rates File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Rates.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_Rates + + USE gckpp_adj_Parameters + USE gckpp_adj_Global + IMPLICIT NONE + +CONTAINS + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Update_RCONST - function to update rate constants +! Arguments : +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE Update_RCONST ( ) + + USE COMODE_MOD, ONLY : R_KPP + USE gckpp_adj_Monitor + + INTEGER :: N + + DO N = 1, NREACT + RCONST(N) = R_KPP(JLOOP,IND(N)) + ENDDO + + !KLUDGE FIX for isoprene nitrate bug in globchem.dat: deactivate + ! RIO2 + NO --> HNO3 + ! (fp, dkh, 05/10/13) + ! Also, modify globchem.eqn to include 0.1 HNO3 from the + ! other RIO2 + NO, RCONST(55) + RCONST(56) = 0d0 + +END SUBROUTINE Update_RCONST + +! End of Update_RCONST function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +END MODULE gckpp_adj_Rates + diff --git a/code/adjoint/gckpp_adj_Stoichiom.f90 b/code/adjoint/gckpp_adj_Stoichiom.f90 new file mode 100644 index 0000000..fe0bb7f --- /dev/null +++ b/code/adjoint/gckpp_adj_Stoichiom.f90 @@ -0,0 +1,1506 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! The Stoichiometric Chemical Model File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Stoichiom.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_Stoichiom + + USE gckpp_adj_Parameters + USE gckpp_adj_StoichiomSP + + IMPLICIT NONE + +CONTAINS + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! ReactantProd - Reactant Products in each equation +! Arguments : +! V - Concentrations of variable species (local) +! F - Concentrations of fixed species (local) +! ARP - Reactant product in each equation +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE ReactantProd ( V, F, ARP ) + +! V - Concentrations of variable species (local) + REAL(kind=dp) :: V(NVAR) +! F - Concentrations of fixed species (local) + REAL(kind=dp) :: F(NFIX) +! ARP - Reactant product in each equation + REAL(kind=dp) :: ARP(NREACT) + + +! Reactant Products in each equation are useful in the +! stoichiometric formulation of mass action law + ARP(1) = V(85)*V(89) + ARP(2) = V(83)*V(89) + ARP(3) = V(84)*V(89) + ARP(4) = V(82)*V(89) + ARP(5) = V(89)*V(90) + ARP(6) = V(83)*V(83) + ARP(7) = V(83)*V(83) + ARP(8) = V(83)*V(84) + ARP(9) = V(17)*V(83) + ARP(10) = V(84)*V(85) + ARP(11) = V(84)*V(84) + ARP(12) = V(83)*F(9) + ARP(13) = V(47)*V(83) + ARP(14) = V(83)*F(2) + ARP(15) = V(85)*V(90) + ARP(16) = V(84)*V(90) + ARP(17) = V(90)*V(90) + ARP(18) = V(90)*V(90) + ARP(19) = V(28)*V(83) + ARP(20) = V(28)*V(83) + ARP(21) = V(69)*V(83) + ARP(22) = V(82)*V(83) + ARP(23) = V(56)*V(83) + ARP(24) = V(83)*V(85) + ARP(25) = V(24)*V(83) + ARP(26) = V(82)*V(84) + ARP(27) = V(29) + ARP(28) = V(29)*V(83) + ARP(29) = V(84)*V(87) + ARP(30) = V(85)*V(87) + ARP(31) = V(83)*V(87) + ARP(32) = V(82)*V(87) + ARP(33) = V(25) + ARP(34) = V(83)*F(11) + ARP(35) = V(83)*F(13) + ARP(36) = V(82)*V(87) + ARP(37) = V(69)*V(87) + ARP(38) = V(71)*V(83) + ARP(39) = V(71)*V(87) + ARP(40) = V(82)*V(86) + ARP(41) = V(21) + ARP(42) = V(85)*V(86) + ARP(43) = V(23)*V(83) + ARP(44) = V(74)*V(85) + ARP(45) = V(16)*V(83) + ARP(46) = V(16)*V(83) + ARP(47) = V(52)*V(85) + ARP(48) = V(70)*V(85) + ARP(49) = V(22)*V(83) + ARP(50) = V(72)*V(85) + ARP(51) = V(72)*V(85) + ARP(52) = V(54)*V(85) + ARP(53) = V(62)*V(85) + ARP(54) = V(60)*V(85) + ARP(55) = V(79)*V(85) + ARP(56) = V(79)*V(85) + ARP(57) = V(57)*V(85) + ARP(58) = V(57)*V(85) + ARP(59) = V(66)*V(85) + ARP(60) = V(65)*V(85) + ARP(61) = V(64)*V(85) + ARP(62) = V(64)*V(85) + ARP(63) = V(59)*V(85) + ARP(64) = V(59)*V(85) + ARP(65) = V(51)*V(85) + ARP(66) = V(55)*V(85) + ARP(67) = V(53)*V(85) + ARP(68) = V(67)*V(85) + ARP(69) = V(63)*V(85) + ARP(70) = V(22)*V(87) + ARP(71) = V(73)*V(83) + ARP(72) = V(83)*F(1) + ARP(73) = V(68)*V(83) + ARP(74) = V(81)*V(82) + ARP(75) = V(18) + ARP(76) = V(82)*V(88) + ARP(77) = V(19) + ARP(78) = V(78)*V(82) + ARP(79) = V(44) + ARP(80) = V(82)*F(5) + ARP(81) = F(7) + ARP(82) = V(81)*V(85) + ARP(83) = V(85)*V(88) + ARP(84) = V(78)*V(85) + ARP(85) = V(85)*F(5) + ARP(86) = V(68)*V(87) + ARP(87) = V(49)*V(83) + ARP(88) = V(49)*V(83) + ARP(89) = V(52)*V(90) + ARP(90) = V(70)*V(90) + ARP(91) = V(72)*V(84) + ARP(92) = V(54)*V(84) + ARP(93) = V(62)*V(84) + ARP(94) = V(60)*V(84) + ARP(95) = V(79)*V(84) + ARP(96) = V(57)*V(84) + ARP(97) = V(66)*V(84) + ARP(98) = V(65)*V(84) + ARP(99) = V(64)*V(84) + ARP(100) = V(59)*V(84) + ARP(101) = V(51)*V(84) + ARP(102) = V(55)*V(84) + ARP(103) = V(53)*V(84) + ARP(104) = V(67)*V(84) + ARP(105) = V(63)*V(84) + ARP(106) = V(76)*V(83) + ARP(107) = V(74)*V(90) + ARP(108) = V(76)*V(87) + ARP(109) = V(72)*V(90) + ARP(110) = V(54)*V(90) + ARP(111) = V(62)*V(90) + ARP(112) = V(60)*V(90) + ARP(113) = V(79)*V(90) + ARP(114) = V(57)*V(90) + ARP(115) = V(66)*V(90) + ARP(116) = V(65)*V(90) + ARP(117) = V(64)*V(90) + ARP(118) = V(59)*V(90) + ARP(119) = V(51)*V(90) + ARP(120) = V(55)*V(90) + ARP(121) = V(53)*V(90) + ARP(122) = V(67)*V(90) + ARP(123) = V(63)*V(90) + ARP(124) = V(83)*F(4) + ARP(125) = V(83)*F(16) + ARP(126) = V(74)*V(74) + ARP(127) = V(74)*V(74) + ARP(128) = V(74)*V(84) + ARP(129) = V(52)*V(84) + ARP(130) = V(70)*V(84) + ARP(131) = V(84)*V(86) + ARP(132) = V(81)*V(84) + ARP(133) = V(84)*V(88) + ARP(134) = V(78)*V(84) + ARP(135) = V(84)*F(5) + ARP(136) = V(48)*V(83) + ARP(137) = V(48)*V(89) + ARP(138) = V(44)*V(83) + ARP(139) = V(44)*V(89) + ARP(140) = V(50)*V(83) + ARP(141) = V(48)*V(87) + ARP(142) = V(83)*F(8) + ARP(143) = V(75)*V(83) + ARP(144) = V(87)*F(8) + ARP(145) = V(75)*V(87) + ARP(146) = V(46)*V(83) + ARP(147) = V(77)*V(83) + ARP(148) = V(80)*V(83) + ARP(149) = V(61)*V(83) + ARP(150) = V(52)*V(86) + ARP(151) = V(70)*V(86) + ARP(152) = V(52)*V(86) + ARP(153) = V(70)*V(86) + ARP(154) = V(46)*V(89) + ARP(155) = V(77)*V(89) + ARP(156) = V(80)*V(89) + ARP(157) = V(46)*V(87) + ARP(158) = V(80)*V(87) + ARP(159) = V(80)*V(87) + ARP(160) = V(81)*V(90) + ARP(161) = V(88)*V(90) + ARP(162) = V(78)*V(90) + ARP(163) = V(90)*F(5) + ARP(164) = V(81)*V(90) + ARP(165) = V(88)*V(90) + ARP(166) = V(78)*V(90) + ARP(167) = V(90)*F(5) + ARP(168) = V(39)*V(83) + ARP(169) = V(38)*V(83) + ARP(170) = V(35)*V(83) + ARP(171) = V(31)*V(83) + ARP(172) = V(32)*V(83) + ARP(173) = V(30)*V(83) + ARP(174) = V(33)*V(83) + ARP(175) = V(37)*V(83) + ARP(176) = V(36)*V(83) + ARP(177) = V(83)*F(6) + ARP(178) = V(45)*V(83) + ARP(179) = V(41)*V(83) + ARP(180) = V(43)*V(83) + ARP(181) = V(42)*V(83) + ARP(182) = V(40)*V(83) + ARP(183) = V(26)*V(83) + ARP(184) = V(27)*V(83) + ARP(185) = V(23)*V(87) + ARP(186) = V(83)*F(12) + ARP(187) = V(58)*V(83) + ARP(188) = V(58)*V(89) + ARP(189) = V(86)*V(86) + ARP(190) = V(86)*V(90) + ARP(191) = V(86)*V(90) + ARP(192) = V(72)*V(86) + ARP(193) = V(62)*V(86) + ARP(194) = V(60)*V(86) + ARP(195) = V(79)*V(86) + ARP(196) = V(57)*V(86) + ARP(197) = V(66)*V(86) + ARP(198) = V(65)*V(86) + ARP(199) = V(64)*V(86) + ARP(200) = V(59)*V(86) + ARP(201) = V(53)*V(86) + ARP(202) = V(54)*V(86) + ARP(203) = V(51)*V(86) + ARP(204) = V(55)*V(86) + ARP(205) = V(67)*V(86) + ARP(206) = V(63)*V(86) + ARP(207) = V(72)*V(86) + ARP(208) = V(62)*V(86) + ARP(209) = V(60)*V(86) + ARP(210) = V(79)*V(86) + ARP(211) = V(57)*V(86) + ARP(212) = V(66)*V(86) + ARP(213) = V(64)*V(86) + ARP(214) = V(59)*V(86) + ARP(215) = V(54)*V(86) + ARP(216) = V(65)*V(86) + ARP(217) = V(51)*V(86) + ARP(218) = V(55)*V(86) + ARP(219) = V(67)*V(86) + ARP(220) = V(63)*V(86) + ARP(221) = V(53)*V(86) + ARP(222) = V(74)*V(86) + ARP(223) = V(74)*V(86) + ARP(224) = V(81)*V(86) + ARP(225) = V(86)*V(88) + ARP(226) = V(78)*V(86) + ARP(227) = V(86)*F(5) + ARP(228) = V(87)*V(87) + ARP(229) = F(3) + ARP(230) = F(3) + ARP(231) = F(3) + ARP(232) = F(3) + ARP(233) = F(3) + ARP(234) = F(3) + ARP(235) = F(3) + ARP(236) = F(3) + ARP(237) = F(3) + ARP(238) = F(3) + ARP(239) = F(3) + ARP(240) = F(3) + ARP(241) = F(3) + ARP(242) = F(3) + ARP(243) = V(82) + ARP(244) = V(89) + ARP(245) = V(21) + ARP(246) = V(56) + ARP(247) = V(69) + ARP(248) = V(25) + ARP(249) = V(17) + ARP(250) = V(44) + ARP(251) = V(18) + ARP(252) = V(73) + ARP(253) = V(84) + ARP(254) = V(82) + ARP(255) = V(87) + ARP(256) = V(25) + ARP(257) = V(34)*V(83) + ARP(258) = V(34)*V(83) + ARP(259) = V(34)*V(87) + ARP(260) = V(20)*V(83) + ARP(261) = V(89) + ARP(262) = V(82) + ARP(263) = V(17) + ARP(264) = V(28) + ARP(265) = V(69) + ARP(266) = V(69) + ARP(267) = V(56) + ARP(268) = V(24) + ARP(269) = V(29) + ARP(270) = V(87) + ARP(271) = V(87) + ARP(272) = V(25) + ARP(273) = V(25) + ARP(274) = V(29) + ARP(275) = V(71) + ARP(276) = V(71) + ARP(277) = V(21) + ARP(278) = V(68) + ARP(279) = V(49) + ARP(280) = V(49) + ARP(281) = V(76) + ARP(282) = F(12) + ARP(283) = V(50) + ARP(284) = F(8) + ARP(285) = F(8) + ARP(286) = V(75) + ARP(287) = V(75) + ARP(288) = V(77) + ARP(289) = V(77) + ARP(290) = V(77) + ARP(291) = V(80) + ARP(292) = V(80) + ARP(293) = V(61) + ARP(294) = V(39) + ARP(295) = V(38) + ARP(296) = V(35) + ARP(297) = V(31) + ARP(298) = V(32) + ARP(299) = V(30) + ARP(300) = V(37) + ARP(301) = V(33) + ARP(302) = V(36) + ARP(303) = F(6) + ARP(304) = V(45) + ARP(305) = V(41) + ARP(306) = V(43) + ARP(307) = V(42) + ARP(308) = V(40) + ARP(309) = V(26) + ARP(310) = V(73) + ARP(311) = V(27) + +END SUBROUTINE ReactantProd + +! End of ReactantProd function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! JacReactantProd - Jacobian of Reactant Products vector +! Arguments : +! V - Concentrations of variable species (local) +! F - Concentrations of fixed species (local) +! JVRP - d ARP(1:NREACT)/d VAR (1:NVAR) +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE JacReactantProd ( V, F, JVRP ) + +! V - Concentrations of variable species (local) + REAL(kind=dp) :: V(NVAR) +! F - Concentrations of fixed species (local) + REAL(kind=dp) :: F(NFIX) +! JVRP - d ARP(1:NREACT)/d VAR (1:NVAR) + REAL(kind=dp) :: JVRP(NJVRP) + + +! Reactant Products in each equation are useful in the +! stoichiometric formulation of mass action law +! Below we compute the Jacobian of the Reactant Products vector +! w.r.t. variable species: d ARP(1:NREACT) / d Var(1:NVAR) + +! JVRP(1) = dARP(1)/dV(85) + JVRP(1) = V(89) +! JVRP(2) = dARP(1)/dV(89) + JVRP(2) = V(85) +! JVRP(3) = dARP(2)/dV(83) + JVRP(3) = V(89) +! JVRP(4) = dARP(2)/dV(89) + JVRP(4) = V(83) +! JVRP(5) = dARP(3)/dV(84) + JVRP(5) = V(89) +! JVRP(6) = dARP(3)/dV(89) + JVRP(6) = V(84) +! JVRP(7) = dARP(4)/dV(82) + JVRP(7) = V(89) +! JVRP(8) = dARP(4)/dV(89) + JVRP(8) = V(82) +! JVRP(9) = dARP(5)/dV(89) + JVRP(9) = V(90) +! JVRP(10) = dARP(5)/dV(90) + JVRP(10) = V(89) +! JVRP(11) = dARP(6)/dV(83) + JVRP(11) = 2*V(83) +! JVRP(12) = dARP(7)/dV(83) + JVRP(12) = 2*V(83) +! JVRP(13) = dARP(8)/dV(83) + JVRP(13) = V(84) +! JVRP(14) = dARP(8)/dV(84) + JVRP(14) = V(83) +! JVRP(15) = dARP(9)/dV(17) + JVRP(15) = V(83) +! JVRP(16) = dARP(9)/dV(83) + JVRP(16) = V(17) +! JVRP(17) = dARP(10)/dV(84) + JVRP(17) = V(85) +! JVRP(18) = dARP(10)/dV(85) + JVRP(18) = V(84) +! JVRP(19) = dARP(11)/dV(84) + JVRP(19) = 2*V(84) +! JVRP(20) = dARP(12)/dV(83) + JVRP(20) = F(9) +! JVRP(21) = dARP(13)/dV(47) + JVRP(21) = V(83) +! JVRP(22) = dARP(13)/dV(83) + JVRP(22) = V(47) +! JVRP(23) = dARP(14)/dV(83) + JVRP(23) = F(2) +! JVRP(24) = dARP(15)/dV(85) + JVRP(24) = V(90) +! JVRP(25) = dARP(15)/dV(90) + JVRP(25) = V(85) +! JVRP(26) = dARP(16)/dV(84) + JVRP(26) = V(90) +! JVRP(27) = dARP(16)/dV(90) + JVRP(27) = V(84) +! JVRP(28) = dARP(17)/dV(90) + JVRP(28) = 2*V(90) +! JVRP(29) = dARP(18)/dV(90) + JVRP(29) = 2*V(90) +! JVRP(30) = dARP(19)/dV(28) + JVRP(30) = V(83) +! JVRP(31) = dARP(19)/dV(83) + JVRP(31) = V(28) +! JVRP(32) = dARP(20)/dV(28) + JVRP(32) = V(83) +! JVRP(33) = dARP(20)/dV(83) + JVRP(33) = V(28) +! JVRP(34) = dARP(21)/dV(69) + JVRP(34) = V(83) +! JVRP(35) = dARP(21)/dV(83) + JVRP(35) = V(69) +! JVRP(36) = dARP(22)/dV(82) + JVRP(36) = V(83) +! JVRP(37) = dARP(22)/dV(83) + JVRP(37) = V(82) +! JVRP(38) = dARP(23)/dV(56) + JVRP(38) = V(83) +! JVRP(39) = dARP(23)/dV(83) + JVRP(39) = V(56) +! JVRP(40) = dARP(24)/dV(83) + JVRP(40) = V(85) +! JVRP(41) = dARP(24)/dV(85) + JVRP(41) = V(83) +! JVRP(42) = dARP(25)/dV(24) + JVRP(42) = V(83) +! JVRP(43) = dARP(25)/dV(83) + JVRP(43) = V(24) +! JVRP(44) = dARP(26)/dV(82) + JVRP(44) = V(84) +! JVRP(45) = dARP(26)/dV(84) + JVRP(45) = V(82) +! JVRP(46) = dARP(27)/dV(29) + JVRP(46) = 1 +! JVRP(47) = dARP(28)/dV(29) + JVRP(47) = V(83) +! JVRP(48) = dARP(28)/dV(83) + JVRP(48) = V(29) +! JVRP(49) = dARP(29)/dV(84) + JVRP(49) = V(87) +! JVRP(50) = dARP(29)/dV(87) + JVRP(50) = V(84) +! JVRP(51) = dARP(30)/dV(85) + JVRP(51) = V(87) +! JVRP(52) = dARP(30)/dV(87) + JVRP(52) = V(85) +! JVRP(53) = dARP(31)/dV(83) + JVRP(53) = V(87) +! JVRP(54) = dARP(31)/dV(87) + JVRP(54) = V(83) +! JVRP(55) = dARP(32)/dV(82) + JVRP(55) = V(87) +! JVRP(56) = dARP(32)/dV(87) + JVRP(56) = V(82) +! JVRP(57) = dARP(33)/dV(25) + JVRP(57) = 1 +! JVRP(58) = dARP(34)/dV(83) + JVRP(58) = F(11) +! JVRP(59) = dARP(35)/dV(83) + JVRP(59) = F(13) +! JVRP(60) = dARP(36)/dV(82) + JVRP(60) = V(87) +! JVRP(61) = dARP(36)/dV(87) + JVRP(61) = V(82) +! JVRP(62) = dARP(37)/dV(69) + JVRP(62) = V(87) +! JVRP(63) = dARP(37)/dV(87) + JVRP(63) = V(69) +! JVRP(64) = dARP(38)/dV(71) + JVRP(64) = V(83) +! JVRP(65) = dARP(38)/dV(83) + JVRP(65) = V(71) +! JVRP(66) = dARP(39)/dV(71) + JVRP(66) = V(87) +! JVRP(67) = dARP(39)/dV(87) + JVRP(67) = V(71) +! JVRP(68) = dARP(40)/dV(82) + JVRP(68) = V(86) +! JVRP(69) = dARP(40)/dV(86) + JVRP(69) = V(82) +! JVRP(70) = dARP(41)/dV(21) + JVRP(70) = 1 +! JVRP(71) = dARP(42)/dV(85) + JVRP(71) = V(86) +! JVRP(72) = dARP(42)/dV(86) + JVRP(72) = V(85) +! JVRP(73) = dARP(43)/dV(23) + JVRP(73) = V(83) +! JVRP(74) = dARP(43)/dV(83) + JVRP(74) = V(23) +! JVRP(75) = dARP(44)/dV(74) + JVRP(75) = V(85) +! JVRP(76) = dARP(44)/dV(85) + JVRP(76) = V(74) +! JVRP(77) = dARP(45)/dV(16) + JVRP(77) = V(83) +! JVRP(78) = dARP(45)/dV(83) + JVRP(78) = V(16) +! JVRP(79) = dARP(46)/dV(16) + JVRP(79) = V(83) +! JVRP(80) = dARP(46)/dV(83) + JVRP(80) = V(16) +! JVRP(81) = dARP(47)/dV(52) + JVRP(81) = V(85) +! JVRP(82) = dARP(47)/dV(85) + JVRP(82) = V(52) +! JVRP(83) = dARP(48)/dV(70) + JVRP(83) = V(85) +! JVRP(84) = dARP(48)/dV(85) + JVRP(84) = V(70) +! JVRP(85) = dARP(49)/dV(22) + JVRP(85) = V(83) +! JVRP(86) = dARP(49)/dV(83) + JVRP(86) = V(22) +! JVRP(87) = dARP(50)/dV(72) + JVRP(87) = V(85) +! JVRP(88) = dARP(50)/dV(85) + JVRP(88) = V(72) +! JVRP(89) = dARP(51)/dV(72) + JVRP(89) = V(85) +! JVRP(90) = dARP(51)/dV(85) + JVRP(90) = V(72) +! JVRP(91) = dARP(52)/dV(54) + JVRP(91) = V(85) +! JVRP(92) = dARP(52)/dV(85) + JVRP(92) = V(54) +! JVRP(93) = dARP(53)/dV(62) + JVRP(93) = V(85) +! JVRP(94) = dARP(53)/dV(85) + JVRP(94) = V(62) +! JVRP(95) = dARP(54)/dV(60) + JVRP(95) = V(85) +! JVRP(96) = dARP(54)/dV(85) + JVRP(96) = V(60) +! JVRP(97) = dARP(55)/dV(79) + JVRP(97) = V(85) +! JVRP(98) = dARP(55)/dV(85) + JVRP(98) = V(79) +! JVRP(99) = dARP(56)/dV(79) + JVRP(99) = V(85) +! JVRP(100) = dARP(56)/dV(85) + JVRP(100) = V(79) +! JVRP(101) = dARP(57)/dV(57) + JVRP(101) = V(85) +! JVRP(102) = dARP(57)/dV(85) + JVRP(102) = V(57) +! JVRP(103) = dARP(58)/dV(57) + JVRP(103) = V(85) +! JVRP(104) = dARP(58)/dV(85) + JVRP(104) = V(57) +! JVRP(105) = dARP(59)/dV(66) + JVRP(105) = V(85) +! JVRP(106) = dARP(59)/dV(85) + JVRP(106) = V(66) +! JVRP(107) = dARP(60)/dV(65) + JVRP(107) = V(85) +! JVRP(108) = dARP(60)/dV(85) + JVRP(108) = V(65) +! JVRP(109) = dARP(61)/dV(64) + JVRP(109) = V(85) +! JVRP(110) = dARP(61)/dV(85) + JVRP(110) = V(64) +! JVRP(111) = dARP(62)/dV(64) + JVRP(111) = V(85) +! JVRP(112) = dARP(62)/dV(85) + JVRP(112) = V(64) +! JVRP(113) = dARP(63)/dV(59) + JVRP(113) = V(85) +! JVRP(114) = dARP(63)/dV(85) + JVRP(114) = V(59) +! JVRP(115) = dARP(64)/dV(59) + JVRP(115) = V(85) +! JVRP(116) = dARP(64)/dV(85) + JVRP(116) = V(59) +! JVRP(117) = dARP(65)/dV(51) + JVRP(117) = V(85) +! JVRP(118) = dARP(65)/dV(85) + JVRP(118) = V(51) +! JVRP(119) = dARP(66)/dV(55) + JVRP(119) = V(85) +! JVRP(120) = dARP(66)/dV(85) + JVRP(120) = V(55) +! JVRP(121) = dARP(67)/dV(53) + JVRP(121) = V(85) +! JVRP(122) = dARP(67)/dV(85) + JVRP(122) = V(53) +! JVRP(123) = dARP(68)/dV(67) + JVRP(123) = V(85) +! JVRP(124) = dARP(68)/dV(85) + JVRP(124) = V(67) +! JVRP(125) = dARP(69)/dV(63) + JVRP(125) = V(85) +! JVRP(126) = dARP(69)/dV(85) + JVRP(126) = V(63) +! JVRP(127) = dARP(70)/dV(22) + JVRP(127) = V(87) +! JVRP(128) = dARP(70)/dV(87) + JVRP(128) = V(22) +! JVRP(129) = dARP(71)/dV(73) + JVRP(129) = V(83) +! JVRP(130) = dARP(71)/dV(83) + JVRP(130) = V(73) +! JVRP(131) = dARP(72)/dV(83) + JVRP(131) = F(1) +! JVRP(132) = dARP(73)/dV(68) + JVRP(132) = V(83) +! JVRP(133) = dARP(73)/dV(83) + JVRP(133) = V(68) +! JVRP(134) = dARP(74)/dV(81) + JVRP(134) = V(82) +! JVRP(135) = dARP(74)/dV(82) + JVRP(135) = V(81) +! JVRP(136) = dARP(75)/dV(18) + JVRP(136) = 1 +! JVRP(137) = dARP(76)/dV(82) + JVRP(137) = V(88) +! JVRP(138) = dARP(76)/dV(88) + JVRP(138) = V(82) +! JVRP(139) = dARP(77)/dV(19) + JVRP(139) = 1 +! JVRP(140) = dARP(78)/dV(78) + JVRP(140) = V(82) +! JVRP(141) = dARP(78)/dV(82) + JVRP(141) = V(78) +! JVRP(142) = dARP(79)/dV(44) + JVRP(142) = 1 +! JVRP(143) = dARP(80)/dV(82) + JVRP(143) = F(5) +! JVRP(144) = dARP(82)/dV(81) + JVRP(144) = V(85) +! JVRP(145) = dARP(82)/dV(85) + JVRP(145) = V(81) +! JVRP(146) = dARP(83)/dV(85) + JVRP(146) = V(88) +! JVRP(147) = dARP(83)/dV(88) + JVRP(147) = V(85) +! JVRP(148) = dARP(84)/dV(78) + JVRP(148) = V(85) +! JVRP(149) = dARP(84)/dV(85) + JVRP(149) = V(78) +! JVRP(150) = dARP(85)/dV(85) + JVRP(150) = F(5) +! JVRP(151) = dARP(86)/dV(68) + JVRP(151) = V(87) +! JVRP(152) = dARP(86)/dV(87) + JVRP(152) = V(68) +! JVRP(153) = dARP(87)/dV(49) + JVRP(153) = V(83) +! JVRP(154) = dARP(87)/dV(83) + JVRP(154) = V(49) +! JVRP(155) = dARP(88)/dV(49) + JVRP(155) = V(83) +! JVRP(156) = dARP(88)/dV(83) + JVRP(156) = V(49) +! JVRP(157) = dARP(89)/dV(52) + JVRP(157) = V(90) +! JVRP(158) = dARP(89)/dV(90) + JVRP(158) = V(52) +! JVRP(159) = dARP(90)/dV(70) + JVRP(159) = V(90) +! JVRP(160) = dARP(90)/dV(90) + JVRP(160) = V(70) +! JVRP(161) = dARP(91)/dV(72) + JVRP(161) = V(84) +! JVRP(162) = dARP(91)/dV(84) + JVRP(162) = V(72) +! JVRP(163) = dARP(92)/dV(54) + JVRP(163) = V(84) +! JVRP(164) = dARP(92)/dV(84) + JVRP(164) = V(54) +! JVRP(165) = dARP(93)/dV(62) + JVRP(165) = V(84) +! JVRP(166) = dARP(93)/dV(84) + JVRP(166) = V(62) +! JVRP(167) = dARP(94)/dV(60) + JVRP(167) = V(84) +! JVRP(168) = dARP(94)/dV(84) + JVRP(168) = V(60) +! JVRP(169) = dARP(95)/dV(79) + JVRP(169) = V(84) +! JVRP(170) = dARP(95)/dV(84) + JVRP(170) = V(79) +! JVRP(171) = dARP(96)/dV(57) + JVRP(171) = V(84) +! JVRP(172) = dARP(96)/dV(84) + JVRP(172) = V(57) +! JVRP(173) = dARP(97)/dV(66) + JVRP(173) = V(84) +! JVRP(174) = dARP(97)/dV(84) + JVRP(174) = V(66) +! JVRP(175) = dARP(98)/dV(65) + JVRP(175) = V(84) +! JVRP(176) = dARP(98)/dV(84) + JVRP(176) = V(65) +! JVRP(177) = dARP(99)/dV(64) + JVRP(177) = V(84) +! JVRP(178) = dARP(99)/dV(84) + JVRP(178) = V(64) +! JVRP(179) = dARP(100)/dV(59) + JVRP(179) = V(84) +! JVRP(180) = dARP(100)/dV(84) + JVRP(180) = V(59) +! JVRP(181) = dARP(101)/dV(51) + JVRP(181) = V(84) +! JVRP(182) = dARP(101)/dV(84) + JVRP(182) = V(51) +! JVRP(183) = dARP(102)/dV(55) + JVRP(183) = V(84) +! JVRP(184) = dARP(102)/dV(84) + JVRP(184) = V(55) +! JVRP(185) = dARP(103)/dV(53) + JVRP(185) = V(84) +! JVRP(186) = dARP(103)/dV(84) + JVRP(186) = V(53) +! JVRP(187) = dARP(104)/dV(67) + JVRP(187) = V(84) +! JVRP(188) = dARP(104)/dV(84) + JVRP(188) = V(67) +! JVRP(189) = dARP(105)/dV(63) + JVRP(189) = V(84) +! JVRP(190) = dARP(105)/dV(84) + JVRP(190) = V(63) +! JVRP(191) = dARP(106)/dV(76) + JVRP(191) = V(83) +! JVRP(192) = dARP(106)/dV(83) + JVRP(192) = V(76) +! JVRP(193) = dARP(107)/dV(74) + JVRP(193) = V(90) +! JVRP(194) = dARP(107)/dV(90) + JVRP(194) = V(74) +! JVRP(195) = dARP(108)/dV(76) + JVRP(195) = V(87) +! JVRP(196) = dARP(108)/dV(87) + JVRP(196) = V(76) +! JVRP(197) = dARP(109)/dV(72) + JVRP(197) = V(90) +! JVRP(198) = dARP(109)/dV(90) + JVRP(198) = V(72) +! JVRP(199) = dARP(110)/dV(54) + JVRP(199) = V(90) +! JVRP(200) = dARP(110)/dV(90) + JVRP(200) = V(54) +! JVRP(201) = dARP(111)/dV(62) + JVRP(201) = V(90) +! JVRP(202) = dARP(111)/dV(90) + JVRP(202) = V(62) +! JVRP(203) = dARP(112)/dV(60) + JVRP(203) = V(90) +! JVRP(204) = dARP(112)/dV(90) + JVRP(204) = V(60) +! JVRP(205) = dARP(113)/dV(79) + JVRP(205) = V(90) +! JVRP(206) = dARP(113)/dV(90) + JVRP(206) = V(79) +! JVRP(207) = dARP(114)/dV(57) + JVRP(207) = V(90) +! JVRP(208) = dARP(114)/dV(90) + JVRP(208) = V(57) +! JVRP(209) = dARP(115)/dV(66) + JVRP(209) = V(90) +! JVRP(210) = dARP(115)/dV(90) + JVRP(210) = V(66) +! JVRP(211) = dARP(116)/dV(65) + JVRP(211) = V(90) +! JVRP(212) = dARP(116)/dV(90) + JVRP(212) = V(65) +! JVRP(213) = dARP(117)/dV(64) + JVRP(213) = V(90) +! JVRP(214) = dARP(117)/dV(90) + JVRP(214) = V(64) +! JVRP(215) = dARP(118)/dV(59) + JVRP(215) = V(90) +! JVRP(216) = dARP(118)/dV(90) + JVRP(216) = V(59) +! JVRP(217) = dARP(119)/dV(51) + JVRP(217) = V(90) +! JVRP(218) = dARP(119)/dV(90) + JVRP(218) = V(51) +! JVRP(219) = dARP(120)/dV(55) + JVRP(219) = V(90) +! JVRP(220) = dARP(120)/dV(90) + JVRP(220) = V(55) +! JVRP(221) = dARP(121)/dV(53) + JVRP(221) = V(90) +! JVRP(222) = dARP(121)/dV(90) + JVRP(222) = V(53) +! JVRP(223) = dARP(122)/dV(67) + JVRP(223) = V(90) +! JVRP(224) = dARP(122)/dV(90) + JVRP(224) = V(67) +! JVRP(225) = dARP(123)/dV(63) + JVRP(225) = V(90) +! JVRP(226) = dARP(123)/dV(90) + JVRP(226) = V(63) +! JVRP(227) = dARP(124)/dV(83) + JVRP(227) = F(4) +! JVRP(228) = dARP(125)/dV(83) + JVRP(228) = F(16) +! JVRP(229) = dARP(126)/dV(74) + JVRP(229) = 2*V(74) +! JVRP(230) = dARP(127)/dV(74) + JVRP(230) = 2*V(74) +! JVRP(231) = dARP(128)/dV(74) + JVRP(231) = V(84) +! JVRP(232) = dARP(128)/dV(84) + JVRP(232) = V(74) +! JVRP(233) = dARP(129)/dV(52) + JVRP(233) = V(84) +! JVRP(234) = dARP(129)/dV(84) + JVRP(234) = V(52) +! JVRP(235) = dARP(130)/dV(70) + JVRP(235) = V(84) +! JVRP(236) = dARP(130)/dV(84) + JVRP(236) = V(70) +! JVRP(237) = dARP(131)/dV(84) + JVRP(237) = V(86) +! JVRP(238) = dARP(131)/dV(86) + JVRP(238) = V(84) +! JVRP(239) = dARP(132)/dV(81) + JVRP(239) = V(84) +! JVRP(240) = dARP(132)/dV(84) + JVRP(240) = V(81) +! JVRP(241) = dARP(133)/dV(84) + JVRP(241) = V(88) +! JVRP(242) = dARP(133)/dV(88) + JVRP(242) = V(84) +! JVRP(243) = dARP(134)/dV(78) + JVRP(243) = V(84) +! JVRP(244) = dARP(134)/dV(84) + JVRP(244) = V(78) +! JVRP(245) = dARP(135)/dV(84) + JVRP(245) = F(5) +! JVRP(246) = dARP(136)/dV(48) + JVRP(246) = V(83) +! JVRP(247) = dARP(136)/dV(83) + JVRP(247) = V(48) +! JVRP(248) = dARP(137)/dV(48) + JVRP(248) = V(89) +! JVRP(249) = dARP(137)/dV(89) + JVRP(249) = V(48) +! JVRP(250) = dARP(138)/dV(44) + JVRP(250) = V(83) +! JVRP(251) = dARP(138)/dV(83) + JVRP(251) = V(44) +! JVRP(252) = dARP(139)/dV(44) + JVRP(252) = V(89) +! JVRP(253) = dARP(139)/dV(89) + JVRP(253) = V(44) +! JVRP(254) = dARP(140)/dV(50) + JVRP(254) = V(83) +! JVRP(255) = dARP(140)/dV(83) + JVRP(255) = V(50) +! JVRP(256) = dARP(141)/dV(48) + JVRP(256) = V(87) +! JVRP(257) = dARP(141)/dV(87) + JVRP(257) = V(48) +! JVRP(258) = dARP(142)/dV(83) + JVRP(258) = F(8) +! JVRP(259) = dARP(143)/dV(75) + JVRP(259) = V(83) +! JVRP(260) = dARP(143)/dV(83) + JVRP(260) = V(75) +! JVRP(261) = dARP(144)/dV(87) + JVRP(261) = F(8) +! JVRP(262) = dARP(145)/dV(75) + JVRP(262) = V(87) +! JVRP(263) = dARP(145)/dV(87) + JVRP(263) = V(75) +! JVRP(264) = dARP(146)/dV(46) + JVRP(264) = V(83) +! JVRP(265) = dARP(146)/dV(83) + JVRP(265) = V(46) +! JVRP(266) = dARP(147)/dV(77) + JVRP(266) = V(83) +! JVRP(267) = dARP(147)/dV(83) + JVRP(267) = V(77) +! JVRP(268) = dARP(148)/dV(80) + JVRP(268) = V(83) +! JVRP(269) = dARP(148)/dV(83) + JVRP(269) = V(80) +! JVRP(270) = dARP(149)/dV(61) + JVRP(270) = V(83) +! JVRP(271) = dARP(149)/dV(83) + JVRP(271) = V(61) +! JVRP(272) = dARP(150)/dV(52) + JVRP(272) = V(86) +! JVRP(273) = dARP(150)/dV(86) + JVRP(273) = V(52) +! JVRP(274) = dARP(151)/dV(70) + JVRP(274) = V(86) +! JVRP(275) = dARP(151)/dV(86) + JVRP(275) = V(70) +! JVRP(276) = dARP(152)/dV(52) + JVRP(276) = V(86) +! JVRP(277) = dARP(152)/dV(86) + JVRP(277) = V(52) +! JVRP(278) = dARP(153)/dV(70) + JVRP(278) = V(86) +! JVRP(279) = dARP(153)/dV(86) + JVRP(279) = V(70) +! JVRP(280) = dARP(154)/dV(46) + JVRP(280) = V(89) +! JVRP(281) = dARP(154)/dV(89) + JVRP(281) = V(46) +! JVRP(282) = dARP(155)/dV(77) + JVRP(282) = V(89) +! JVRP(283) = dARP(155)/dV(89) + JVRP(283) = V(77) +! JVRP(284) = dARP(156)/dV(80) + JVRP(284) = V(89) +! JVRP(285) = dARP(156)/dV(89) + JVRP(285) = V(80) +! JVRP(286) = dARP(157)/dV(46) + JVRP(286) = V(87) +! JVRP(287) = dARP(157)/dV(87) + JVRP(287) = V(46) +! JVRP(288) = dARP(158)/dV(80) + JVRP(288) = V(87) +! JVRP(289) = dARP(158)/dV(87) + JVRP(289) = V(80) +! JVRP(290) = dARP(159)/dV(80) + JVRP(290) = V(87) +! JVRP(291) = dARP(159)/dV(87) + JVRP(291) = V(80) +! JVRP(292) = dARP(160)/dV(81) + JVRP(292) = V(90) +! JVRP(293) = dARP(160)/dV(90) + JVRP(293) = V(81) +! JVRP(294) = dARP(161)/dV(88) + JVRP(294) = V(90) +! JVRP(295) = dARP(161)/dV(90) + JVRP(295) = V(88) +! JVRP(296) = dARP(162)/dV(78) + JVRP(296) = V(90) +! JVRP(297) = dARP(162)/dV(90) + JVRP(297) = V(78) +! JVRP(298) = dARP(163)/dV(90) + JVRP(298) = F(5) +! JVRP(299) = dARP(164)/dV(81) + JVRP(299) = V(90) +! JVRP(300) = dARP(164)/dV(90) + JVRP(300) = V(81) +! JVRP(301) = dARP(165)/dV(88) + JVRP(301) = V(90) +! JVRP(302) = dARP(165)/dV(90) + JVRP(302) = V(88) +! JVRP(303) = dARP(166)/dV(78) + JVRP(303) = V(90) +! JVRP(304) = dARP(166)/dV(90) + JVRP(304) = V(78) +! JVRP(305) = dARP(167)/dV(90) + JVRP(305) = F(5) +! JVRP(306) = dARP(168)/dV(39) + JVRP(306) = V(83) +! JVRP(307) = dARP(168)/dV(83) + JVRP(307) = V(39) +! JVRP(308) = dARP(169)/dV(38) + JVRP(308) = V(83) +! JVRP(309) = dARP(169)/dV(83) + JVRP(309) = V(38) +! JVRP(310) = dARP(170)/dV(35) + JVRP(310) = V(83) +! JVRP(311) = dARP(170)/dV(83) + JVRP(311) = V(35) +! JVRP(312) = dARP(171)/dV(31) + JVRP(312) = V(83) +! JVRP(313) = dARP(171)/dV(83) + JVRP(313) = V(31) +! JVRP(314) = dARP(172)/dV(32) + JVRP(314) = V(83) +! JVRP(315) = dARP(172)/dV(83) + JVRP(315) = V(32) +! JVRP(316) = dARP(173)/dV(30) + JVRP(316) = V(83) +! JVRP(317) = dARP(173)/dV(83) + JVRP(317) = V(30) +! JVRP(318) = dARP(174)/dV(33) + JVRP(318) = V(83) +! JVRP(319) = dARP(174)/dV(83) + JVRP(319) = V(33) +! JVRP(320) = dARP(175)/dV(37) + JVRP(320) = V(83) +! JVRP(321) = dARP(175)/dV(83) + JVRP(321) = V(37) +! JVRP(322) = dARP(176)/dV(36) + JVRP(322) = V(83) +! JVRP(323) = dARP(176)/dV(83) + JVRP(323) = V(36) +! JVRP(324) = dARP(177)/dV(83) + JVRP(324) = F(6) +! JVRP(325) = dARP(178)/dV(45) + JVRP(325) = V(83) +! JVRP(326) = dARP(178)/dV(83) + JVRP(326) = V(45) +! JVRP(327) = dARP(179)/dV(41) + JVRP(327) = V(83) +! JVRP(328) = dARP(179)/dV(83) + JVRP(328) = V(41) +! JVRP(329) = dARP(180)/dV(43) + JVRP(329) = V(83) +! JVRP(330) = dARP(180)/dV(83) + JVRP(330) = V(43) +! JVRP(331) = dARP(181)/dV(42) + JVRP(331) = V(83) +! JVRP(332) = dARP(181)/dV(83) + JVRP(332) = V(42) +! JVRP(333) = dARP(182)/dV(40) + JVRP(333) = V(83) +! JVRP(334) = dARP(182)/dV(83) + JVRP(334) = V(40) +! JVRP(335) = dARP(183)/dV(26) + JVRP(335) = V(83) +! JVRP(336) = dARP(183)/dV(83) + JVRP(336) = V(26) +! JVRP(337) = dARP(184)/dV(27) + JVRP(337) = V(83) +! JVRP(338) = dARP(184)/dV(83) + JVRP(338) = V(27) +! JVRP(339) = dARP(185)/dV(23) + JVRP(339) = V(87) +! JVRP(340) = dARP(185)/dV(87) + JVRP(340) = V(23) +! JVRP(341) = dARP(186)/dV(83) + JVRP(341) = F(12) +! JVRP(342) = dARP(187)/dV(58) + JVRP(342) = V(83) +! JVRP(343) = dARP(187)/dV(83) + JVRP(343) = V(58) +! JVRP(344) = dARP(188)/dV(58) + JVRP(344) = V(89) +! JVRP(345) = dARP(188)/dV(89) + JVRP(345) = V(58) +! JVRP(346) = dARP(189)/dV(86) + JVRP(346) = 2*V(86) +! JVRP(347) = dARP(190)/dV(86) + JVRP(347) = V(90) +! JVRP(348) = dARP(190)/dV(90) + JVRP(348) = V(86) +! JVRP(349) = dARP(191)/dV(86) + JVRP(349) = V(90) +! JVRP(350) = dARP(191)/dV(90) + JVRP(350) = V(86) +! JVRP(351) = dARP(192)/dV(72) + JVRP(351) = V(86) +! JVRP(352) = dARP(192)/dV(86) + JVRP(352) = V(72) +! JVRP(353) = dARP(193)/dV(62) + JVRP(353) = V(86) +! JVRP(354) = dARP(193)/dV(86) + JVRP(354) = V(62) +! JVRP(355) = dARP(194)/dV(60) + JVRP(355) = V(86) +! JVRP(356) = dARP(194)/dV(86) + JVRP(356) = V(60) +! JVRP(357) = dARP(195)/dV(79) + JVRP(357) = V(86) +! JVRP(358) = dARP(195)/dV(86) + JVRP(358) = V(79) +! JVRP(359) = dARP(196)/dV(57) + JVRP(359) = V(86) +! JVRP(360) = dARP(196)/dV(86) + JVRP(360) = V(57) +! JVRP(361) = dARP(197)/dV(66) + JVRP(361) = V(86) +! JVRP(362) = dARP(197)/dV(86) + JVRP(362) = V(66) +! JVRP(363) = dARP(198)/dV(65) + JVRP(363) = V(86) +! JVRP(364) = dARP(198)/dV(86) + JVRP(364) = V(65) +! JVRP(365) = dARP(199)/dV(64) + JVRP(365) = V(86) +! JVRP(366) = dARP(199)/dV(86) + JVRP(366) = V(64) +! JVRP(367) = dARP(200)/dV(59) + JVRP(367) = V(86) +! JVRP(368) = dARP(200)/dV(86) + JVRP(368) = V(59) +! JVRP(369) = dARP(201)/dV(53) + JVRP(369) = V(86) +! JVRP(370) = dARP(201)/dV(86) + JVRP(370) = V(53) +! JVRP(371) = dARP(202)/dV(54) + JVRP(371) = V(86) +! JVRP(372) = dARP(202)/dV(86) + JVRP(372) = V(54) +! JVRP(373) = dARP(203)/dV(51) + JVRP(373) = V(86) +! JVRP(374) = dARP(203)/dV(86) + JVRP(374) = V(51) +! JVRP(375) = dARP(204)/dV(55) + JVRP(375) = V(86) +! JVRP(376) = dARP(204)/dV(86) + JVRP(376) = V(55) +! JVRP(377) = dARP(205)/dV(67) + JVRP(377) = V(86) +! JVRP(378) = dARP(205)/dV(86) + JVRP(378) = V(67) +! JVRP(379) = dARP(206)/dV(63) + JVRP(379) = V(86) +! JVRP(380) = dARP(206)/dV(86) + JVRP(380) = V(63) +! JVRP(381) = dARP(207)/dV(72) + JVRP(381) = V(86) +! JVRP(382) = dARP(207)/dV(86) + JVRP(382) = V(72) +! JVRP(383) = dARP(208)/dV(62) + JVRP(383) = V(86) +! JVRP(384) = dARP(208)/dV(86) + JVRP(384) = V(62) +! JVRP(385) = dARP(209)/dV(60) + JVRP(385) = V(86) +! JVRP(386) = dARP(209)/dV(86) + JVRP(386) = V(60) +! JVRP(387) = dARP(210)/dV(79) + JVRP(387) = V(86) +! JVRP(388) = dARP(210)/dV(86) + JVRP(388) = V(79) +! JVRP(389) = dARP(211)/dV(57) + JVRP(389) = V(86) +! JVRP(390) = dARP(211)/dV(86) + JVRP(390) = V(57) +! JVRP(391) = dARP(212)/dV(66) + JVRP(391) = V(86) +! JVRP(392) = dARP(212)/dV(86) + JVRP(392) = V(66) +! JVRP(393) = dARP(213)/dV(64) + JVRP(393) = V(86) +! JVRP(394) = dARP(213)/dV(86) + JVRP(394) = V(64) +! JVRP(395) = dARP(214)/dV(59) + JVRP(395) = V(86) +! JVRP(396) = dARP(214)/dV(86) + JVRP(396) = V(59) +! JVRP(397) = dARP(215)/dV(54) + JVRP(397) = V(86) +! JVRP(398) = dARP(215)/dV(86) + JVRP(398) = V(54) +! JVRP(399) = dARP(216)/dV(65) + JVRP(399) = V(86) +! JVRP(400) = dARP(216)/dV(86) + JVRP(400) = V(65) +! JVRP(401) = dARP(217)/dV(51) + JVRP(401) = V(86) +! JVRP(402) = dARP(217)/dV(86) + JVRP(402) = V(51) +! JVRP(403) = dARP(218)/dV(55) + JVRP(403) = V(86) +! JVRP(404) = dARP(218)/dV(86) + JVRP(404) = V(55) +! JVRP(405) = dARP(219)/dV(67) + JVRP(405) = V(86) +! JVRP(406) = dARP(219)/dV(86) + JVRP(406) = V(67) +! JVRP(407) = dARP(220)/dV(63) + JVRP(407) = V(86) +! JVRP(408) = dARP(220)/dV(86) + JVRP(408) = V(63) +! JVRP(409) = dARP(221)/dV(53) + JVRP(409) = V(86) +! JVRP(410) = dARP(221)/dV(86) + JVRP(410) = V(53) +! JVRP(411) = dARP(222)/dV(74) + JVRP(411) = V(86) +! JVRP(412) = dARP(222)/dV(86) + JVRP(412) = V(74) +! JVRP(413) = dARP(223)/dV(74) + JVRP(413) = V(86) +! JVRP(414) = dARP(223)/dV(86) + JVRP(414) = V(74) +! JVRP(415) = dARP(224)/dV(81) + JVRP(415) = V(86) +! JVRP(416) = dARP(224)/dV(86) + JVRP(416) = V(81) +! JVRP(417) = dARP(225)/dV(86) + JVRP(417) = V(88) +! JVRP(418) = dARP(225)/dV(88) + JVRP(418) = V(86) +! JVRP(419) = dARP(226)/dV(78) + JVRP(419) = V(86) +! JVRP(420) = dARP(226)/dV(86) + JVRP(420) = V(78) +! JVRP(421) = dARP(227)/dV(86) + JVRP(421) = F(5) +! JVRP(422) = dARP(228)/dV(87) + JVRP(422) = 2*V(87) +! JVRP(423) = dARP(243)/dV(82) + JVRP(423) = 1 +! JVRP(424) = dARP(244)/dV(89) + JVRP(424) = 1 +! JVRP(425) = dARP(245)/dV(21) + JVRP(425) = 1 +! JVRP(426) = dARP(246)/dV(56) + JVRP(426) = 1 +! JVRP(427) = dARP(247)/dV(69) + JVRP(427) = 1 +! JVRP(428) = dARP(248)/dV(25) + JVRP(428) = 1 +! JVRP(429) = dARP(249)/dV(17) + JVRP(429) = 1 +! JVRP(430) = dARP(250)/dV(44) + JVRP(430) = 1 +! JVRP(431) = dARP(251)/dV(18) + JVRP(431) = 1 +! JVRP(432) = dARP(252)/dV(73) + JVRP(432) = 1 +! JVRP(433) = dARP(253)/dV(84) + JVRP(433) = 1 +! JVRP(434) = dARP(254)/dV(82) + JVRP(434) = 1 +! JVRP(435) = dARP(255)/dV(87) + JVRP(435) = 1 +! JVRP(436) = dARP(256)/dV(25) + JVRP(436) = 1 +! JVRP(437) = dARP(257)/dV(34) + JVRP(437) = V(83) +! JVRP(438) = dARP(257)/dV(83) + JVRP(438) = V(34) +! JVRP(439) = dARP(258)/dV(34) + JVRP(439) = V(83) +! JVRP(440) = dARP(258)/dV(83) + JVRP(440) = V(34) +! JVRP(441) = dARP(259)/dV(34) + JVRP(441) = V(87) +! JVRP(442) = dARP(259)/dV(87) + JVRP(442) = V(34) +! JVRP(443) = dARP(260)/dV(20) + JVRP(443) = V(83) +! JVRP(444) = dARP(260)/dV(83) + JVRP(444) = V(20) +! JVRP(445) = dARP(261)/dV(89) + JVRP(445) = 1 +! JVRP(446) = dARP(262)/dV(82) + JVRP(446) = 1 +! JVRP(447) = dARP(263)/dV(17) + JVRP(447) = 1 +! JVRP(448) = dARP(264)/dV(28) + JVRP(448) = 1 +! JVRP(449) = dARP(265)/dV(69) + JVRP(449) = 1 +! JVRP(450) = dARP(266)/dV(69) + JVRP(450) = 1 +! JVRP(451) = dARP(267)/dV(56) + JVRP(451) = 1 +! JVRP(452) = dARP(268)/dV(24) + JVRP(452) = 1 +! JVRP(453) = dARP(269)/dV(29) + JVRP(453) = 1 +! JVRP(454) = dARP(270)/dV(87) + JVRP(454) = 1 +! JVRP(455) = dARP(271)/dV(87) + JVRP(455) = 1 +! JVRP(456) = dARP(272)/dV(25) + JVRP(456) = 1 +! JVRP(457) = dARP(273)/dV(25) + JVRP(457) = 1 +! JVRP(458) = dARP(274)/dV(29) + JVRP(458) = 1 +! JVRP(459) = dARP(275)/dV(71) + JVRP(459) = 1 +! JVRP(460) = dARP(276)/dV(71) + JVRP(460) = 1 +! JVRP(461) = dARP(277)/dV(21) + JVRP(461) = 1 +! JVRP(462) = dARP(278)/dV(68) + JVRP(462) = 1 +! JVRP(463) = dARP(279)/dV(49) + JVRP(463) = 1 +! JVRP(464) = dARP(280)/dV(49) + JVRP(464) = 1 +! JVRP(465) = dARP(281)/dV(76) + JVRP(465) = 1 +! JVRP(466) = dARP(283)/dV(50) + JVRP(466) = 1 +! JVRP(467) = dARP(286)/dV(75) + JVRP(467) = 1 +! JVRP(468) = dARP(287)/dV(75) + JVRP(468) = 1 +! JVRP(469) = dARP(288)/dV(77) + JVRP(469) = 1 +! JVRP(470) = dARP(289)/dV(77) + JVRP(470) = 1 +! JVRP(471) = dARP(290)/dV(77) + JVRP(471) = 1 +! JVRP(472) = dARP(291)/dV(80) + JVRP(472) = 1 +! JVRP(473) = dARP(292)/dV(80) + JVRP(473) = 1 +! JVRP(474) = dARP(293)/dV(61) + JVRP(474) = 1 +! JVRP(475) = dARP(294)/dV(39) + JVRP(475) = 1 +! JVRP(476) = dARP(295)/dV(38) + JVRP(476) = 1 +! JVRP(477) = dARP(296)/dV(35) + JVRP(477) = 1 +! JVRP(478) = dARP(297)/dV(31) + JVRP(478) = 1 +! JVRP(479) = dARP(298)/dV(32) + JVRP(479) = 1 +! JVRP(480) = dARP(299)/dV(30) + JVRP(480) = 1 +! JVRP(481) = dARP(300)/dV(37) + JVRP(481) = 1 +! JVRP(482) = dARP(301)/dV(33) + JVRP(482) = 1 +! JVRP(483) = dARP(302)/dV(36) + JVRP(483) = 1 +! JVRP(484) = dARP(304)/dV(45) + JVRP(484) = 1 +! JVRP(485) = dARP(305)/dV(41) + JVRP(485) = 1 +! JVRP(486) = dARP(306)/dV(43) + JVRP(486) = 1 +! JVRP(487) = dARP(307)/dV(42) + JVRP(487) = 1 +! JVRP(488) = dARP(308)/dV(40) + JVRP(488) = 1 +! JVRP(489) = dARP(309)/dV(26) + JVRP(489) = 1 +! JVRP(490) = dARP(310)/dV(73) + JVRP(490) = 1 +! JVRP(491) = dARP(311)/dV(27) + JVRP(491) = 1 + +END SUBROUTINE JacReactantProd + +! End of JacReactantProd function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +! Begin Derivative w.r.t. Rate Coefficients + +! ------------------------------------------------------------------------------ +! Subroutine for the derivative of Fun with respect to rate coefficients +! ----------------------------------------------------------------------------- + + SUBROUTINE dFun_dRcoeff( V, F, NCOEFF, JCOEFF, DFDR ) + + USE gckpp_adj_Parameters + USE gckpp_adj_StoichiomSP + IMPLICIT NONE + +! V - Concentrations of variable/radical/fixed species + REAL(kind=dp) V(NVAR), F(NFIX) +! NCOEFF - the number of rate coefficients with respect to which we differentiate + INTEGER NCOEFF +! JCOEFF - a vector of integers containing the indices of reactions (rate +! coefficients) with respect to which we differentiate + INTEGER JCOEFF(NCOEFF) +! DFDR - a matrix containg derivative values; specifically, +! column j contains d Fun(1:NVAR) / d RCT( JCOEFF(j) ) +! for each 1 <= j <= NCOEFF +! This matrix is stored in a column-wise linearized format + REAL(kind=dp) DFDR(NVAR*NCOEFF) + +! Local vector with reactant products + REAL(kind=dp) A_RPROD(NREACT) + REAL(kind=dp) aj + INTEGER i,j,k + +! Compute the reactant products of all reactions + CALL ReactantProd ( V, F, A_RPROD ) + +! Compute the derivatives by multiplying column JCOEFF(j) of the stoichiometric matrix with A_RPROD + DO j=1,NCOEFF +! Initialize the j-th column of derivative matrix to zero + DO i=1,NVAR + DFDR(i+NVAR*(j-1)) = 0.0_dp + END DO +! Column JCOEFF(j) in the stoichiometric matrix times the +! reactant product of the JCOEFF(j)-th reaction +! give the j-th column of the derivative matrix + aj = A_RPROD(JCOEFF(j)) + DO k=CCOL_STOICM(JCOEFF(j)),CCOL_STOICM(JCOEFF(j)+1)-1 + DFDR(IROW_STOICM(k)+NVAR*(j-1)) = STOICM(k)*aj + END DO + END DO + + END SUBROUTINE dFun_dRcoeff + +! End Derivative w.r.t. Rate Coefficients + + +! Begin Jacobian Derivative w.r.t. Rate Coefficients + +! ------------------------------------------------------------------------------ +! Subroutine for the derivative of Jac with respect to rate coefficients +! Times a user vector +! ----------------------------------------------------------------------------- + + SUBROUTINE dJac_dRcoeff( V, F, U, NCOEFF, JCOEFF, DJDR ) + + USE gckpp_adj_Parameters + USE gckpp_adj_StoichiomSP + IMPLICIT NONE + +! V - Concentrations of variable/fixed species + REAL(kind=dp) V(NVAR), F(NFIX) +! U - User-supplied Vector + REAL(kind=dp) U(NVAR) +! NCOEFF - the number of rate coefficients with respect to which we differentiate + INTEGER NCOEFF +! JCOEFF - a vector of integers containing the indices of reactions (rate +! coefficients) with respect to which we differentiate + INTEGER JCOEFF(NCOEFF) +! DFDR - a matrix containg derivative values; specifically, +! column j contains d Jac(1:NVAR) / d RCT( JCOEFF(j) ) * U +! for each 1 <= j <= NCOEFF +! This matrix is stored in a column-wise linearized format + REAL(kind=dp) DJDR(NVAR*NCOEFF) + +! Local vector for Jacobian of reactant products + REAL(kind=dp) JV_RPROD(NJVRP) + REAL(kind=dp) aj + INTEGER i,j,k + +! Compute the Jacobian of all reactant products + CALL JacReactantProd( V, F, JV_RPROD ) + +! Compute the derivatives by multiplying column JCOEFF(j) of the stoichiometric matrix with A_PROD + DO j=1,NCOEFF +! Initialize the j-th column of derivative matrix to zero + DO i=1,NVAR + DJDR(i+NVAR*(j-1)) = 0.0_dp + END DO +! Column JCOEFF(j) in the stoichiometric matrix times the +! ( Gradient of reactant product of the JCOEFF(j)-th reaction X user vector ) +! give the j-th column of the derivative matrix +! +! Row JCOEFF(j) of JV_RPROD times the user vector + aj = 0.0_dp + DO k=CROW_JVRP(JCOEFF(j)),CROW_JVRP(JCOEFF(j)+1)-1 + aj = aj + JV_RPROD(k)*U(ICOL_JVRP(k)) + END DO +! Column JCOEFF(j) of Stoichiom. matrix times aj + DO k=CCOL_STOICM(JCOEFF(j)),CCOL_STOICM(JCOEFF(j)+1)-1 + DJDR(IROW_STOICM(k)+NVAR*(j-1)) = STOICM(k)*aj + END DO + END DO + + END SUBROUTINE dJac_dRcoeff + +! End Jacobian Derivative w.r.t. Rate Coefficients + + +END MODULE gckpp_adj_Stoichiom + diff --git a/code/adjoint/gckpp_adj_StoichiomSP.f90 b/code/adjoint/gckpp_adj_StoichiomSP.f90 new file mode 100644 index 0000000..3bdda34 --- /dev/null +++ b/code/adjoint/gckpp_adj_StoichiomSP.f90 @@ -0,0 +1,678 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Sparse Stoichiometric Data Structures File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_StoichiomSP.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_StoichiomSP + + USE gckpp_adj_Precision + PUBLIC + SAVE + + +! Row-compressed sparse data for the Jacobian of reaction products JVRP + + INTEGER, PARAMETER, DIMENSION(312) :: CROW_JVRP = (/ & + 1, 3, 5, 7, 9, 11, 12, 13, 15, 17, 19, 20, & + 21, 23, 24, 26, 28, 29, 30, 32, 34, 36, 38, 40, & + 42, 44, 46, 47, 49, 51, 53, 55, 57, 58, 59, 60, & + 62, 64, 66, 68, 70, 71, 73, 75, 77, 79, 81, 83, & + 85, 87, 89, 91, 93, 95, 97, 99,101,103,105,107, & + 109,111,113,115,117,119,121,123,125,127,129,131, & + 132,134,136,137,139,140,142,143,144,144,146,148, & + 150,151,153,155,157,159,161,163,165,167,169,171, & + 173,175,177,179,181,183,185,187,189,191,193,195, & + 197,199,201,203,205,207,209,211,213,215,217,219, & + 221,223,225,227,228,229,230,231,233,235,237,239, & + 241,243,245,246,248,250,252,254,256,258,259,261, & + 262,264,266,268,270,272,274,276,278,280,282,284, & + 286,288,290,292,294,296,298,299,301,303,305,306, & + 308,310,312,314,316,318,320,322,324,325,327,329, & + 331,333,335,337,339,341,342,344,346,347,349,351, & + 353,355,357,359,361,363,365,367,369,371,373,375, & + 377,379,381,383,385,387,389,391,393,395,397,399, & + 401,403,405,407,409,411,413,415,417,419,421,422, & + 423,423,423,423,423,423,423,423,423,423,423,423, & + 423,423,423,424,425,426,427,428,429,430,431,432, & + 433,434,435,436,437,439,441,443,445,446,447,448, & + 449,450,451,452,453,454,455,456,457,458,459,460, & + 461,462,463,464,465,466,466,467,467,467,468,469, & + 470,471,472,473,474,475,476,477,478,479,480,481, & + 482,483,484,484,485,486,487,488,489,490,491,492 /) + + INTEGER, PARAMETER, DIMENSION(360) :: ICOL_JVRP_0 = (/ & + 85, 89, 83, 89, 84, 89, 82, 89, 89, 90, 83, 83, & + 83, 84, 17, 83, 84, 85, 84, 83, 47, 83, 83, 85, & + 90, 84, 90, 90, 90, 28, 83, 28, 83, 69, 83, 82, & + 83, 56, 83, 83, 85, 24, 83, 82, 84, 29, 29, 83, & + 84, 87, 85, 87, 83, 87, 82, 87, 25, 83, 83, 82, & + 87, 69, 87, 71, 83, 71, 87, 82, 86, 21, 85, 86, & + 23, 83, 74, 85, 16, 83, 16, 83, 52, 85, 70, 85, & + 22, 83, 72, 85, 72, 85, 54, 85, 62, 85, 60, 85, & + 79, 85, 79, 85, 57, 85, 57, 85, 66, 85, 65, 85, & + 64, 85, 64, 85, 59, 85, 59, 85, 51, 85, 55, 85, & + 53, 85, 67, 85, 63, 85, 22, 87, 73, 83, 83, 68, & + 83, 81, 82, 18, 82, 88, 19, 78, 82, 44, 82, 81, & + 85, 85, 88, 78, 85, 85, 68, 87, 49, 83, 49, 83, & + 52, 90, 70, 90, 72, 84, 54, 84, 62, 84, 60, 84, & + 79, 84, 57, 84, 66, 84, 65, 84, 64, 84, 59, 84, & + 51, 84, 55, 84, 53, 84, 67, 84, 63, 84, 76, 83, & + 74, 90, 76, 87, 72, 90, 54, 90, 62, 90, 60, 90, & + 79, 90, 57, 90, 66, 90, 65, 90, 64, 90, 59, 90, & + 51, 90, 55, 90, 53, 90, 67, 90, 63, 90, 83, 83, & + 74, 74, 74, 84, 52, 84, 70, 84, 84, 86, 81, 84, & + 84, 88, 78, 84, 84, 48, 83, 48, 89, 44, 83, 44, & + 89, 50, 83, 48, 87, 83, 75, 83, 87, 75, 87, 46, & + 83, 77, 83, 80, 83, 61, 83, 52, 86, 70, 86, 52, & + 86, 70, 86, 46, 89, 77, 89, 80, 89, 46, 87, 80, & + 87, 80, 87, 81, 90, 88, 90, 78, 90, 90, 81, 90, & + 88, 90, 78, 90, 90, 39, 83, 38, 83, 35, 83, 31, & + 83, 32, 83, 30, 83, 33, 83, 37, 83, 36, 83, 83, & + 45, 83, 41, 83, 43, 83, 42, 83, 40, 83, 26, 83, & + 27, 83, 23, 87, 83, 58, 83, 58, 89, 86, 86, 90, & + 86, 90, 72, 86, 62, 86, 60, 86, 79, 86, 57, 86 /) + INTEGER, PARAMETER, DIMENSION(131) :: ICOL_JVRP_1 = (/ & + 66, 86, 65, 86, 64, 86, 59, 86, 53, 86, 54, 86, & + 51, 86, 55, 86, 67, 86, 63, 86, 72, 86, 62, 86, & + 60, 86, 79, 86, 57, 86, 66, 86, 64, 86, 59, 86, & + 54, 86, 65, 86, 51, 86, 55, 86, 67, 86, 63, 86, & + 53, 86, 74, 86, 74, 86, 81, 86, 86, 88, 78, 86, & + 86, 87, 82, 89, 21, 56, 69, 25, 17, 44, 18, 73, & + 84, 82, 87, 25, 34, 83, 34, 83, 34, 87, 20, 83, & + 89, 82, 17, 28, 69, 69, 56, 24, 29, 87, 87, 25, & + 25, 29, 71, 71, 21, 68, 49, 49, 76, 50, 75, 75, & + 77, 77, 77, 80, 80, 61, 39, 38, 35, 31, 32, 30, & + 37, 33, 36, 45, 41, 43, 42, 40, 26, 73, 27 /) + INTEGER, PARAMETER, DIMENSION(491) :: ICOL_JVRP = (/& + ICOL_JVRP_0, ICOL_JVRP_1 /) + + INTEGER, PARAMETER, DIMENSION(360) :: IROW_JVRP_0 = (/ & + 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 7, & + 8, 8, 9, 9, 10, 10, 11, 12, 13, 13, 14, 15, & + 15, 16, 16, 17, 18, 19, 19, 20, 20, 21, 21, 22, & + 22, 23, 23, 24, 24, 25, 25, 26, 26, 27, 28, 28, & + 29, 29, 30, 30, 31, 31, 32, 32, 33, 34, 35, 36, & + 36, 37, 37, 38, 38, 39, 39, 40, 40, 41, 42, 42, & + 43, 43, 44, 44, 45, 45, 46, 46, 47, 47, 48, 48, & + 49, 49, 50, 50, 51, 51, 52, 52, 53, 53, 54, 54, & + 55, 55, 56, 56, 57, 57, 58, 58, 59, 59, 60, 60, & + 61, 61, 62, 62, 63, 63, 64, 64, 65, 65, 66, 66, & + 67, 67, 68, 68, 69, 69, 70, 70, 71, 71, 72, 73, & + 73, 74, 74, 75, 76, 76, 77, 78, 78, 79, 80, 82, & + 82, 83, 83, 84, 84, 85, 86, 86, 87, 87, 88, 88, & + 89, 89, 90, 90, 91, 91, 92, 92, 93, 93, 94, 94, & + 95, 95, 96, 96, 97, 97, 98, 98, 99, 99,100,100, & + 101,101,102,102,103,103,104,104,105,105,106,106, & + 107,107,108,108,109,109,110,110,111,111,112,112, & + 113,113,114,114,115,115,116,116,117,117,118,118, & + 119,119,120,120,121,121,122,122,123,123,124,125, & + 126,127,128,128,129,129,130,130,131,131,132,132, & + 133,133,134,134,135,136,136,137,137,138,138,139, & + 139,140,140,141,141,142,143,143,144,145,145,146, & + 146,147,147,148,148,149,149,150,150,151,151,152, & + 152,153,153,154,154,155,155,156,156,157,157,158, & + 158,159,159,160,160,161,161,162,162,163,164,164, & + 165,165,166,166,167,168,168,169,169,170,170,171, & + 171,172,172,173,173,174,174,175,175,176,176,177, & + 178,178,179,179,180,180,181,181,182,182,183,183, & + 184,184,185,185,186,187,187,188,188,189,190,190, & + 191,191,192,192,193,193,194,194,195,195,196,196 /) + INTEGER, PARAMETER, DIMENSION(131) :: IROW_JVRP_1 = (/ & + 197,197,198,198,199,199,200,200,201,201,202,202, & + 203,203,204,204,205,205,206,206,207,207,208,208, & + 209,209,210,210,211,211,212,212,213,213,214,214, & + 215,215,216,216,217,217,218,218,219,219,220,220, & + 221,221,222,222,223,223,224,224,225,225,226,226, & + 227,228,243,244,245,246,247,248,249,250,251,252, & + 253,254,255,256,257,257,258,258,259,259,260,260, & + 261,262,263,264,265,266,267,268,269,270,271,272, & + 273,274,275,276,277,278,279,280,281,283,286,287, & + 288,289,290,291,292,293,294,295,296,297,298,299, & + 300,301,302,304,305,306,307,308,309,310,311 /) + INTEGER, PARAMETER, DIMENSION(491) :: IROW_JVRP = (/& + IROW_JVRP_0, IROW_JVRP_1 /) + + + +! Stoichiometric Matrix in Compressed Column Sparse Format + + + INTEGER, PARAMETER, DIMENSION(312) :: CCOL_STOICM = (/ & + 1, 4, 7, 10, 13, 17, 19, 21, 23, 26, 30, 32, & + 34, 38, 40, 45, 48, 50, 53, 56, 58, 62, 65, 68, & + 71, 74, 77, 80, 83, 87, 90, 94, 97,100,103,106, & + 108,113,119,123,126,129,134,137,142,145,148,153, & + 159,162,174,177,184,190,196,205,208,214,217,227, & + 234,242,245,251,254,263,268,273,281,286,290,293, & + 296,299,302,305,308,311,314,317,318,319,323,328, & + 333,337,341,344,347,352,359,362,365,369,373,376, & + 379,382,385,388,391,394,397,400,403,406,409,414, & + 418,429,437,444,451,460,466,475,483,491,497,505, & + 512,517,526,533,536,539,542,544,547,550,553,559, & + 563,568,572,574,577,585,591,596,601,604,607,611, & + 615,620,624,627,631,635,640,646,649,653,663,671, & + 679,682,685,689,694,698,703,707,710,713,716,718, & + 721,724,728,732,736,740,744,747,750,752,756,759, & + 764,768,771,774,778,782,785,790,798,800,803,806, & + 817,823,826,835,841,850,856,863,871,876,884,891, & + 897,906,912,915,918,921,924,927,930,933,936,940, & + 944,948,952,956,960,963,968,971,975,980,983,987, & + 989,990,991,992,993,994,995,996,997,998,999,1000, & + 1001,1002,1003,1006,1009,1012,1015,1018,1021,1024,1027,1030, & + 1033,1035,1038,1040,1042,1047,1052,1058,1062,1064,1067,1069, & + 1073,1076,1078,1081,1084,1087,1090,1092,1095,1099,1102,1106, & + 1108,1113,1117,1120,1123,1128,1130,1134,1136,1138,1142,1145, & + 1148,1153,1156,1159,1164,1168,1173,1178,1182,1186,1190,1194, & + 1199,1203,1207,1210,1217,1224,1229,1236,1242,1246,1257,1260 /) + + INTEGER, PARAMETER, DIMENSION(360) :: IROW_STOICM_0 = (/ & + 82, 85, 89, 83, 84, 89, 83, 84, 89, 82, 87, 89, & + 69, 84, 89, 90, 83, 89, 17, 83, 83, 84, 17, 83, & + 84, 82, 83, 84, 85, 17, 84, 83, 84, 13, 47, 83, & + 84, 83, 90, 69, 82, 84, 85, 90, 28, 84, 90, 69, & + 90, 69, 84, 90, 28, 83, 90, 28, 69, 47, 69, 83, & + 84, 56, 82, 83, 56, 83, 87, 24, 83, 85, 24, 82, & + 83, 29, 82, 84, 29, 82, 84, 29, 82, 83, 82, 83, & + 84, 87, 82, 85, 87, 82, 83, 84, 87, 25, 82, 87, & + 25, 82, 87, 13, 83, 84, 69, 83, 84, 85, 87, 47, & + 56, 69, 84, 87, 47, 69, 71, 83, 84, 86, 56, 71, & + 86, 87, 21, 82, 86, 21, 82, 86, 13, 82, 85, 86, & + 90, 23, 74, 83, 71, 74, 82, 84, 85, 16, 53, 83, & + 16, 52, 83, 52, 68, 82, 84, 85, 69, 70, 71, 82, & + 84, 85, 22, 72, 83, 49, 52, 53, 68, 71, 72, 74, & + 76, 82, 84, 85, 90, 72, 73, 85, 54, 68, 69, 71, & + 72, 82, 85, 62, 69, 73, 82, 85, 86, 60, 71, 73, & + 82, 85, 86, 56, 58, 69, 77, 79, 80, 82, 84, 85, & + 56, 79, 85, 57, 58, 69, 82, 84, 85, 56, 57, 85, & + 47, 50, 56, 61, 66, 69, 75, 82, 84, 85, 50, 56, & + 61, 65, 82, 84, 85, 50, 64, 69, 75, 82, 84, 85, & + 86, 56, 64, 85, 59, 61, 69, 82, 84, 85, 56, 59, & + 85, 50, 51, 56, 69, 75, 82, 84, 85, 86, 55, 69, & + 75, 82, 85, 49, 53, 82, 84, 85, 56, 67, 69, 77, & + 80, 82, 84, 85, 63, 69, 71, 82, 85, 22, 56, 72, & + 87, 54, 73, 83, 13, 83, 90, 68, 81, 83, 18, 81, & + 82, 18, 81, 82, 19, 82, 88, 19, 82, 88, 44, 78, & + 82, 44, 78, 82, 82, 82, 74, 81, 82, 85, 69, 82, & + 84, 85, 88, 69, 78, 82, 85, 86, 47, 82, 84, 85, & + 56, 68, 81, 87, 49, 62, 83, 49, 62, 83, 52, 68, & + 69, 84, 90, 61, 68, 69, 70, 71, 84, 90, 30, 72 /) + INTEGER, PARAMETER, DIMENSION(360) :: IROW_STOICM_1 = (/ & + 84, 54, 73, 84, 62, 84, 86, 90, 60, 75, 84, 90, & + 45, 79, 84, 45, 57, 84, 41, 66, 84, 43, 65, 84, & + 42, 64, 84, 40, 59, 84, 43, 51, 84, 43, 55, 84, & + 32, 53, 84, 39, 67, 84, 38, 63, 84, 60, 76, 83, & + 69, 71, 74, 84, 90, 56, 60, 76, 87, 49, 52, 53, & + 68, 69, 71, 72, 74, 76, 84, 90, 54, 68, 69, 71, & + 72, 82, 84, 90, 61, 62, 69, 75, 84, 86, 90, 60, & + 69, 71, 76, 84, 86, 90, 57, 58, 69, 76, 77, 79, & + 80, 84, 90, 57, 58, 69, 76, 84, 90, 47, 50, 61, & + 66, 69, 75, 76, 84, 90, 50, 61, 65, 68, 69, 82, & + 84, 90, 50, 64, 69, 75, 76, 84, 86, 90, 47, 59, & + 61, 69, 84, 90, 51, 68, 69, 75, 82, 84, 86, 90, & + 55, 68, 69, 75, 82, 84, 90, 49, 53, 69, 84, 90, & + 56, 67, 68, 69, 77, 80, 82, 84, 90, 63, 68, 69, & + 71, 82, 84, 90, 71, 83, 84, 68, 83, 84, 71, 74, & + 84, 71, 74, 35, 74, 84, 31, 52, 84, 37, 70, 84, & + 27, 83, 84, 86, 89, 90, 33, 81, 84, 89, 36, 69, & + 84, 88, 89, 26, 78, 84, 89, 84, 89, 48, 70, 83, & + 47, 48, 69, 71, 83, 84, 89, 90, 44, 61, 69, 82, & + 83, 84, 44, 69, 82, 84, 89, 47, 50, 83, 84, 88, & + 48, 63, 87, 47, 83, 84, 47, 75, 83, 86, 47, 56, & + 84, 87, 47, 56, 75, 86, 87, 15, 46, 79, 83, 64, & + 77, 83, 59, 78, 80, 83, 61, 75, 83, 84, 52, 68, & + 84, 86, 90, 69, 70, 71, 84, 86, 90, 52, 68, 86, & + 61, 68, 70, 86, 13, 46, 47, 48, 69, 77, 80, 83, & + 84, 89, 47, 69, 71, 75, 77, 83, 84, 89, 13, 47, & + 69, 75, 80, 83, 84, 89, 46, 67, 87, 55, 80, 87, & + 56, 78, 80, 87, 69, 74, 81, 84, 90, 69, 84, 88, & + 90, 69, 78, 84, 86, 90, 47, 69, 84, 90, 69, 81, & + 90, 69, 88, 90, 69, 78, 90, 69, 90, 39, 67, 83 /) + INTEGER, PARAMETER, DIMENSION(360) :: IROW_STOICM_2 = (/ & + 38, 63, 83, 35, 71, 74, 83, 31, 52, 68, 83, 32, & + 49, 53, 83, 30, 68, 72, 83, 33, 71, 81, 83, 37, & + 70, 83, 36, 83, 88, 47, 83, 45, 58, 79, 83, 41, & + 66, 83, 43, 65, 68, 82, 83, 42, 64, 68, 83, 40, & + 59, 83, 26, 78, 83, 27, 69, 83, 86, 23, 56, 74, & + 87, 69, 82, 83, 58, 66, 78, 83, 84, 47, 50, 58, & + 61, 69, 75, 83, 89, 86, 90, 69, 84, 86, 69, 86, & + 90, 49, 52, 53, 68, 71, 72, 74, 76, 84, 86, 90, & + 62, 69, 75, 84, 86, 90, 60, 71, 90, 57, 58, 69, & + 77, 79, 80, 84, 86, 90, 57, 58, 69, 84, 86, 90, & + 47, 50, 61, 66, 69, 75, 84, 86, 90, 50, 61, 65, & + 82, 86, 90, 50, 64, 69, 75, 84, 86, 90, 47, 59, & + 61, 69, 75, 84, 86, 90, 49, 53, 84, 86, 90, 54, & + 68, 69, 71, 72, 82, 86, 90, 51, 69, 75, 82, 84, & + 86, 90, 55, 69, 75, 82, 86, 90, 56, 67, 69, 77, & + 80, 82, 84, 86, 90, 63, 69, 71, 82, 86, 90, 72, & + 76, 86, 62, 76, 86, 60, 76, 86, 76, 79, 86, 57, & + 76, 86, 66, 76, 86, 64, 76, 86, 59, 76, 86, 54, & + 68, 82, 86, 65, 68, 82, 86, 51, 68, 82, 86, 55, & + 68, 82, 86, 67, 68, 82, 86, 63, 68, 82, 86, 49, & + 53, 86, 71, 74, 84, 86, 90, 71, 74, 86, 74, 81, & + 86, 90, 69, 84, 86, 88, 90, 69, 78, 90, 47, 84, & + 86, 90, 82, 87, 85, 82, 47, 22, 46, 49, 48, 16, & + 23, 76, 71, 69, 89, 56, 5, 14, 82, 6, 14, 89, & + 7, 14, 21, 3, 14, 56, 1, 14, 69, 4, 14, 25, & + 2, 14, 17, 8, 14, 44, 9, 14, 18, 10, 14, 73, & + 17, 84, 24, 56, 82, 56, 87, 25, 56, 20, 34, 69, & + 83, 90, 12, 20, 34, 83, 90, 20, 34, 56, 69, 87, & + 90, 11, 20, 83, 84, 83, 89, 82, 85, 89, 17, 83, & + 28, 69, 83, 84, 47, 69, 84, 47, 69, 56, 82, 83 /) + INTEGER, PARAMETER, DIMENSION(179) :: IROW_STOICM_3 = (/ & + 24, 83, 85, 29, 83, 87, 82, 87, 89, 85, 87, 25, & + 82, 87, 25, 85, 87, 89, 29, 82, 84, 47, 71, 84, & + 90, 47, 71, 21, 82, 86, 87, 90, 47, 68, 74, 84, & + 49, 86, 90, 47, 49, 90, 74, 76, 81, 86, 90, 69, & + 82, 47, 50, 69, 84, 47, 69, 47, 84, 47, 75, 84, & + 86, 47, 71, 75, 47, 48, 77, 47, 69, 77, 84, 86, & + 77, 78, 90, 78, 80, 84, 47, 69, 80, 84, 86, 61, & + 69, 84, 86, 39, 68, 82, 83, 84, 38, 68, 82, 83, & + 84, 35, 71, 83, 84, 31, 68, 83, 84, 32, 49, 83, & + 84, 30, 68, 83, 84, 37, 69, 71, 83, 84, 33, 71, & + 83, 84, 36, 69, 83, 84, 47, 83, 84, 45, 58, 69, & + 77, 80, 83, 84, 41, 47, 50, 61, 75, 83, 84, 43, & + 68, 82, 83, 84, 42, 50, 69, 75, 83, 84, 86, 40, & + 47, 61, 69, 83, 84, 26, 69, 83, 86, 49, 52, 53, & + 68, 71, 73, 74, 76, 82, 84, 90, 27, 83, 90 /) + INTEGER, PARAMETER, DIMENSION(1259) :: IROW_STOICM = (/& + IROW_STOICM_0, IROW_STOICM_1, IROW_STOICM_2, IROW_STOICM_3 /) + + INTEGER, PARAMETER, DIMENSION(360) :: ICOL_STOICM_0 = (/ & + 1, 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 4, & + 5, 5, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, & + 9, 10, 10, 10, 10, 11, 11, 12, 12, 13, 13, 13, & + 13, 14, 14, 15, 15, 15, 15, 15, 16, 16, 16, 17, & + 17, 18, 18, 18, 19, 19, 19, 20, 20, 21, 21, 21, & + 21, 22, 22, 22, 23, 23, 23, 24, 24, 24, 25, 25, & + 25, 26, 26, 26, 27, 27, 27, 28, 28, 28, 29, 29, & + 29, 29, 30, 30, 30, 31, 31, 31, 31, 32, 32, 32, & + 33, 33, 33, 34, 34, 34, 35, 35, 35, 36, 36, 37, & + 37, 37, 37, 37, 38, 38, 38, 38, 38, 38, 39, 39, & + 39, 39, 40, 40, 40, 41, 41, 41, 42, 42, 42, 42, & + 42, 43, 43, 43, 44, 44, 44, 44, 44, 45, 45, 45, & + 46, 46, 46, 47, 47, 47, 47, 47, 48, 48, 48, 48, & + 48, 48, 49, 49, 49, 50, 50, 50, 50, 50, 50, 50, & + 50, 50, 50, 50, 50, 51, 51, 51, 52, 52, 52, 52, & + 52, 52, 52, 53, 53, 53, 53, 53, 53, 54, 54, 54, & + 54, 54, 54, 55, 55, 55, 55, 55, 55, 55, 55, 55, & + 56, 56, 56, 57, 57, 57, 57, 57, 57, 58, 58, 58, & + 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 60, 60, & + 60, 60, 60, 60, 60, 61, 61, 61, 61, 61, 61, 61, & + 61, 62, 62, 62, 63, 63, 63, 63, 63, 63, 64, 64, & + 64, 65, 65, 65, 65, 65, 65, 65, 65, 65, 66, 66, & + 66, 66, 66, 67, 67, 67, 67, 67, 68, 68, 68, 68, & + 68, 68, 68, 68, 69, 69, 69, 69, 69, 70, 70, 70, & + 70, 71, 71, 71, 72, 72, 72, 73, 73, 73, 74, 74, & + 74, 75, 75, 75, 76, 76, 76, 77, 77, 77, 78, 78, & + 78, 79, 79, 79, 80, 81, 82, 82, 82, 82, 83, 83, & + 83, 83, 83, 84, 84, 84, 84, 84, 85, 85, 85, 85, & + 86, 86, 86, 86, 87, 87, 87, 88, 88, 88, 89, 89, & + 89, 89, 89, 90, 90, 90, 90, 90, 90, 90, 91, 91 /) + INTEGER, PARAMETER, DIMENSION(360) :: ICOL_STOICM_1 = (/ & + 91, 92, 92, 92, 93, 93, 93, 93, 94, 94, 94, 94, & + 95, 95, 95, 96, 96, 96, 97, 97, 97, 98, 98, 98, & + 99, 99, 99,100,100,100,101,101,101,102,102,102, & + 103,103,103,104,104,104,105,105,105,106,106,106, & + 107,107,107,107,107,108,108,108,108,109,109,109, & + 109,109,109,109,109,109,109,109,110,110,110,110, & + 110,110,110,110,111,111,111,111,111,111,111,112, & + 112,112,112,112,112,112,113,113,113,113,113,113, & + 113,113,113,114,114,114,114,114,114,115,115,115, & + 115,115,115,115,115,115,116,116,116,116,116,116, & + 116,116,117,117,117,117,117,117,117,117,118,118, & + 118,118,118,118,119,119,119,119,119,119,119,119, & + 120,120,120,120,120,120,120,121,121,121,121,121, & + 122,122,122,122,122,122,122,122,122,123,123,123, & + 123,123,123,123,124,124,124,125,125,125,126,126, & + 126,127,127,128,128,128,129,129,129,130,130,130, & + 131,131,131,131,131,131,132,132,132,132,133,133, & + 133,133,133,134,134,134,134,135,135,136,136,136, & + 137,137,137,137,137,137,137,137,138,138,138,138, & + 138,138,139,139,139,139,139,140,140,140,140,140, & + 141,141,141,142,142,142,143,143,143,143,144,144, & + 144,144,145,145,145,145,145,146,146,146,146,147, & + 147,147,148,148,148,148,149,149,149,149,150,150, & + 150,150,150,151,151,151,151,151,151,152,152,152, & + 153,153,153,153,154,154,154,154,154,154,154,154, & + 154,154,155,155,155,155,155,155,155,155,156,156, & + 156,156,156,156,156,156,157,157,157,158,158,158, & + 159,159,159,159,160,160,160,160,160,161,161,161, & + 161,162,162,162,162,162,163,163,163,163,164,164, & + 164,165,165,165,166,166,166,167,167,168,168,168 /) + INTEGER, PARAMETER, DIMENSION(360) :: ICOL_STOICM_2 = (/ & + 169,169,169,170,170,170,170,171,171,171,171,172, & + 172,172,172,173,173,173,173,174,174,174,174,175, & + 175,175,176,176,176,177,177,178,178,178,178,179, & + 179,179,180,180,180,180,180,181,181,181,181,182, & + 182,182,183,183,183,184,184,184,184,185,185,185, & + 185,186,186,186,187,187,187,187,187,188,188,188, & + 188,188,188,188,188,189,189,190,190,190,191,191, & + 191,192,192,192,192,192,192,192,192,192,192,192, & + 193,193,193,193,193,193,194,194,194,195,195,195, & + 195,195,195,195,195,195,196,196,196,196,196,196, & + 197,197,197,197,197,197,197,197,197,198,198,198, & + 198,198,198,199,199,199,199,199,199,199,200,200, & + 200,200,200,200,200,200,201,201,201,201,201,202, & + 202,202,202,202,202,202,202,203,203,203,203,203, & + 203,203,204,204,204,204,204,204,205,205,205,205, & + 205,205,205,205,205,206,206,206,206,206,206,207, & + 207,207,208,208,208,209,209,209,210,210,210,211, & + 211,211,212,212,212,213,213,213,214,214,214,215, & + 215,215,215,216,216,216,216,217,217,217,217,218, & + 218,218,218,219,219,219,219,220,220,220,220,221, & + 221,221,222,222,222,222,222,223,223,223,224,224, & + 224,224,225,225,225,225,225,226,226,226,227,227, & + 227,227,228,228,229,230,231,232,233,234,235,236, & + 237,238,239,240,241,242,243,243,243,244,244,244, & + 245,245,245,246,246,246,247,247,247,248,248,248, & + 249,249,249,250,250,250,251,251,251,252,252,252, & + 253,253,254,254,254,255,255,256,256,257,257,257, & + 257,257,258,258,258,258,258,259,259,259,259,259, & + 259,260,260,260,260,261,261,262,262,262,263,263, & + 264,264,264,264,265,265,265,266,266,267,267,267 /) + INTEGER, PARAMETER, DIMENSION(179) :: ICOL_STOICM_3 = (/ & + 268,268,268,269,269,269,270,270,270,271,271,272, & + 272,272,273,273,273,273,274,274,274,275,275,275, & + 275,276,276,277,277,277,277,277,278,278,278,278, & + 279,279,279,280,280,280,281,281,281,281,281,282, & + 282,283,283,283,283,284,284,285,285,286,286,286, & + 286,287,287,287,288,288,288,289,289,289,289,289, & + 290,290,290,291,291,291,292,292,292,292,292,293, & + 293,293,293,294,294,294,294,294,295,295,295,295, & + 295,296,296,296,296,297,297,297,297,298,298,298, & + 298,299,299,299,299,300,300,300,300,300,301,301, & + 301,301,302,302,302,302,303,303,303,304,304,304, & + 304,304,304,304,305,305,305,305,305,305,305,306, & + 306,306,306,306,307,307,307,307,307,307,307,308, & + 308,308,308,308,308,309,309,309,309,310,310,310, & + 310,310,310,310,310,310,310,310,311,311,311 /) + INTEGER, PARAMETER, DIMENSION(1259) :: ICOL_STOICM = (/& + ICOL_STOICM_0, ICOL_STOICM_1, ICOL_STOICM_2, ICOL_STOICM_3 /) + + REAL(kind=dp), PARAMETER, DIMENSION(150) :: STOICM_0 = (/ & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, -2.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -2.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -2.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -2.000000e+00_dp, 2.000000e+00_dp, & + 2.000000e+00_dp, -2.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 2.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 5.000000e-02_dp, 5.000000e-02_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 5.000000e-02_dp, 9.500000e-01_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp /) + REAL(kind=dp), PARAMETER, DIMENSION(150) :: STOICM_1 = (/ & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 3.200000e-01_dp, 5.000000e-02_dp, 1.800000e-01_dp, 1.300000e-01_dp, & + 3.200000e-01_dp, -1.000000e+00_dp, 3.200000e-01_dp, 1.900000e-01_dp, 1.000000e+00_dp, & + 2.700000e-01_dp, -1.000000e+00_dp, 1.800000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 5.700000e-01_dp, 3.900000e-01_dp, 7.500000e-01_dp, & + 3.000000e-01_dp, 2.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 9.600000e-01_dp, & + 4.000000e-02_dp, 9.600000e-01_dp, -1.000000e+00_dp, 9.600000e-01_dp, -1.000000e+00_dp, & + 9.300000e-01_dp, 7.000000e-02_dp, 9.300000e-01_dp, -1.000000e+00_dp, 9.300000e-01_dp, & + 1.000000e-01_dp, 3.400000e-01_dp, 5.600000e-01_dp, 3.400000e-01_dp, -1.000000e+00_dp, & + 2.200000e-01_dp, 9.000000e-01_dp, 9.000000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 7.500000e-01_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 6.100000e-01_dp, 2.400000e-01_dp, 8.000000e-02_dp, 3.300000e-01_dp, & + -1.000000e+00_dp, 3.500000e-01_dp, 5.300000e-01_dp, 9.200000e-01_dp, 9.200000e-01_dp, & + -1.000000e+00_dp, 9.500000e-01_dp, 5.000000e-02_dp, 9.500000e-01_dp, -1.000000e+00_dp, & + 1.950000e+00_dp, 5.000000e-02_dp, -1.000000e+00_dp, 7.200000e-01_dp, -1.000000e+00_dp, & + 2.800000e-01_dp, 2.800000e-01_dp, 1.000000e+00_dp, 2.800000e-01_dp, -1.000000e+00_dp, & + 7.200000e-01_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 6.000000e-01_dp, -1.000000e+00_dp, & + 1.000000e-01_dp, 3.000000e-01_dp, 3.000000e-01_dp, 1.900000e+00_dp, 3.000000e-01_dp, & + -1.000000e+00_dp, 6.000000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 2.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 8.500000e-01_dp, -1.000000e+00_dp, 1.500000e-01_dp, & + 5.000000e-02_dp, 1.000000e-01_dp, 1.150000e+00_dp, 8.000000e-01_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 2.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp /) + REAL(kind=dp), PARAMETER, DIMENSION(150) :: STOICM_2 = (/ & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 7.500000e-01_dp, 7.500000e-01_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.600000e-01_dp, 9.000000e-02_dp, 1.250000e+00_dp, -1.000000e+00_dp, & + 5.000000e-01_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 7.500000e-01_dp, 7.500000e-01_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.600000e-01_dp, 3.000000e-02_dp, 9.000000e-02_dp, & + 7.000000e-02_dp, 7.500000e-01_dp, 1.600000e-01_dp, -1.000000e+00_dp, 1.600000e-01_dp, & + 3.500000e-01_dp, 6.400000e-01_dp, -9.100000e-01_dp, -1.000000e+00_dp, 5.400000e-01_dp, & + 9.500000e-01_dp, 3.800000e-01_dp, 1.500000e-01_dp, 1.000000e+00_dp, 5.000000e-01_dp, & + -1.000000e+00_dp, 2.000000e-01_dp, -1.000000e+00_dp, 5.000000e-01_dp, 5.000000e-01_dp, & + 3.000000e-01_dp, 3.000000e-01_dp, -1.000000e+00_dp, -1.000000e+00_dp, 7.500000e-01_dp, & + 5.000000e-01_dp, 2.500000e-01_dp, 5.000000e-01_dp, 5.000000e-01_dp, -1.000000e+00_dp /) + REAL(kind=dp), PARAMETER, DIMENSION(150) :: STOICM_3 = (/ & + 7.000000e-02_dp, 6.000000e-02_dp, 1.100000e+00_dp, 2.500000e-01_dp, 2.000000e-01_dp, & + -1.000000e+00_dp, 1.400000e-01_dp, 9.200000e-01_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 5.000000e-01_dp, 1.130000e+00_dp, 2.500000e-01_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 3.300000e-01_dp, 1.300000e-01_dp, 1.800000e-01_dp, -1.000000e+00_dp, 9.500000e-01_dp, & + 2.900000e-01_dp, 2.500000e-01_dp, 1.000000e+00_dp, -1.000000e+00_dp, 5.000000e-01_dp, & + 5.000000e-01_dp, -1.000000e+00_dp, 2.500000e-01_dp, 7.500000e-01_dp, 1.000000e+00_dp, & + 5.000000e-01_dp, -1.000000e+00_dp, 3.600000e-01_dp, -1.000000e+00_dp, 8.900000e-01_dp, & + 1.400000e-01_dp, 2.500000e-01_dp, 6.400000e-01_dp, 3.600000e-01_dp, -1.000000e+00_dp, & + 1.500000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, 8.500000e-01_dp, 1.150000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 2.500000e-01_dp, 1.250000e+00_dp, 2.500000e-01_dp, & + 1.000000e+00_dp, 7.500000e-01_dp, 2.500000e-01_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 2.500000e-01_dp, 1.250000e+00_dp, 5.000000e-01_dp, 1.000000e+00_dp, 5.000000e-01_dp, & + -1.000000e+00_dp, 7.500000e-01_dp, -1.000000e+00_dp, 7.500000e-01_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 4.250000e-01_dp, -1.000000e+00_dp, 2.500000e-01_dp, 8.300000e-01_dp, & + 3.000000e-02_dp, 5.000000e-02_dp, 5.750000e-01_dp, 4.500000e-01_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 2.500000e-01_dp, 1.250000e+00_dp, 5.000000e-01_dp, 1.000000e+00_dp, & + 5.000000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 2.000000e+00_dp, -2.000000e+00_dp, & + 2.000000e+00_dp, 1.000000e+00_dp, -2.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 4.100000e-01_dp, 4.400000e-01_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.500000e-01_dp, 4.400000e-01_dp, 7.000000e-01_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 3.000000e-01_dp, 7.100000e-01_dp, 2.900000e-01_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 2.900000e-01_dp, 7.000000e-01_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 3.000000e-01_dp, -1.000000e+00_dp, 3.000000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 4.200000e-01_dp, -1.000000e+00_dp, 5.350000e-01_dp, 5.000000e-01_dp, & + 1.350000e-01_dp, 3.000000e-01_dp, -1.000000e+00_dp, 3.050000e-01_dp, -1.000000e+00_dp, & + 5.900000e-01_dp, 2.230000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 2.000000e+00_dp, & + -1.000000e+00_dp, 6.000000e-01_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 4.000000e-01_dp, -1.000000e+00_dp, -1.000000e+00_dp, 2.000000e-01_dp, 8.000000e-01_dp /) + REAL(kind=dp), PARAMETER, DIMENSION(150) :: STOICM_4 = (/ & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 2.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 2.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 4.300000e-01_dp, 5.700000e-01_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 6.500000e-01_dp, 3.500000e-01_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.500000e-01_dp, -1.000000e+00_dp, 5.000000e-02_dp, & + 7.000000e-02_dp, 9.000000e-01_dp, 1.590000e-01_dp, 3.870000e-01_dp, 2.700000e-01_dp, & + 6.000000e-02_dp, -9.000000e-01_dp, 5.000000e-02_dp, 8.000000e-01_dp, 4.000000e-02_dp, & + 8.200000e-01_dp, -1.000000e+00_dp, 8.000000e-02_dp, 6.000000e-02_dp, -8.000000e-01_dp, & + 1.600000e-01_dp, 2.000000e-01_dp, 7.000000e-01_dp, 8.000000e-01_dp, -1.000000e+00_dp, & + 2.150000e-01_dp, 2.750000e-01_dp, -8.000000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 2.000000e+00_dp, 2.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 2.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 2.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 5.000000e-01_dp, & + 5.000000e-01_dp, -5.000000e-01_dp, -1.000000e+00_dp, 5.000000e-01_dp, 5.000000e-01_dp, & + -5.000000e-01_dp, -1.000000e+00_dp, 5.000000e-01_dp, 5.000000e-01_dp, -5.000000e-01_dp, & + -1.000000e+00_dp, 5.000000e-01_dp, 5.000000e-01_dp, -5.000000e-01_dp, -1.000000e+00_dp, & + 5.000000e-01_dp, 5.000000e-01_dp, -5.000000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 5.000000e-01_dp /) + REAL(kind=dp), PARAMETER, DIMENSION(150) :: STOICM_5 = (/ & + -5.000000e-01_dp, -1.000000e+00_dp, 5.090000e-01_dp, 4.910000e-01_dp, -4.910000e-01_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 5.000000e-01_dp, & + 5.000000e-01_dp, 5.000000e-01_dp, -5.000000e-01_dp, -1.000000e+00_dp, 5.000000e-01_dp, & + 5.000000e-01_dp, -5.000000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 5.000000e-01_dp, & + -5.000000e-01_dp, 5.000000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 4.400000e-01_dp, 4.100000e-01_dp, -1.000000e+00_dp, 1.500000e-01_dp, 4.000000e-01_dp, & + 2.800000e-01_dp, -1.000000e+00_dp, 2.000000e-01_dp, 1.200000e-01_dp, 6.000000e-01_dp, & + 1.000000e-01_dp, -7.000000e-01_dp, -2.000000e+00_dp, 2.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 3.200000e-01_dp, 5.000000e-02_dp, 1.800000e-01_dp, 1.300000e-01_dp, 3.200000e-01_dp, & + -1.000000e+00_dp, 3.200000e-01_dp, 1.900000e-01_dp, 2.700000e-01_dp, -1.000000e+00_dp, & + 1.180000e+00_dp, -1.000000e+00_dp, 2.000000e-01_dp, 8.000000e-01_dp, 8.000000e-01_dp, & + -8.000000e-01_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.360000e-01_dp, 1.270000e-01_dp, 6.900000e-01_dp, 4.020000e-01_dp, -1.000000e+00_dp, & + 2.880000e-01_dp, 8.640000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 7.500000e-01_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 6.500000e-01_dp, 2.600000e-01_dp, 3.600000e-01_dp, -1.000000e+00_dp, 4.000000e-01_dp, & + 5.800000e-01_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 7.200000e-01_dp, -1.000000e+00_dp, 2.800000e-01_dp, 2.800000e-01_dp, 2.800000e-01_dp, & + -2.800000e-01_dp, 1.000000e+00_dp, 8.300000e-01_dp, -1.000000e+00_dp, 8.300000e-01_dp, & + 1.700000e-01_dp, 1.700000e-01_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 5.700000e-01_dp, 3.900000e-01_dp, 7.500000e-01_dp, 3.000000e-01_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 5.000000e-01_dp, 1.000000e+00_dp, 5.000000e-01_dp, -5.000000e-01_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 8.500000e-01_dp, -1.000000e+00_dp, 1.500000e-01_dp, 5.000000e-02_dp /) + REAL(kind=dp), PARAMETER, DIMENSION(150) :: STOICM_6 = (/ & + 1.000000e-01_dp, 1.500000e-01_dp, 8.000000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 2.000000e+00_dp, -2.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 5.000000e-01_dp, -1.000000e+00_dp, 5.000000e-01_dp, & + 5.000000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 2.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 2.500000e-01_dp, 7.500000e-01_dp, -1.000000e+00_dp, -1.000000e+00_dp /) + REAL(kind=dp), PARAMETER, DIMENSION(150) :: STOICM_7 = (/ & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 2.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 2.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 2.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, -1.000000e+00_dp, 6.000000e-01_dp, 6.000000e-01_dp, & + 4.000000e-01_dp, 4.000000e-01_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 2.000000e+00_dp, 8.500000e-01_dp, -1.000000e+00_dp, 1.500000e-01_dp, & + 8.500000e-01_dp, 1.500000e-01_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 2.000000e+00_dp, 1.500000e+00_dp, 5.000000e-01_dp, & + 2.000000e+00_dp, 2.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp /) + REAL(kind=dp), PARAMETER, DIMENSION(59) :: STOICM_8 = (/ & + 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, & + 3.730000e-01_dp, 6.270000e-01_dp, 3.680000e-01_dp, 2.590000e-01_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 6.700000e-01_dp, 2.600000e-01_dp, 3.600000e-01_dp, & + 5.800000e-01_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, -1.000000e+00_dp, 7.000000e-01_dp, & + 3.000000e-01_dp, 3.000000e-01_dp, 1.000000e+00_dp, 3.000000e-01_dp, 7.000000e-01_dp, & + -1.000000e+00_dp, 5.000000e-01_dp, 1.000000e+00_dp, 5.000000e-01_dp, 1.000000e+00_dp, & + 1.000000e+00_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp, & + 3.200000e-01_dp, 5.000000e-02_dp, 1.800000e-01_dp, 1.300000e-01_dp, 3.200000e-01_dp, & + -1.000000e+00_dp, 3.200000e-01_dp, 1.900000e-01_dp, 1.000000e+00_dp, 2.700000e-01_dp, & + 1.800000e-01_dp, -1.000000e+00_dp, 1.000000e+00_dp, 1.000000e+00_dp /) + REAL(kind=dp), PARAMETER, DIMENSION(1259) :: STOICM = (/& + STOICM_0, STOICM_1, STOICM_2, STOICM_3, STOICM_4, & + STOICM_5, STOICM_6, STOICM_7, STOICM_8 /) + + +END MODULE gckpp_adj_StoichiomSP + diff --git a/code/adjoint/gckpp_adj_Util.f90 b/code/adjoint/gckpp_adj_Util.f90 new file mode 100644 index 0000000..8d7412f --- /dev/null +++ b/code/adjoint/gckpp_adj_Util.f90 @@ -0,0 +1,470 @@ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Auxiliary Routines File +! +! Generated by KPP-2.2 symbolic chemistry Kinetics PreProcessor +! (http://www.cs.vt.edu/~asandu/Software/KPP) +! KPP is distributed under GPL, the general public licence +! (http://www.gnu.org/copyleft/gpl.html) +! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa +! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech +! With important contributions from: +! M. Damian, Villanova University, USA +! R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany +! +! File : gckpp_adj_Util.f90 +! Time : Tue May 14 19:43:54 2013 +! Working directory : /home/daven/kpp-2.2.1/GC_KPP +! Equation file : gckpp_adj.kpp +! Output root filename : gckpp_adj +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +MODULE gckpp_adj_Util + + USE gckpp_adj_Parameters + IMPLICIT NONE + +CONTAINS + + + +! User INLINED Utility Functions + +! End INLINED Utility Functions + + ! Need to add this to the INLINE +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_KPP( ) +! +!****************************************************************************** +! Subroutine INIT_KPP allocates global arrays (dkh, 06/07/06) +! +! +! NOTES: +! (1 ) Should make this an inlines utility? +! (2 ) Use LAMBDA_P instead of SUM_LAMBDA. (dkh, 10/16/06) +! (3 ) Now define JCOEFF here and initialize RCONST2RRATE array. (dkh, 10/16/06) +! (4 ) Update to GCv8, now use VAR_R_ADJ instead of LAMBDA_P. It is not +! dynamically allocated. +!****************************************************************************** +! + ! Reference to f90 modules + ! Modified for reaction rate sensitivities (tww, 05/08/12) + USE GCKPP_ADJ_GLOBAL, ONLY : NCOEFF, NCOEFF_EM + USE GCKPP_ADJ_GLOBAL, ONLY : JCOEFF + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + USE ADJ_ARRAYS_MOD, ONLY : ID_RRATES, NRRATES + USE GCKPP_ADJ_GLOBAL, ONLY : DMAP + USE GCKPP_ADJ_PARAMETERS + + ! Local variables + INTEGER :: I + + !================================================================= + ! INIT_KPP begins here! + !================================================================= + + ! Select ALL reaction rate constants + ! Grab emissions rates here (tww, 05/08/12) + DO I = 1, NCOEFF_EM-1 + JCOEFF(I) = I + 228 + ENDDO + JCOEFF(NCOEFF_EM) = 244 + + ! Get reaction rates from input.gcadj (tww, 05/08/12) + IF ( LADJ_RRATE ) THEN + DO I = NCOEFF_EM+1, NCOEFF_EM+NRRATES + JCOEFF(I) = ID_RRATES(I-NCOEFF_EM) + ENDDO + ENDIF + + ! emissions + DMAP(1 ) = ind_NO + DMAP(2 ) = ind_NO2 + DMAP(3 ) = ind_CO + DMAP(4 ) = ind_ALK4 + DMAP(5 ) = ind_ISOP + DMAP(6 ) = ind_ACET + DMAP(7 ) = ind_PRPE + DMAP(8 ) = ind_C3H8 + DMAP(9 ) = ind_C2H6 + DMAP(10) = ind_MEK + DMAP(11) = ind_ALD2 + DMAP(12) = ind_CH2O + DMAP(13) = ind_O3 + DMAP(14) = ind_HNO3 + + ! Return to calling program + END SUBROUTINE INIT_KPP + +!------------------------------------------------------------------------------ + + +! Utility Functions from KPP_HOME/util/util +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! UTIL - Utility functions +! Arguments : +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +! **************************************************************** +! +! InitSaveData - Opens the data file for writing +! Parameters : +! +! **************************************************************** + + SUBROUTINE InitSaveData () + + USE gckpp_adj_Parameters + + open(10, file='gckpp_adj.dat') + + END SUBROUTINE InitSaveData + +! End of InitSaveData function +! **************************************************************** + +! **************************************************************** +! +! SaveData - Write LOOKAT species in the data file +! Parameters : +! +! **************************************************************** + + SUBROUTINE SaveData () + + USE gckpp_adj_Global + USE gckpp_adj_Monitor + + INTEGER i + + WRITE(10,999) (TIME-TSTART)/3600.D0, & + (C(LOOKAT(i))/CFACTOR, i=1,NLOOKAT) +999 FORMAT(E24.16,100(1X,E24.16)) + + END SUBROUTINE SaveData + +! End of SaveData function +! **************************************************************** + +! **************************************************************** +! +! CloseSaveData - Close the data file +! Parameters : +! +! **************************************************************** + + SUBROUTINE CloseSaveData () + + USE gckpp_adj_Parameters + + CLOSE(10) + + END SUBROUTINE CloseSaveData + +! End of CloseSaveData function +! **************************************************************** + +! **************************************************************** +! +! GenerateMatlab - Generates MATLAB file to load the data file +! Parameters : +! It will have a character string to prefix each +! species name with. +! +! **************************************************************** + + SUBROUTINE GenerateMatlab ( PREFIX ) + + USE gckpp_adj_Parameters + USE gckpp_adj_Global + USE gckpp_adj_Monitor + + + CHARACTER(LEN=8) PREFIX + INTEGER i + + open(20, file='gckpp_adj.m') + write(20,*) 'load gckpp_adj.dat;' + write(20,990) PREFIX +990 FORMAT(A1,'c = gckpp_adj;') + write(20,*) 'clear gckpp_adj;' + write(20,991) PREFIX, PREFIX +991 FORMAT(A1,'t=',A1,'c(:,1);') + write(20,992) PREFIX +992 FORMAT(A1,'c(:,1)=[];') + + do i=1,NLOOKAT + write(20,993) PREFIX, SPC_NAMES(LOOKAT(i)), PREFIX, i +993 FORMAT(A1,A6,' = ',A1,'c(:,',I2,');') + end do + + CLOSE(20) + + END SUBROUTINE GenerateMatlab + +! End of GenerateMatlab function +! **************************************************************** + + +! End Utility Functions from KPP_HOME/util/util +! End of UTIL function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Shuffle_user2kpp - function to copy concentrations from USER to KPP +! Arguments : +! V_USER - Concentration of variable species in USER's order +! V - Concentrations of variable species (local) +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE Shuffle_user2kpp ( V_USER, V ) + +! V_USER - Concentration of variable species in USER's order + REAL(kind=dp) :: V_USER(NVAR) +! V - Concentrations of variable species (local) + REAL(kind=dp) :: V(NVAR) + + V(52) = V_USER(1) + V(49) = V_USER(2) + V(71) = V_USER(3) + V(22) = V_USER(4) + V(62) = V_USER(5) + V(53) = V_USER(6) + V(23) = V_USER(7) + V(16) = V_USER(8) + V(69) = V_USER(9) + V(47) = V_USER(10) + V(1) = V_USER(11) + V(2) = V_USER(12) + V(3) = V_USER(13) + V(4) = V_USER(14) + V(5) = V_USER(15) + V(6) = V_USER(16) + V(7) = V_USER(17) + V(8) = V_USER(18) + V(9) = V_USER(19) + V(10) = V_USER(20) + V(74) = V_USER(21) + V(35) = V_USER(22) + V(88) = V_USER(23) + V(50) = V_USER(24) + V(36) = V_USER(25) + V(19) = V_USER(26) + V(17) = V_USER(27) + V(61) = V_USER(28) + V(24) = V_USER(29) + V(56) = V_USER(30) + V(29) = V_USER(31) + V(84) = V_USER(32) + V(58) = V_USER(33) + V(66) = V_USER(34) + V(41) = V_USER(35) + V(67) = V_USER(36) + V(39) = V_USER(37) + V(65) = V_USER(38) + V(43) = V_USER(39) + V(46) = V_USER(40) + V(60) = V_USER(41) + V(80) = V_USER(42) + V(55) = V_USER(43) + V(78) = V_USER(44) + V(26) = V_USER(45) + V(27) = V_USER(46) + V(86) = V_USER(47) + V(76) = V_USER(48) + V(75) = V_USER(49) + V(90) = V_USER(50) + V(28) = V_USER(51) + V(59) = V_USER(52) + V(40) = V_USER(53) + V(77) = V_USER(54) + V(51) = V_USER(55) + V(25) = V_USER(56) + V(85) = V_USER(57) + V(82) = V_USER(58) + V(87) = V_USER(59) + V(89) = V_USER(60) + V(83) = V_USER(61) + V(21) = V_USER(62) + V(44) = V_USER(63) + V(70) = V_USER(64) + V(37) = V_USER(65) + V(18) = V_USER(66) + V(63) = V_USER(67) + V(48) = V_USER(68) + V(38) = V_USER(69) + V(54) = V_USER(70) + V(73) = V_USER(71) + V(72) = V_USER(72) + V(30) = V_USER(73) + V(31) = V_USER(74) + V(32) = V_USER(75) + V(68) = V_USER(76) + V(81) = V_USER(77) + V(57) = V_USER(78) + V(79) = V_USER(79) + V(45) = V_USER(80) + V(33) = V_USER(81) + V(64) = V_USER(82) + V(42) = V_USER(83) + V(34) = V_USER(84) + V(20) = V_USER(85) + V(11) = V_USER(86) + V(12) = V_USER(87) + V(13) = V_USER(88) + V(14) = V_USER(89) + +END SUBROUTINE Shuffle_user2kpp + +! End of Shuffle_user2kpp function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Shuffle_kpp2user - function to restore concentrations from KPP to USER +! Arguments : +! V - Concentrations of variable species (local) +! V_USER - Concentration of variable species in USER's order +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE Shuffle_kpp2user ( V, V_USER ) + +! V - Concentrations of variable species (local) + REAL(kind=dp) :: V(NVAR) +! V_USER - Concentration of variable species in USER's order + REAL(kind=dp) :: V_USER(NVAR) + + V_USER(1) = V(52) + V_USER(2) = V(49) + V_USER(3) = V(71) + V_USER(4) = V(22) + V_USER(5) = V(62) + V_USER(6) = V(53) + V_USER(7) = V(23) + V_USER(8) = V(16) + V_USER(9) = V(69) + V_USER(10) = V(47) + V_USER(11) = V(1) + V_USER(12) = V(2) + V_USER(13) = V(3) + V_USER(14) = V(4) + V_USER(15) = V(5) + V_USER(16) = V(6) + V_USER(17) = V(7) + V_USER(18) = V(8) + V_USER(19) = V(9) + V_USER(20) = V(10) + V_USER(21) = V(74) + V_USER(22) = V(35) + V_USER(23) = V(88) + V_USER(24) = V(50) + V_USER(25) = V(36) + V_USER(26) = V(19) + V_USER(27) = V(17) + V_USER(28) = V(61) + V_USER(29) = V(24) + V_USER(30) = V(56) + V_USER(31) = V(29) + V_USER(32) = V(84) + V_USER(33) = V(58) + V_USER(34) = V(66) + V_USER(35) = V(41) + V_USER(36) = V(67) + V_USER(37) = V(39) + V_USER(38) = V(65) + V_USER(39) = V(43) + V_USER(40) = V(46) + V_USER(41) = V(60) + V_USER(42) = V(80) + V_USER(43) = V(55) + V_USER(44) = V(78) + V_USER(45) = V(26) + V_USER(46) = V(27) + V_USER(47) = V(86) + V_USER(48) = V(76) + V_USER(49) = V(75) + V_USER(50) = V(90) + V_USER(51) = V(28) + V_USER(52) = V(59) + V_USER(53) = V(40) + V_USER(54) = V(77) + V_USER(55) = V(51) + V_USER(56) = V(25) + V_USER(57) = V(85) + V_USER(58) = V(82) + V_USER(59) = V(87) + V_USER(60) = V(89) + V_USER(61) = V(83) + V_USER(62) = V(21) + V_USER(63) = V(44) + V_USER(64) = V(70) + V_USER(65) = V(37) + V_USER(66) = V(18) + V_USER(67) = V(63) + V_USER(68) = V(48) + V_USER(69) = V(38) + V_USER(70) = V(54) + V_USER(71) = V(73) + V_USER(72) = V(72) + V_USER(73) = V(30) + V_USER(74) = V(31) + V_USER(75) = V(32) + V_USER(76) = V(68) + V_USER(77) = V(81) + V_USER(78) = V(57) + V_USER(79) = V(79) + V_USER(80) = V(45) + V_USER(81) = V(33) + V_USER(82) = V(64) + V_USER(83) = V(42) + V_USER(84) = V(34) + V_USER(85) = V(20) + V_USER(86) = V(11) + V_USER(87) = V(12) + V_USER(88) = V(13) + V_USER(89) = V(14) + +END SUBROUTINE Shuffle_kpp2user + +! End of Shuffle_kpp2user function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! GetMass - compute total mass of selected atoms +! Arguments : +! CL - Concentration of all species (local) +! Mass - value of mass balance +! +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +SUBROUTINE GetMass ( CL, Mass ) + +! CL - Concentration of all species (local) + REAL(kind=dp) :: CL(NSPEC) +! Mass - value of mass balance + REAL(kind=dp) :: Mass(1) + + +END SUBROUTINE GetMass + +! End of GetMass function +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +END MODULE gckpp_adj_Util + diff --git a/code/adjoint/geos_chem_adj_mod.f b/code/adjoint/geos_chem_adj_mod.f new file mode 100644 index 0000000..55d573c --- /dev/null +++ b/code/adjoint/geos_chem_adj_mod.f @@ -0,0 +1,4342 @@ +!$Id: geos_chem_adj_mod.f,v 1.33 2012/09/24 21:44:47 yanko Exp $ +! ============================================================= +! + MODULE GEOS_CHEM_ADJ_MOD +! +!****************************************************************************** +! +! +! GGGGGG CCCCCC A DDDDD J OOO I N N TTTTTTT +! G C A A D D J O O I NN N T +! G GGG C == AAAAA D D J 0 O I N N N T +! G G C A A D D J J 0 O I N NN T +! GGGGGG CCCCCC A A DDDDD JJJ OOO I N N T +! +! +! for 4 x 5, 2 x 2.5 global grids and 1 x 1 nested grids +! +! Contact: Daven Henze (daven.henze@colorado.edu) +! +!****************************************************************************** +! +! See the GEOS-Chem-Adj wiki: +! +! http://wiki.seas.harvard.edu/geos-chem/index.php/GEOS-Chem_Adjoint +! +! for the most up-to-date GEOS-CHEM documentation on the following topics: +! +! - installation, compilation, and execution +! - coding practice and style +! - input files and met field data files +! - horizontal and vertical resolution +! - modification history +! +!****************************************************************************** + + IMPLICIT NONE + + ! Header files +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic switches, NJDAY +# include "CMN_GCTM" ! Physical constants +# include "define_adj.h" ! Obs operators + + CONTAINS + + SUBROUTINE DO_GEOS_CHEM_ADJ + + ! References to F90 modules + USE A3_READ_MOD, ONLY : GET_A3_FIELDS + USE A3_READ_MOD, ONLY : OPEN_A3_FIELDS + USE A3_READ_MOD, ONLY : UNZIP_A3_FIELDS + USE A6_READ_MOD, ONLY : GET_A6_FIELDS + USE A6_READ_MOD, ONLY : OPEN_A6_FIELDS + USE A6_READ_MOD, ONLY : UNZIP_A6_FIELDS + USE BENCHMARK_MOD, ONLY : STDRUN + USE CARBON_MOD, ONLY : WRITE_GPROD_APROD + USE CONVECTION_MOD, ONLY : DO_CONVECTION + USE COMODE_MOD, ONLY : INIT_COMODE + USE DIAG_MOD, ONLY : DIAGCHLORO + USE DIAG41_MOD, ONLY : DIAG41, ND41 + USE DIAG42_MOD, ONLY : DIAG42, ND42 + USE DIAG48_MOD, ONLY : DIAG48, ITS_TIME_FOR_DIAG48 + USE DIAG49_MOD, ONLY : DIAG49, ITS_TIME_FOR_DIAG49 + USE DIAG50_MOD, ONLY : DIAG50, DO_SAVE_DIAG50 + USE DIAG51_MOD, ONLY : DIAG51, DO_SAVE_DIAG51 + USE DIAG_OH_MOD, ONLY : PRINT_DIAG_OH + USE DAO_MOD, ONLY : AD, AIRQNT + USE DAO_MOD, ONLY : AVGPOLE, CLDTOPS + USE DAO_MOD, ONLY : CONVERT_UNITS, COPY_I6_FIELDS + USE DAO_MOD, ONLY : COSSZA, INIT_DAO + USE DAO_MOD, ONLY : INTERP, PS1 + USE DAO_MOD, ONLY : PS2, PSC2 + USE DAO_MOD, ONLY : T, TS + USE DAO_MOD, ONLY : SUNCOS, SUNCOSB + USE DAO_MOD, ONLY : SUNCOS_5hr + USE DAO_MOD, ONLY : MAKE_RH + USE DRYDEP_MOD, ONLY : DO_DRYDEP + USE EMISSIONS_MOD, ONLY : DO_EMISSIONS + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_BPCH, IU_DEBUG + USE FILE_MOD, ONLY : IU_ND48, IU_SMV2LOG + USE FILE_MOD, ONLY : CLOSE_FILES + USE GLOBAL_CH4_MOD, ONLY : INIT_GLOBAL_CH4, CH4_AVGTP + USE GCAP_READ_MOD, ONLY : GET_GCAP_FIELDS + USE GCAP_READ_MOD, ONLY : OPEN_GCAP_FIELDS + USE GCAP_READ_MOD, ONLY : UNZIP_GCAP_FIELDS + USE GWET_READ_MOD, ONLY : GET_GWET_FIELDS + USE GWET_READ_MOD, ONLY : OPEN_GWET_FIELDS + USE GWET_READ_MOD, ONLY : UNZIP_GWET_FIELDS + USE I6_READ_MOD, ONLY : GET_I6_FIELDS_1 + USE I6_READ_MOD, ONLY : GET_I6_FIELDS_2 + USE I6_READ_MOD, ONLY : OPEN_I6_FIELDS + USE I6_READ_MOD, ONLY : UNZIP_I6_FIELDS + USE INPUT_MOD, ONLY : READ_INPUT_FILE + USE LAI_MOD, ONLY : RDISOLAI + USE LIGHTNING_NOX_MOD, ONLY : LIGHTNING + USE LOGICAL_MOD, ONLY : LEMIS, LCHEM, LUNZIP, LDUST + USE LOGICAL_MOD, ONLY : LLIGHTNOX, LPRT, LSTDRUN, LSVGLB + USE LOGICAL_MOD, ONLY : LWAIT, LTRAN, LUPBD, LCONV + USE LOGICAL_MOD, ONLY : LWETD, LTURB, LDRYD, LMEGAN + USE LOGICAL_MOD, ONLY : LDYNOCEAN, LSOA, LVARTROP + USE LOGICAL_MOD, ONLY : LSULF + USE MEGAN_MOD, ONLY : INIT_MEGAN + USE MEGAN_MOD, ONLY : UPDATE_T_15_AVG + USE MEGAN_MOD, ONLY : UPDATE_T_DAY + USE PBL_MIX_MOD, ONLY : DO_PBL_MIX + USE OCEAN_MERCURY_MOD, ONLY : MAKE_OCEAN_Hg_RESTART + USE OCEAN_MERCURY_MOD, ONLY : READ_OCEAN_Hg_RESTART + USE PLANEFLIGHT_MOD, ONLY : PLANEFLIGHT + USE PLANEFLIGHT_MOD, ONLY : SETUP_PLANEFLIGHT + USE PRESSURE_MOD, ONLY : INIT_PRESSURE + USE PRESSURE_MOD, ONLY : SET_FLOATING_PRESSURE, get_pedge + USE TIME_MOD, ONLY : GET_NYMDb, GET_NHMSb + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_A3_TIME, GET_FIRST_A3_TIME + USE TIME_MOD, ONLY : GET_A6_TIME, GET_FIRST_A6_TIME + USE TIME_MOD, ONLY : GET_I6_TIME, GET_MONTH + USE TIME_MOD, ONLY : GET_TAU, GET_TAUb + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_TS_DYN + USE TIME_MOD, ONLY : GET_ELAPSED_SEC, GET_TIME_AHEAD + USE TIME_MOD, ONLY : GET_DAY_OF_YEAR, ITS_A_NEW_DAY + USE TIME_MOD, ONLY : ITS_A_NEW_SEASON, GET_SEASON + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH, GET_NDIAGTIME + USE TIME_MOD, ONLY : ITS_A_LEAPYEAR, GET_YEAR + USE TIME_MOD, ONLY : ITS_TIME_FOR_A3, ITS_TIME_FOR_A6 + USE TIME_MOD, ONLY : ITS_TIME_FOR_I6, ITS_TIME_FOR_CHEM + USE TIME_MOD, ONLY : ITS_TIME_FOR_CONV,ITS_TIME_FOR_DEL + USE TIME_MOD, ONLY : ITS_TIME_FOR_DIAG,ITS_TIME_FOR_DYN + USE TIME_MOD, ONLY : ITS_TIME_FOR_EMIS,ITS_TIME_FOR_EXIT + USE TIME_MOD, ONLY : ITS_TIME_FOR_UNIT,ITS_TIME_FOR_UNZIP + USE TIME_MOD, ONLY : ITS_TIME_FOR_BPCH + USE TIME_MOD, ONLY : SET_CT_CONV, SET_CT_DYN + USE TIME_MOD, ONLY : SET_CT_EMIS, SET_CT_CHEM + USE TIME_MOD, ONLY : SET_DIAGb, SET_DIAGe + USE TIME_MOD, ONLY : SET_CURRENT_TIME, PRINT_CURRENT_TIME + USE TIME_MOD, ONLY : SET_ELAPSED_MIN, SYSTEM_TIMESTAMP + USE TRACER_MOD, ONLY : CHECK_STT, N_TRACERS, STT, TCVV + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_A_H2HD_SIM + USE TRACER_MOD, ONLY : ITS_A_MERCURY_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGOX_SIM + USE TRANSPORT_MOD, ONLY : DO_TRANSPORT + USE TROPOPAUSE_MOD, ONLY : READ_TROPOPAUSE, CHECK_VAR_TROP + USE RESTART_MOD, ONLY : MAKE_RESTART_FILE, READ_RESTART_FILE + USE UPBDFLX_MOD, ONLY : DO_UPBDFLX, UPBDFLX_NOY + USE UVALBEDO_MOD, ONLY : READ_UVALBEDO + USE WETSCAV_MOD, ONLY : INIT_WETSCAV, DO_WETDEP + USE XTRA_READ_MOD, ONLY : GET_XTRA_FIELDS, OPEN_XTRA_FIELDS + USE XTRA_READ_MOD, ONLY : UNZIP_XTRA_FIELDS + USE ERROR_MOD, ONLY : IT_IS_NAN, IT_IS_FINITE !yxw + ! USE STATEMENTS FOR ADJOINT + USE CHECKPT_MOD, ONLY : CHK_PSC + USE CHECKPOINT_MOD, ONLY : READ_CONVECTION_CHKFILE + USE CHECKPOINT_MOD, ONLY : READ_PRESSURE_CHKFILE + USE DAO_MOD, ONLY : COPY_I6_FIELDS_ADJ + USE DAO_MOD, ONLY : INTERP_ADJ + USE ERROR_MOD, ONLY : ERROR_STOP + USE I6_READ_MOD, ONLY : OPEN_I6_FIELDS_ADJ + USE I6_READ_MOD, ONLY : GET_I6_FIELDS_1_ADJ + USE A6_READ_MOD, ONLY : OPEN_A6_FIELDS_ADJ + USE A3_READ_MOD, ONLY : OPEN_A3_FIELDS_ADJ + USE GWET_READ_MOD, ONLY : OPEN_GWET_FIELDS_ADJ + USE CHECKPOINT_MOD, ONLY : READ_CHEMISTRY_CHKFILE + USE GEOS_CHEM_MOD, ONLY : DISPLAY_MET + USE GEOS_CHEM_MOD, ONLY : NSECb + USE MEGAN_MOD, ONLY : UPDATE_T_DAY_ADJ + USE MEGAN_MOD, ONLY : UPDATE_T_15_AVG_ADJ + USE TIME_MOD, ONLY : GET_ELAPSED_MIN + USE TIME_MOD, ONLY : SET_ELAPSED_MIN_ADJ + USE TIME_MOD, ONLY : ITS_TIME_FOR_EXIT_ADJ + USE TIME_MOD, ONLY : ITS_A_NEW_DAY_ADJ + USE TIME_MOD, ONLY : ITS_TIME_FOR_A3_ADJ + USE TIME_MOD, ONLY : ITS_TIME_FOR_A6_ADJ + USE TIME_MOD, ONLY : ITS_TIME_FOR_I6_ADJ + USE TIME_MOD, ONLY : GET_I6_TIME_ADJ + USE TIME_MOD, ONLY : GET_A6_TIME_ADJ + USE TIME_MOD, ONLY : GET_A3_TIME_ADJ + USE TIME_MOD, ONLY : GET_TIME_BEHIND_ADJ + USE TRACER_MOD, ONLY : ITS_A_CO2_SIM + USE TRANSPORT_MOD, ONLY : DO_TRANSPORT_ADJ + ! To save CSPEC_FULL restart (dkh, 02/12/09) + USE LOGICAL_MOD, ONLY : LSVCSPEC + USE RESTART_MOD, ONLY : MAKE_CSPEC_FILE + + !!! geos-fp (lzh, 07/10/2014) + USE TIME_MOD, ONLY : ITS_TIME_FOR_A1 + USE TIME_MOD, ONLY : ITS_TIME_FOR_A1_ADJ + USE TIME_MOD, ONLY : ITS_TIME_FOR_I3_ADJ + USE TIME_MOD, ONLY : GET_I3_TIME_ADJ + USE TIME_MOD, ONLY : GET_A1_TIME_ADJ + USE GEOSFP_READ_MOD + + ! adjoint specific modules (adj_group, 6/09/09) + USE ADJ_ARRAYS_MOD, ONLY : DAY_OF_SIM, DAYS + USE ADJ_ARRAYS_MOD, ONLY : ITS_TIME_FOR_OBS + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : CHECK_STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : CHECK_STT_05x0666_ADJ + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE TIME_MOD, ONLY : SET_DIRECTION + USE CHEMISTRY_ADJ_MOD, ONLY : DO_CHEMISTRY_ADJ + USE CHECKPT_MOD, ONLY : MAKE_ADJ_FILE + USE CONVECTION_ADJ_MOD,ONLY : DO_CONVECTION_ADJ + USE EMISSIONS_ADJ_MOD, ONLY : DO_EMISSIONS_ADJ + USE LOGICAL_ADJ_MOD, ONLY : LADJ_TRAJ, LADJ_CHEM + USE LOGICAL_ADJ_MOD, ONLY : LAPSRC + USE LOGICAL_ADJ_MOD, ONLY : LSENS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE PBL_MIX_ADJ_MOD, ONLY : DO_PBL_MIX_ADJ + USE UPBDFLX_ADJ_MOD, ONLY : UPBDFLX_NOY_ADJ + USE UPBDFLX_ADJ_MOD, ONLY : DO_UPBDFLX_ADJ + USE WETSCAV_ADJ_MOD, ONLY : INIT_WETSCAV_ADJ + USE WETSCAV_ADJ_MOD, ONLY : ADJ_INIT_WETSCAV + USE WETSCAV_ADJ_MOD, ONLY : DO_WETDEP_ADJ + + ! dkh debug + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD, ICSFD + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ + USE DRYDEP_MOD, ONLY : DEPSAV + + ! mkeller: weak constraint + + USE WEAK_CONSTRAINT_MOD, ONLY : READ_FORCE_U_FILE + USE WEAK_CONSTRAINT_MOD, ONLY : FORCE_U_FULLGRID + USE WEAK_CONSTRAINT_MOD, ONLY : DO_WEAK_CONSTRAINT + USE WEAK_CONSTRAINT_MOD, ONLY : ITS_TIME_FOR_U + USE WEAK_CONSTRAINT_MOD, ONLY : SET_CT_U + USE WEAK_CONSTRAINT_MOD, ONLY : SET_CT_MAIN_U + USE WEAK_CONSTRAINT_MOD, ONLY : CT_SUB_U + USE WEAK_CONSTRAINT_MOD, ONLY : CT_MAIN_U + USE WEAK_CONSTRAINT_MOD, ONLY : CALC_GRADNT_U + + ! Force all variables to be declared explicitly +! IMPLICIT NONE +! +! ! Header files +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_DIAG" ! Diagnostic switches, NJDAY +!# include "CMN_GCTM" ! Physical constants +!# include "define_adj.h" ! Obs operators + + ! Local variables + LOGICAL :: FIRST = .TRUE. + LOGICAL :: LXTRA + INTEGER :: I, IOS, J, K, L + INTEGER :: N, JDAY, NDIAGTIME, N_DYN + !---------------------------------------------------------------------- + ! BUG FIX: now use value of NSECb from geos_chem_mod.f (dkh, 01/25/10) + !INTEGER :: N_DYN_STEPS, NSECb, N_STEP, DATE(2) + INTEGER :: N_DYN_STEPS, N_STEP, DATE(2) + !---------------------------------------------------------------------- + INTEGER :: YEAR, MONTH, DAY, DAY_OF_YEAR + INTEGER :: SEASON, NYMD, NYMDb, NHMS + INTEGER :: ELAPSED_SEC, NHMSb + REAL*8 :: TAU, TAUb + CHARACTER(LEN=255) :: ZTYPE + + ! (dkh, ks, mak, cs 06/12/09) + INTEGER :: FINAL_ELAPSED_MIN + INTEGER :: MIN_ADJ + INTEGER :: NSECb_ADJ + INTEGER :: I62_DATE(2) + INTEGER :: BEHIND_DATE(2) + +! CONTAINS +! +! SUBROUTINE DO_GEOS_CHEM_ADJ + + INTEGER, SAVE :: LOCAL_DAY + + ! mkeller: logical variable to initialize weak constraint 4D-Var + LOGICAL :: FIRST_WEAK + + !================================================================= + ! GEOS-CHEM-ADJ starts here! + !================================================================= + + !================================================================= + ! ***** I N I T I A L I Z A T I O N ***** + !================================================================= + + !---------------------------------------------------------------------- + ! BUG FIXED: now reference NSECb from geos_chem_mod. (dkh, 01/25/10) + ! old code: + !! Scary but true -- take this out and NSECb will be corrupt + !! Need to find the memory leak somewhere? (dkh, 11/07/09) + !print*, ' NSECb adj = ', NSECb + !---------------------------------------------------------------------- + + ! mkeller + FIRST_WEAK = .TRUE. + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'B A C K W A R D I N T E G R A T I O N' + + ! Now set DIRECTION to -1 to indicate that it's adjoint integration + CALL SET_DIRECTION( -1 ) + + ! Initialize allocatable arrays + !CALL INIT_ADJOINT + !CALL INIT_ADJ_ANTHROEMS + + ! Move these to fwd model to facilitate forcing calculation therein + !CALL INIT_CF_REGION + ! + !!fp + !IF (LADJ_FDEP) THEN + ! CALL INIT_UNITS_DEP + !ENDIF + + + ! Open BACKWD_met file + CALL DISPLAY_MET(165,0) + + ! Define time variables for use below + NHMS = GET_NHMS() + NYMD = GET_NYMD() + TAU = GET_TAU() + + ! Check for NaN, Negatives, Infinities in STT_ADJ once per hour + IF ( ITS_TIME_FOR_DIAG() ) THEN + + ! Sometimes STT in the stratosphere can be negative at + ! the nested-grid domain edges. Force them to be zero before + ! CHECK_STT (yxw) +#if defined( GEOS_5 ) && defined( GRID05x0666 ) + CALL CHECK_STT_05x0666_ADJ( 'End of Dynamic Loop' ) +#endif + + CALL CHECK_STT_ADJ( 'End of Dynamic Loop' ) + ENDIF + + ! BUG FIX: need to reset EMS_SF_ADJ so that gradients do not + ! accumulate from one iteration to the next. (zj, dkh, 07/30/10) + IF ( LADJ_EMS ) EMS_SF_ADJ = 0D0 + + ! for new strat. chem. (hml, 08/09/11, adj32_025) + IF ( LADJ_STRAT ) THEN + PROD_SF_ADJ = 0D0 + LOSS_SF_ADJ = 0D0 + ENDIF + + ! for rrate sensitivity (hml, 06/08/13) + IF ( LADJ_RRATE ) RATE_SF_ADJ = 0D0 + + !================================================================= + ! ***** 6 - H O U R T I M E S T E P L O O P ***** + !================================================================= + + ! Echo message before first timestep + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) REPEAT( '*', 44 ) + WRITE( 6, '(a)' ) '* B e g i n T i m e S t e p p i n g !! *' + WRITE( 6, '(a)' ) REPEAT( '*', 44 ) + WRITE( 6, '(a)' ) + + ! NSTEP is the number of dynamic timesteps w/in a 6-h interval + ! N_DYN_STEPS = 360 / GET_TS_DYN() + ! now with geos-fp (lzh, 07/10/2014) +#if defined( GEOS_FP ) + N_DYN_STEPS = 180 / GET_TS_DYN() ! GEOS-5.7.x has a 3-hr interval +#else + N_DYN_STEPS = 360 / GET_TS_DYN() ! All other met has a 6hr interval +#endif + + FINAL_ELAPSED_MIN = GET_ELAPSED_MIN() + + ! Start a new 6-h loop + DO + + ! Get dynamic timestep in seconds + N_DYN = 60d0 * GET_TS_DYN() + + ! Compute time parameters at start of 6-h loop + CALL SET_CURRENT_TIME + + !================================================================= + ! ***** D Y N A M I C T I M E S T E P L O O P ***** + !================================================================= + DO MIN_ADJ = FINAL_ELAPSED_MIN - GET_TS_DYN(), 0, - GET_TS_DYN() + + ! mak debug + WRITE(6,*)'start of adj time step' + WRITE(6,*)'MIN/MAX OF STT_ADJ:',minval(stt_adj),maxval(stt_adj) + + CALL SET_ELAPSED_MIN_ADJ + + ! Compute & print time quantities at start of dyn step + CALL SET_CURRENT_TIME + + ! Set time variables for dynamic loop + !DAY = GET_DAY() + DAY_OF_YEAR = GET_DAY_OF_YEAR() + ELAPSED_SEC = GET_ELAPSED_SEC() + MONTH = GET_MONTH() + NHMS = GET_NHMS() + NYMD = GET_NYMD() + TAU = GET_TAU() + YEAR = GET_YEAR() + SEASON = GET_SEASON() + + !CALL MAKE_ADJOINT_CHKFILE( NYMD, NHMS, TAU ) + + ! Get info from the perturbed forward run + CALL LOAD_CHECKPT_DATA( NYMD, NHMS ) + + ! mkeller: weak constraint stuff + IF(DO_WEAK_CONSTRAINT) THEN + + IF( .NOT. FIRST_WEAK) THEN + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) + CALL CALC_GRADNT_U(GET_NYMD(), GET_NHMS()) + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) + ENDIF + + ENDIF + + !============================================================ + ! ***** R E A D M E T F I E L D S ***** + !============================================================ + ! If it is the first time through, we will use i6 field from the + ! forward calculation, and all we need to do is set NSECb_ADJ + IF ( FIRST ) THEN + + ! This only happens if stop time is a 6h interval, in which + ! case NSECb gets advanced 6hrs beyond what it actually was + ! last used as, so set it back here. +! IF ( NSECb > GET_ELAPSED_SEC() ) THEN +! NSECb = NSECb - 6 * 3600 +! WRITE(6,*) ' -- Pushing NSECb back by 6h ' +! ENDIF + ! now with geos-fp (lzh, 04/29/2014) +#if defined ( GEOS_FP ) + IF ( NSECb > GET_ELAPSED_SEC() ) THEN + NSECb = NSECb - 3 * 3600 + WRITE(6,*) ' -- Pushing NSECb back by 3h ' + ENDIF +#else + IF ( NSECb > GET_ELAPSED_SEC() ) THEN + NSECb = NSECb - 6 * 3600 + WRITE(6,*) ' -- Pushing NSECb back by 6h ' + ENDIF +#endif + + NSECb_ADJ = NSECb + + ! Instead of this, now keep the currently loaded I-6 met + ! arrays that don't get interpolated (ie SLP) as _TMP. + ! They will come into rotation when COPY_I6_FIELDS_ADJ + ! is called. (dkh, 06/17/09) +! ! GET SLP1 and TROPP1 at the beginning of the last I-6 interval +! I62_DATE = GET_TIME_BEHIND_ADJ( +! & ( GET_ELAPSED_SEC() - NSECb ) / 60 ) +! +! +! CALL OPEN_I6_FIELDS_ADJ( I62_DATE(1), I62_DATE(2) ) +! CALL GET_I6_FIELDS_2( I62_DATE(1), I62_DATE(2) ) + + +! ! Now we don't reset this until after reading daily data + !FIRST = .FALSE. + ENDIF + + !============================================================== + ! ***** R E A D I - 6 F I E L D S ***** + !============================================================== +!!! geos-fp (lzh, 07/10/2014) +#if defined( GEOS_FP ) + IF ( ITS_TIME_FOR_I3_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR I-3 ' + + !================================================================= + ! ***** C O P Y I - 3 F I E L D S ***** + ! + ! The I-6 fields at the beginning of the next ( forward ) + ! timestep become the fields at the end of this timestep + !================================================================= + CALL COPY_I6_FIELDS_ADJ + + ! Get the date/time for the previous I-6 data block + BEHIND_DATE = GET_I3_TIME_ADJ() + + ! Open and read files + CALL GEOSFP_READ_I3_1( BEHIND_DATE(1), BEHIND_DATE(2) ) +! CALL OPEN_I6_FIELDS_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) +! CALL GET_I6_FIELDS_1_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) + PRINT*,'I3 DATE = ',BEHIND_DATE(1),BEHIND_DATE(2) + + ! Compute avg pressure at polar caps (for ADJ argument is PS1, not PS2) + CALL AVGPOLE( PS1 ) + + ! Set NSECb_ADJ to be used for the interpolation + ! where NSECb_ADJ is the total elapsed time in seconds at the + ! beginning of the current 6h time step which contains ELAPSED_MIN + NSECb_ADJ = ( MIN_ADJ + GET_TS_DYN() ) * 60 - 3 * 3600 + ENDIF +#else + + IF ( ITS_TIME_FOR_I6_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR I-6 ' + + !================================================================= + ! ***** C O P Y I - 6 F I E L D S ***** + ! + ! The I-6 fields at the beginning of the next ( forward ) + ! timestep become the fields at the end of this timestep + !================================================================= + CALL COPY_I6_FIELDS_ADJ + + ! Get the date/time for the previous I-6 data block + BEHIND_DATE = GET_I6_TIME_ADJ() + + ! Open and read files + CALL OPEN_I6_FIELDS_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) + CALL GET_I6_FIELDS_1_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) + PRINT*,'I6 DATE = ',BEHIND_DATE(1),BEHIND_DATE(2) + + ! Compute avg pressure at polar caps (for ADJ argument is PS1, not PS2) + CALL AVGPOLE( PS1 ) + + ! Set NSECb_ADJ to be used for the interpolation + ! where NSECb_ADJ is the total elapsed time in seconds at the + ! beginning of the current 6h time step which contains ELAPSED_MIN + NSECb_ADJ = ( MIN_ADJ + GET_TS_DYN() ) * 60 - 6 * 3600 + + ENDIF + +! (lzh, 07/10/2014) geos-fp +#endif + + !============================================================== + ! ***** R E A D A - 6 F I E L D S ***** + !============================================================== +! (lzh, 07/10/2014) geos-fp +#if defined( GEOS_FP ) + IF ( ITS_TIME_FOR_A3_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR A-3 ' + + ! Get the date/time for the previous A-3 data block + BEHIND_DATE = GET_A3_TIME_ADJ() + + ! Open and read files + CALL GEOSFP_READ_A3( BEHIND_DATE(1), BEHIND_DATE(2) ) + + ENDIF +#else + + IF ( ITS_TIME_FOR_A6_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR A-6 ' + + ! Get the date/time for the previous A-6 data block + BEHIND_DATE = GET_A6_TIME_ADJ() + + ! Open and read files + CALL OPEN_A6_FIELDS_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) + CALL GET_A6_FIELDS( BEHIND_DATE(1), BEHIND_DATE(2) ) + + ENDIF +#endif + + !============================================================== + ! ***** R E A D A - 3 F I E L D S ***** + !============================================================== +! (lzh, 07/10/2014) geos-fp +#if defined( GEOS_FP ) + IF ( ITS_TIME_FOR_A1_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR A-1 ' + + ! Get the date/time for the previous A-1 data block + BEHIND_DATE = GET_A1_TIME_ADJ() + + ! Open & read A-3 fields + CALL GEOSFP_READ_A1( BEHIND_DATE(1), BEHIND_DATE(2) ) +! CALL OPEN_A3_FIELDS_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) +! CALL GET_A3_FIELDS( BEHIND_DATE(1), BEHIND_DATE(2) ) + + ! Update daily mean temperature archive for MEGAN biogenics + ! For adjoint, read in checkpointed values (dkh, 01/23/10) + IF ( LMEGAN ) CALL UPDATE_T_DAY_ADJ + ENDIF +#else + IF ( ITS_TIME_FOR_A3_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR A-3 ' + + ! Get the date/time for the previous A-3 data block + BEHIND_DATE = GET_A3_TIME_ADJ() + + ! Open & read A-3 fields + CALL OPEN_A3_FIELDS_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) + CALL GET_A3_FIELDS( BEHIND_DATE(1), BEHIND_DATE(2) ) + + ! Update daily mean temperature archive for MEGAN biogenics + ! For adjoint, read in checkpointed values (dkh, 01/23/10) + IF ( LMEGAN ) CALL UPDATE_T_DAY_ADJ + +#if defined( GEOS_3 ) + ! + IF ( LDUST ) THEN + CALL OPEN_GWET_FIELDS_ADJ( BEHIND_DATE(1), + & BEHIND_DATE(2) ) + CALL GET_GWET_FIELDS( BEHIND_DATE(1), BEHIND_DATE(2) ) + ENDIF +#endif + + ENDIF + +#endif + + !DAY_OF_SIM initialized to -1 in INIT_ADJ_ARRAYS + ! keeps tabs of day of simulation, going backward in time + ! this is handy for storing diagnostic files that have dimensions + ! (IIPAR,JJPAR,DAYS), where DAYS is number of days in simulation + ! (adj_group, 6/09/09) + ! bug fix: can't use ITS_A_NEW_DAY because it advances to the + ! next day when time is 00h + IF( DAY_OF_SIM == -1) THEN + + DAY_OF_SIM = DAYS + LOCAL_DAY = GET_DAY_OF_YEAR() + + PRINT*, 'TODAY IS', DAY_OF_SIM, 'th day of simulation' + + ELSEIF( LOCAL_DAY .ne. GET_DAY_OF_YEAR() ) THEN + + DAY_OF_SIM = DAY_OF_SIM - 1 + LOCAL_DAY = GET_DAY_OF_YEAR() + + PRINT*, 'TODAY IS',DAY_OF_SIM,'th day of simulation' + + ENDIF + + + !============================================================== + ! ***** M O N T H L Y O R S E A S O N A L D A T A ***** + !============================================================== + + ! UV albedoes + IF ( LCHEM .and. ITS_A_NEW_MONTH() ) THEN + CALL READ_UVALBEDO( MONTH ) + ENDIF + + ! Fossil fuel emissions (SMVGEAR) + ! THIS IS IN THE FORWARD DRIVER, but NOT IN THE GCV7 ADJ? + ! (dkh, 06/08/09) + IF ( ITS_A_FULLCHEM_SIM() .or. ITS_A_TAGCO_SIM() ) THEN + IF ( LADJ_EMS .and. ITS_A_NEW_SEASON() ) THEN + CALL ANTHROEMS( SEASON ) + ENDIF + ENDIF + + + !============================================================== + ! ***** D A I L Y D A T A ***** + ! + ! RDLAI returns today's leaf-area index + ! RDSOIL returns today's soil type information + !============================================================== + ! Read daily data at 11:30 p.m. on any new day, not counting the + ! "first" day of the adjoint integration, during which we can + ! still use values from the forward integration. + ! OLD: + !IF ( GET_NHMS() == 233000 .AND. ( .not. FIRST ) ) THEN + ! NEW: make more generic + !IF ( ( GET_NHMS() == 240000 - ( GET_TS_DYN() * 100d0 ) ) + ! NEWER: correctly make more generic (dkh, 10/26/09) + !IF ( ( GET_NHMS() == 236000 - ( GET_TS_DYN() * 100d0 ) ) +! & .AND. ( .not. FIRST ) ) THEN + ! Even NEWER: Now use ITS_A_NEW_DAY_ADJ + IF ( ITS_A_NEW_DAY_ADJ() ) THEN + + ! Now we checkpt XYLAI (dkh, 10/14/09) + !! Read leaf-area index (needed for drydep) + !CALL RDLAI( DAY_OF_YEAR, MONTH ) + + ! For MEGAN biogenics ... + IF ( LMEGAN ) THEN + + ! Read AVHRR daily leaf-area-index + CALL RDISOLAI( GET_DAY_OF_YEAR(), GET_MONTH() ) + + ! Compute 15-day average temperature for MEGAN + ! This will need to be checkpointed or + ! recalculated correctly (dkh, 06/08/09) + ! Now we read in the checkpointed values. + CALL UPDATE_T_15_AVG_ADJ + + ENDIF + + ! Also read soil-type info for fullchem simulation + ! OLD: + !IF ( ITS_A_FULLCHEM_SIM() ) CALL RDSOIL + ! NEW: for v8-02-1 + IF ( ITS_A_FULLCHEM_SIM() .or. ITS_A_H2HD_SIM() ) THEN + CALL RDSOIL + ENDIF + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG ( '### GEOS_CHEM_ADJ: a DAILY DATA' ) + ENDIF + + ENDIF + + ! Reset first-time flag + IF ( FIRST ) FIRST = .FALSE. + + !============================================================== + ! ***** I N T E R P O L A T E Q U A N T I T I E S ***** + ! + ! Interpolate I-6 fields to current dynamic timestep, + ! based on their values at NSEC and NSEC+NTDT + !============================================================== + +#if defined ( GEOS_3 ) + CALL INTERP( NSECb_ADJ, GET_ELAPSED_SEC(), N_DYN ) +#else + IF ( LTRAN ) THEN + CALL INTERP_ADJ( NSECb_ADJ, GET_ELAPSED_SEC(), N_DYN ) + ELSE + CALL INTERP( NSECb_ADJ, GET_ELAPSED_SEC(), N_DYN ) + ENDIF +#endif + + ! If we are not doing transport, then make sure that + ! the floating pressure is set to PSC2 (bdf, bmy, 8/22/02) + IF ( .not. LTRAN ) CALL SET_FLOATING_PRESSURE( PSC2 ) + + ! Compute airmass quantities at each grid box + CALL AIRQNT + + ! OLD: + !! (dkh, 11/07/05) + !! Compute the cosine of the solar zenith angle at each grid box + !CALL COSSZA( GET_DAY_OF_YEAR(), GET_NHMSb(), + ! GET_ELAPSED_SEC(), SUNCOS ) + ! + !! For SMVGEAR II, we also need to compute SUNCOS at + !! the end of this chemistry timestep (bdf, bmy, 4/1/03) + !IF ( LCHEM .and. ITS_A_FULLCHEM_SIM() ) THEN + ! CALL COSSZA( GET_DAY_OF_YEAR(), GET_NHMSb(), + ! GET_ELAPSED_SEC()+GET_TS_CHEM()*60, SUNCOSB ) + !ENDIF + ! NEW for v8-02-01 + ! Compute the cosine of the solar zenith angle array SUNCOS + ! NOTE: SUNCOSB is not really used in PHYSPROC (bmy, 2/13/07) + CALL COSSZA( DAY_OF_YEAR, SUNCOS ) + CALL COSSZA( DAY_OF_YEAR, SUNCOS_5hr, FIVE_HR=.TRUE. ) + + CALL DO_PBL_MIX( .FALSE. ) + + +#if defined( GEOS_3 ) + + ! 1998 GEOS-3 carries the ground temperature and not the air + ! temperature -- thus TS will be 2-3 K too high. As a quick fix, + ! copy the temperature at the first sigma level into TS. + ! (mje, bnd, bmy, 7/3/01) + ! OLD: + !IF ( YEAR == 1998 ) STOP + ! NEW: + IF ( YEAR == 1998 ) THEN + CALL ERROR_STOP( '1998 not supported GEOS-3', + & 'geos_chem_adj_mod.f' ) + ENDIF +#endif + + ! decrement elapsed time +! CALL SET_ELAPSED_MIN_ADJ +! +! CALL SET_CURRENT_TIME +! NHMS = GET_NHMS() +! NYMD = GET_NYMD() + + !============================================================== + ! ***** B E G I N A D J O I N T P R O C E S S E S ***** + ! This is where we start calling adjoint routines in the + ! reverse order of the forward model. + ! (dkh, ks, mak, cs 06/08/09) + !============================================================== + + !============================================================== + ! ***** U P D A T E C O S T F U N C T I O N ***** + !============================================================== + IF ( ITS_TIME_FOR_OBS( ) ) THEN + + ! Update cost function and calculate adjoint forcing + + ! for sensitivity calculations... + IF ( LSENS ) THEN + + CALL CALC_ADJ_FORCE_FOR_SENS + + ! ... for cost functions involving observations (real or pseudo) + ELSE + + CALL CALC_ADJ_FORCE_FOR_OBS + + ENDIF + ENDIF + + ! mkeller: weak constraint stuff + IF ( DO_WEAK_CONSTRAINT ) THEN + IF ( FIRST_WEAK ) THEN + + CALL SET_CT_U( FLIP=.TRUE. ) + + IF ( CT_SUB_U == 0 ) CALL SET_CT_MAIN_U(INCREASE=.FALSE.) + CALL SET_CT_U(INCREASE=.TRUE.) + + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) + + CALL CALC_GRADNT_U(GET_NYMD(), GET_NHMS()) + + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) + + ! first-time flag + FIRST_WEAK = .FALSE. + + ENDIF + ENDIF + + ! Initialize wet scavenging and wetdep fields after + ! the airmass quantities are reset after transport + !IF ( LCONV .or. LWETD ) CALL INIT_WETSCAV_ADJ + ! note: sulfate chemistry adjoint needs SO2s_ADJ and + ! H2O2s_ADJ to be allocated even if LCONV, LWETD = F. + IF ( LCONV .or. LWETD .or. ( LCHEM .and. LSULF ) ) THEN + CALL INIT_WETSCAV_ADJ + ENDIF + + !============================================================== + ! ***** W E T D E P O S I T I O N (rainout + washout) ***** + !============================================================== + IF ( LWETD .and. ITS_TIME_FOR_DYN() ) CALL DO_WETDEP_ADJ + + + !=============================================================== + ! Recalculate the emission and drydep rates here (dkh, 08/06/09) + !=============================================================== + !------------------------------- + ! Test for emission timestep + !------------------------------- + IF ( ITS_TIME_FOR_EMIS() ) THEN + + ! Increment emission counter + CALL SET_CT_EMIS( INCREMENT=.TRUE. ) + + !======================================================== + ! ***** D R Y D E P O S I T I O N ***** + !======================================================== + IF ( LDRYD .and. ( .not. ITS_A_H2HD_SIM() ) ) CALL DO_DRYDEP + + !======================================================== + ! ***** E M I S S I O N S ***** + ! ( only need to do this for fullchem ) + !======================================================== + IF ( LEMIS .and. ( ITS_A_FULLCHEM_SIM() .or. + & ITS_AN_AEROSOL_SIM() )) + & CALL DO_EMISSIONS + + ENDIF + + !=========================================================== + ! ***** C H E M I S T R Y ***** + !=========================================================== + + ! Also need to compute avg P, T for CH4 chemistry (bmy, 1/16/01) + ! fwd: + !IF ( ITS_A_CH4_SIM() ) CALL CH4_AVGTP + ! Now supported (kjw, dkh, 02/12/12, adj32_023) + !IF ( ITS_A_CH4_SIM() ) THEN + ! CALL ERROR_STOP( 'CH4_SIM not supported', 'geos_chem_adj') + !ENDIF + + ! Every chemistry timestep... + IF ( ITS_TIME_FOR_CHEM() ) THEN + + ! mak: try adj chemistry (6/20/09) + IF ( LCHEM .AND. LADJ_CHEM ) THEN + + ! Use dkh checkpt scheme (dkh, 06/12/09) + !CALL READ_CHEMISTRY_CHKFILE( NYMD, NHMS ) + + ! adj_group + IF ( LPRINTFD ) THEN + write(6,*) ' Before CHEMISTRY : = ', + & STT(IFD,JFD,LFD,:) + ENDIF + + + ! Call the appropriate chemistry routine + CALL DO_CHEMISTRY_ADJ + + END IF + + ENDIF + + !------------------------------- + ! Test for emission timestep + !------------------------------- + IF ( ITS_TIME_FOR_EMIS() .and. LADJ_EMS ) THEN + + !======================================================== + ! ***** E M I S S I O N S ***** + !======================================================== + + IF ( LEMIS ) CALL DO_EMISSIONS_ADJ + + ENDIF + + + !============================================================== + ! ***** U N I T C O N V E R S I O N ( J/kg -> J/[v/v] ) ***** + !============================================================== + IF ( ITS_TIME_FOR_UNIT() ) THEN + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG( '### GEOS_CHEM_ADJ: a CONVERT_UNITS:2' ) + ENDIF + + ENDIF + + !===================================================== + ! ***** CONVECTION ADJOINT ***** + !===================================================== + IF ( ITS_TIME_FOR_CONV() ) THEN + + !=========================================================== + ! ***** C L O U D C O N V E C T I O N ***** + !=========================================================== + IF ( LCONV ) THEN + + !-------------------------------------------------------------- + ! ***** CHECKPOINTING EVERY DYNAMIC TIME STEP ***** + !-------------------------------------------------------------- + + ! Use READ_CHK_CON_FILE (dkh, 06/14/09) + !CALL READ_CONVECTION_CHKFILE( NYMD, NHMS ) + + ! dkh debug (dkh, 09/07/09) + print*, ' before DO_CONVECTION_ADJ' + CALL CHECK_STT_ADJ( 'before DO_CONVECTION_ADJ' ) + + CALL DO_CONVECTION_ADJ + + ! dkh debug (dkh, 09/07/09) + print*, ' after DO_CONVECTION_ADJ' + CALL CHECK_STT_ADJ( 'After DO_CONVECTION_ADJ' ) + + ENDIF + + !=========================================================== + ! ***** M I X E D L A Y E R M I X I N G ***** + !=========================================================== + !IF ( LPRINTFD ) THEN + ! CALL DISPLAY_MET(165,3) + ! CALL DISPLAY_MET(165,5) + !ENDIF + + CALL DO_PBL_MIX_ADJ( LTURB ) + + !IF ( LPRINTFD ) THEN + ! CALL DISPLAY_MET(165,4) + !ENDIF + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG( '### GEOS_CHEM_ADJ: a PBL_MIX_ADJ:1' ) + ENDIF + + + ENDIF + + !===================================================== + ! ***** TRANSPORT ADJOINT ***** + !===================================================== + + IF ( ITS_TIME_FOR_DYN() ) THEN + + + !IF( LTRAN ) THEN + ! CALL READ_PRESSURE_CHKFILE( NYMD, NHMS ) + ! CALL SET_FLOATING_PRESSURE( TMP_PRESS(:,:) ) + !ENDIF + + IF ( LCONV .or. LWETD .or. ( LCHEM .and. LSULF ) ) THEN + CALL ADJ_INIT_WETSCAV + ENDIF + + IF ( LPRINTFD ) THEN + CALL DISPLAY_MET( 165 , 1 ) + ENDIF + + !-------------------------------------------------------------- + ! BUG FIX: apply an additional unit conversion to + ! go from discrete to continuous adjointg (jkoo, dkh, 02/14/11) + ! OLD: + !IF ( LTRAN ) CALL DO_TRANSPORT_ADJ + ! NEW: + IF ( LTRAN ) THEN + + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) + + CALL DO_TRANSPORT_ADJ + + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) + + ENDIF + !-------------------------------------------------------------- + + ! Reset air mass quantities + CALL AIRQNT + + IF ( LPRINTFD ) THEN + CALL DISPLAY_MET( 165 , 2 ) + ENDIF + + + ! Replace with strat chem (hml, dkh, 02/27/12, adj32_025) + !! Repartition [NOy] species after transport + !IF ( LUPBD .and. ITS_A_FULLCHEM_SIM() ) THEN + ! CALL UPBDFLX_NOY_ADJ( 1 ) + !ENDIF + +#if !defined( GEOS_5 ) && !defined( GEOS_FP ) + ! Get relative humidity + ! (after recomputing pressure quantities) + ! NOTE: for GEOS-5 we'll read this from disk instead + CALL MAKE_RH +#endif + + + ENDIF + + !============================================================== + ! ***** S T R A T O S P H E R I C F L U X E S ***** + !============================================================== + ! Replace with strat chem (hml, dkh, 02/27/12, adj32_025) + !IF ( LUPBD ) CALL DO_UPBDFLX_ADJ + + !============================================================== + ! ***** U N I T C O N V E R S I O N ( J/[v/v] -> J/kg ) ***** + !============================================================== + IF ( ITS_TIME_FOR_UNIT() ) THEN + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG( '### GEOS_CHEM_ADJ: a CONVERT_UNITS:1' ) + ENDIF + + ENDIF + + ! mkeller: weak constraint stuff + IF( DO_WEAK_CONSTRAINT ) CALL SET_CT_U(INCREASE=.TRUE.) + + ! Check for NaN, Negatives, Infinities in STT_ADJ once per hour + IF ( ITS_TIME_FOR_DIAG() ) THEN + + ! Sometimes STT in the stratosphere can be negative at + ! the nested-grid domain edges. Force them to be zero before + ! CHECK_STT (yxw) +#if defined( GEOS_5 ) && defined( GRID05x0666 ) + CALL CHECK_STT_05x0666_ADJ( 'End of Dynamic Loop' ) +#endif + + CALL CHECK_STT_ADJ( 'End of Dynamic Loop' ) + ENDIF + + ! dkh debug + print*, ' MIN / MAX STT_ADJ = ', + & MINVAL(STT_ADJ), MAXVAL(STT_ADJ) + print*, ' MIN / MAX loc = ', + & MINLOC(STT_ADJ), MAXLOC(STT_ADJ) + + ! Save adjoint values to *.adj.* file +! IF ( LADJ_TRAJ ) THEN + ! (lzh, 07/10/2014) save adj files every hour + IF ( LADJ_TRAJ .and. ( ITS_TIME_FOR_A1() ) ) THEN + CALL MAKE_ADJ_FILE( GET_NYMD(), GET_NHMS() ) + ENDIF + + !============================================================== + ! ***** T E S T F O R E N D O F R U N ***** + !============================================================== + IF ( ITS_TIME_FOR_EXIT_ADJ() ) GOTO 9999 + + ENDDO + + ENDDO + + !================================================================= + ! ***** C L E A N U P A N D Q U I T ***** + !================================================================= + 9999 CONTINUE + + !WRITE(141,*) f + + ! Get ICS_SF_ADJ from STT_ADJ (dkh, 07/23/06, mak, 6/19/09) + CALL RESCALE_ADJOINT + + ! Transform to ICS_SF_ADJ and EMS_SF_ADJ to log scaling if desired +#if defined ( LOG_OPT ) + CALL LOG_RESCALE_ADJOINT +#endif + +! Obsolete (zhej, dkh, 01/16/12, adj32_015) +! ! Set gradient in cushion as ZERO (zhe 11/28/10) +!#if defined( GRID05x0666 ) .and. defined (NESTED_CH) +! CALL NESTED_RESCALE_ADJOINT +!#endif + + ! dkh debug + print*, ' MIN / MAX ICS_SF_ADJ = ', + & MINVAL(ICS_SF_ADJ), MAXVAL(ICS_SF_ADJ) + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG( '### GEOS_CHEM_ADJ: a RESCALE' ) + ENDIF + + + ! dkh debug + print*, ' MIN / MAX STT = ', + & MINVAL(STT ), MAXVAL(STT ) + +! ! dkh debug +! print*, ' MIN / MAX ICS_SF_ADJ = ', +! & MINVAL(ICS_SF_ADJ), MAXVAL(ICS_SF_ADJ) + + + !============================================ + ! BACKGROUND COST AND GRADIENT UPDATE + ! + ! aka A PRIORI TERM CALCULATION + !============================================ + + ! Now we have separate subroutines for these (dkh, 02/09/11) + IF ( LAPSRC ) THEN + + IF ( ITS_A_FULLCHEM_SIM() .or. ITS_A_TAGCO_SIM() .or. + & ITS_A_CH4_SIM() ) THEN + CALL CALC_APRIORI + + ELSEIF ( ITS_A_CO2_SIM() ) THEN + + CALL CALC_APRIORI_CO2 + + ! (yhmao, dkh, 01/13/12, adj32_013) + ELSEIF (ITS_AN_AEROSOL_SIM()) THEN + + CALL CALC_APRIORI_BCOC + + ELSE + + CALL ERROR_STOP( 'APRIORI calc not defined', + & 'geos_chem_adj_mod' ) + + ENDIF + + PRINT*, 'Added (x-xa)T invSa (x-xa) to the cost func' + + ENDIF + + ! Print ending time of simulation + CALL DISPLAY_END_TIME + + ! Return to calling routine. + END SUBROUTINE DO_GEOS_CHEM_ADJ + +! Moved these routines to time_mod.f (dkh, 01/23/10) +!!------------------------------------------------------------------------------ +! +! FUNCTION ITS_TIME_FOR_I6_ADJ() RESULT( FLAG ) +!! +!!****************************************************************************** +!! Function ITS_TIME_FOR_I6_ADJ returns TRUE if it is time to read in I-6 +!! (instantaneous 6-h fields) and FALSE otherwise. This happens when TIME_ADJ is +!! at a 6h interval, which is equivalent to when ELAPSED_TIME+TS_DYN is at a +!! 6h interval. (dkh, 8/25/04) +!! +!! NOTES: +!! (1 ) Don't read in i6 fields when we are still within the last 6 h interval +!! from the forward simulation, in which case just use the i6 fields that +!! are already loaded. (dkh, 9/30/04) +!! (2 ) FIXED BUG: Use EXTRA so that NHMS + (TS_DYN) is divisible by 6 h +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_NHMS, GET_ELAPSED_SEC +! USE TIME_MOD, ONLY : GET_TS_DYN +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GEOS_CHEM_MOD, ONLY : NSECb +! +! ! Function value +! LOGICAL :: FLAG +! +! ! Local variable +! INTEGER :: EXTRA +! +! !================================================================= +! ! ITS_TIME_FOR_I6_ADJ begins here! +! !================================================================= +! IF ( GET_ELAPSED_SEC() >= NSECb ) THEN +! +! ! We can use I6 fields still loaded from forward run +! FLAG = .FALSE. +! +! ! Echo this fact to the screen +! WRITE(6,*) ' -- USE I6 FIELDS FROM FORWARD RUN ' +! +! ELSE +! +! ! EXTRA set so that current NHMS + 1 dynamic time step is +! ! divisible by 060000 +! ! Original, hardwired to 30 min dynamic time step +! !EXTRA = 7000 +! ! Qinbin's formula, assumes TS_DYN <= 60 min +! EXTRA = 4000 + GET_TS_DYN()*100 +! +! IF ( GET_TS_DYN() > 60 ) CALL ERROR_STOP( 'Invalid EXTRA!', +! & 'ITS_TIME_FOR_I6_ADJ (adjoint.f)' ) +! +! ! We read in I-6 fields at 00, 06, 12, 18 GMT +! FLAG = ( MOD( GET_NHMS() + EXTRA, 060000 ) == 0 ) +! +! ENDIF +! +! ! Return to calling program +! END FUNCTION ITS_TIME_FOR_I6_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_I6_TIME_ADJ( ) RESULT( BEHIND_DATE ) +!! +!!****************************************************************************** +!! Function GET_I6_TIME_ADJ returns the correct YYYYMMDD and HHMMSS values +!! that are needed to read in the previous instantaneous 6-hour (I-6) fields. +!! (dkh, 8/25/04) +!! +!! NOTES: +!! This is only called if ITS_TIME_FOR_I6_ADJ is true +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_TS_DYN +! +! ! Arguments +! INTEGER :: BEHIND_DATE(2) +! +! !================================================================= +! ! GET_I6_TIME_ADJ begins here! +! !================================================================= +! +! ! We need to read in the I-6 fields 6h (360 mins) behind of TIME_ADJ +! ! which is the same as 360 - TS_DYN behind ELAPSED_TIME +! BEHIND_DATE = GET_TIME_BEHIND_ADJ( 360 - GET_TS_DYN() ) +! +! ! Return to calling program +! END FUNCTION GET_I6_TIME_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION ITS_TIME_FOR_A6_ADJ() RESULT( FLAG ) +!! +!!****************************************************************************** +!! Function ITS_TIME_FOR_A6_ADJ returns TRUE if it is time to read in I-A +!! (average 6-h fields) and FALSE otherwise. This happens when TIME_ADJ is +!! at a 6h interval (03, 09, 15,21), which is equivalent to when +!! ELAPSED_TIME+TS_DYN is at a 6h interval. (dkh, 03/04/05) +!! +!! NOTES: +!! (1 ) Don't read in A6 fields when we are still within the last 6 h interval +!! from the forward simulation, in which case just use the A6 fields that +!! are already loaded. NSECb is the total elapsed seconds at the last fwd +!! I6 interval, so if we are more than 3 hr past this, can use A6 fields +!! from forward run. (dkh, 03/04/05) +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_NHMS, GET_ELAPSED_SEC +! USE TIME_MOD, ONLY : GET_TS_DYN +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GEOS_CHEM_MOD, ONLY : NSECb +! +! ! Function value +! LOGICAL :: FLAG +! +! ! Local variable +! INTEGER :: EXTRA +! INTEGER :: DATE(2) +! +! !================================================================= +! ! ITS_TIME_FOR_A6_ADJ begins here! +! !================================================================= +! +! IF ( GET_ELAPSED_SEC() >= NSECb + 3 * 3600 ) THEN +! +! ! We can use A6 fields still loaded from forward run +! FLAG = .FALSE. +! +! ! Echo this fact to the screen +! WRITE(6,*) ' -- USE A6 FIELDS FROM FORWARD RUN ' +! +! ELSE +! +!#if defined( GEOS_4 ) && defined( A_LLK_03 ) || defined ( GCAP ) +! +! ! For GEOS-4 "a_llk_03" data, we need to read A-6 fields when it +! ! is 00, 06, 12, 18 GMT. DATE is the current time -- test below. +! DATE = GET_TIME_AHEAD( 0 ) +! +!#else +! +! ! For GEOS-1, GEOS-S, GEOS-3, and GEOS-4 "a_llk_04" data, +! ! we need to read A-6 fields when it is 03, 09, 15, 21 GMT. +! ! DATE is the time 3 before now -- test below. +! DATE = GET_TIME_BEHIND_ADJ( 180 ) +! +!#endif +! ! EXTRA set so that current NHMS + 1 dynamic time step is +! ! divisible by 060000 +! ! Original formula, assumes dynamic time step is 30 min +! ! EXTRA = 7000 +! ! Qinbin's formula, assumes dynamic time step <= 60 +! EXTRA = 4000 + GET_TS_DYN() * 100 +! +! IF ( GET_TS_DYN() > 60 ) CALL ERROR_STOP( 'Invalid EXTRA!', +! & 'ITS_TIME_FOR_A6_ADJ (adjoint.f)' ) +! +! ! We read in A-6 fields at 03, 09, 15, 21 GMT +! FLAG = ( MOD( DATE(2) + EXTRA, 060000 ) == 0 ) +! +! ENDIF +! +! ! Return to calling program +! END FUNCTION ITS_TIME_FOR_A6_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_A6_TIME_ADJ( ) RESULT( BEHIND_DATE ) +!! +!!****************************************************************************** +!! Function GET_A6_TIME_ADJ returns the correct YYYYMMDD and HHMMSS values +!! that are needed to read in the previous average 6-hour (A-6) fields. +!! (dkh, 03/04/05) +!! +!! NOTES: +!! (1 ) This is only called if ITS_TIME_FOR_A6_ADJ is true +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_TS_DYN +! +! ! Arguments +! INTEGER :: BEHIND_DATE(2) +! +! !================================================================= +! ! GET_A6_TIME_ADJ begins here! +! !================================================================= +! +! ! Return the time 3h (180m) before now, since there is a 3-hour +! ! offset between the actual time when the A-6 fields are read +! ! and the time that the A-6 fields are stamped with. Also apply +! ! offset of TS_DYN. +! BEHIND_DATE = GET_TIME_BEHIND_ADJ( 180 - GET_TS_DYN() ) +! !BEHIND_DATE = GET_TIME_BEHIND_ADJ( - TS_DYN ) +! +! ! Return to calling program +! END FUNCTION GET_A6_TIME_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION ITS_TIME_FOR_A3_ADJ() RESULT( FLAG ) +!! +!!****************************************************************************** +!! Function ITS_TIME_FOR_A3_ADJ returns TRUE if it is time to read in A-3 +!! (average 3-h fields) and FALSE otherwise. This happens when TIME_ADJ is +!! at a 3h interval, which is equivalent to when +!! ELAPSED_TIME+TS_DYN is at a 3h interval. (dkh, 03/04/05) +!! +!! NOTES: +!! (1 ) Don't read in 3 fields when we are still within the last 3 h interval +!! from the forward simulation, in which case just use the A3 fields that +!! are already loaded. NSECb is the total elapsed seconds at the last fwd +!! I6 interval, so if we are more than 3 hr past this, can use A3 fields +!! from forward run. (dkh, 03/04/05) +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_NHMS, GET_ELAPSED_SEC +! USE TIME_MOD, ONLY : GET_TS_DYN +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GEOS_CHEM_MOD, ONLY : NSECb +! +! ! Function value +! LOGICAL :: FLAG +! +! ! Local variable +! INTEGER :: EXTRA +! +! !================================================================= +! ! ITS_TIME_FOR_A3_ADJ begins here! +! !================================================================= +! +! IF ( GET_ELAPSED_SEC() >= NSECb + 3 * 3600 ) THEN +! !IF ( GET_ELAPSED_SEC() >= NSECb + 3 * 3600 + 30*60 ) THEN +! +! ! We can use A3 fields still loaded from forward run +! FLAG = .FALSE. +! +! ! Echo this fact to the screen +! WRITE(6,*) ' -- USE A3 FIELDS FROM FORWARD RUN ' +! +! ELSE +! ! EXTRA set so that current NHMS + 1 dynamic time step is +! ! divisible by 030000 +! ! Original formula, assumes dynamic time step is 30 min +! !EXTRA = 7000 +! ! Qinbin's formula, assumes dynamic time step <= 60 min +! EXTRA = 4000 + GET_TS_DYN() * 100 +! +! IF ( GET_TS_DYN() > 30 ) CALL ERROR_STOP( 'Invalid EXTRA!', +! & 'ITS_TIME_FOR_A3_ADJ (adjoint.f)' ) +! +! ! We read in A-3 every 3 hours +! FLAG = ( MOD( GET_NHMS() + EXTRA, 030000 ) == 0 ) +! +! ENDIF +! +! ! Return to calling program +! END FUNCTION ITS_TIME_FOR_A3_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_A3_TIME_ADJ( ) RESULT( BEHIND_DATE ) +!! +!!****************************************************************************** +!! Function GET_A3_TIME_ADJ returns the correct YYYYMMDD and HHMMSS values +!! that are needed to read in the previous average 3-hour (A-3) fields. +!! (dkh, 03/04/05) +!! +!! NOTES: +!! (1 ) This is only called if ITS_TIME_FOR_A3_ADJ is true +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_TS_DYN +! +! ! Arguments +! INTEGER :: BEHIND_DATE(2) +! +! !================================================================= +! ! GET_A3_TIME_ADJ begins here! +! !================================================================= +! +!!#if defined( GEOS_4 ) +!#if defined( GEOS_4 ) || defined ( GEOS_5 ) +! +! ! For GEOS-4/fvDAS, the A-3 fields are timestamped by center time. +! ! Therefore, the difference between the actual time when the fields +! ! are read and the A-3 timestamp time is 90 minutes. +! BEHIND_DATE = GET_TIME_BEHIND_ADJ( 90 - GET_TS_DYN() ) +! +!#else +! +! ! For GEOS-1, GEOS-STRAT, GEOS-3, the A-3 fields are timestamped +! ! by ending time. Therefore, the difference between the actual time +! ! when the fields are read and the A-3 timestamp time is 180 minutes. +! !BEHIND_DATE = GET_TIME_BEHIND_ADJ( 180 - TS_DYN ) +! BEHIND_DATE = GET_TIME_BEHIND_ADJ( - GET_TS_DYN() ) +! +!#endif +! +! ! Return to calling program +! END FUNCTION GET_A3_TIME_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_TIME_BEHIND_ADJ( N_MINS ) RESULT( DATE ) +!! +!!****************************************************************************** +!! Function GET_TIME_BEHIND_ADJ returns to the calling program a 2-element vector +!! containing the YYYYMMDD and HHMMSS values at the current time minus N_MINS +!! minutes. (dkh, 8/25/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) N_MINS (INTEGER) : Minutes ahead of time to compute YYYYMMDD,HHMMSS +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! References to F90 modules +! USE TIME_MOD, ONLY : GET_JD, GET_NYMD, GET_NHMS +! USE JULDAY_MOD, ONLY : CALDATE +! +! ! Arguments +! INTEGER, INTENT(IN) :: N_MINS +! +! ! Local variables +! INTEGER :: DATE(2) +! REAL*8 :: JD +! +! !================================================================= +! ! GET_TIME_BEHIND_ADJ begins here! +! !================================================================= +! +! ! Astronomical Julian Date at current time - N_MINS +! JD = GET_JD( GET_NYMD(), GET_NHMS() ) - ( N_MINS / 1440d0 ) +! +! ! Call CALDATE to compute the current YYYYMMDD and HHMMSS +! CALL CALDATE( JD, DATE(1), DATE(2) ) +! +! ! Return to calling program +! END FUNCTION GET_TIME_BEHIND_ADJ +! +!----------------------------------------------------------------------------- + + SUBROUTINE DISPLAY_END_TIME + + !================================================================= + ! Internal subroutine DISPLAY_END_TIME prints the ending time of + ! the GEOS-CHEM simulation (bmy, 5/3/05) + !================================================================= + USE TIME_MOD, ONLY : SYSTEM_TIMESTAMP + + ! Local variables + CHARACTER(LEN=16) :: STAMP + + ! Print system time stamp + STAMP = SYSTEM_TIMESTAMP() + WRITE( 6, 100 ) STAMP + 100 FORMAT( /, '===> SIMULATION END TIME: ', a, ' <===', / ) + + ! Echo info + WRITE ( 6, 3000 ) + 3000 FORMAT + & ( /, '************** E N D O F A D J O I N T G E O S + & -- C H E M ', + & '**************' ) + + ! Return to MAIN program + END SUBROUTINE DISPLAY_END_TIME + +!------------------------------------------------------------------------------ + + SUBROUTINE MET_FIELD_DEBUG + + !================================================================= + ! Internal subroutine MET_FIELD_DEBUG prints out the maximum + ! and minimum, and sum of DAO met fields for debugging + !================================================================= + + ! References to F90 modules + USE DAO_MOD, ONLY : AD, AIRDEN, AIRVOL, ALBD1, ALBD2 + USE DAO_MOD, ONLY : ALBD, AVGW, BXHEIGHT, CLDFRC, CLDF + USE DAO_MOD, ONLY : CLDMAS, CLDTOPS, DELP + USE DAO_MOD, ONLY : DTRAIN, GWETTOP, HFLUX, HKBETA, HKETA + USE DAO_MOD, ONLY : LWI, MOISTQ, OPTD, OPTDEP, PBL + USE DAO_MOD, ONLY : PREACC, PRECON, PS1, PS2, PSC2 + USE DAO_MOD, ONLY : RADLWG, RADSWG, RH, SLP, SNOW + USE DAO_MOD, ONLY : SPHU1, SPHU2, SPHU, SUNCOS, SUNCOSB + USE DAO_MOD, ONLY : SUNCOS_5hr + USE DAO_MOD, ONLY : TMPU1, TMPU2, T, TROPP, TS + USE DAO_MOD, ONLY : TSKIN, U10M, USTAR, UWND1, UWND2 + USE DAO_MOD, ONLY : UWND, V10M, VWND1, VWND2, VWND + USE DAO_MOD, ONLY : Z0, ZMEU, ZMMD, ZMMU + +# include "CMN_SIZE" + + ! Local variables + INTEGER :: I, J, L, IJ + + !================================================================= + ! MET_FIELD_DEBUG begins here! + !================================================================= + + ! Define box to print out + I = 23 + J = 34 + L = 1 + IJ = ( ( J-1 ) * IIPAR ) + I + + !================================================================= + ! Print out met fields at (I,J,L) + !================================================================= + IF ( ALLOCATED( AD ) ) PRINT*, 'AD : ', AD(I,J,L) + IF ( ALLOCATED( AIRDEN ) ) PRINT*, 'AIRDEN : ', AIRDEN(L,I,J) + IF ( ALLOCATED( AIRVOL ) ) PRINT*, 'AIRVOL : ', AIRVOL(I,J,L) + IF ( ALLOCATED( ALBD1 ) ) PRINT*, 'ALBD1 : ', ALBD1(I,J) + IF ( ALLOCATED( ALBD2 ) ) PRINT*, 'ALBD2 : ', ALBD2(I,J) + IF ( ALLOCATED( ALBD ) ) PRINT*, 'ALBD : ', ALBD(I,J) + IF ( ALLOCATED( AVGW ) ) PRINT*, 'AVGW : ', AVGW(I,J,L) + IF ( ALLOCATED( BXHEIGHT ) ) PRINT*, 'BXHEIGHT: ', BXHEIGHT(I,J,L) + IF ( ALLOCATED( CLDFRC ) ) PRINT*, 'CLDFRC : ', CLDFRC(I,J) + IF ( ALLOCATED( CLDF ) ) PRINT*, 'CLDF : ', CLDF(L,I,J) + IF ( ALLOCATED( CLDMAS ) ) PRINT*, 'CLDMAS : ', CLDMAS(I,J,L) + IF ( ALLOCATED( CLDTOPS ) ) PRINT*, 'CLDTOPS : ', CLDTOPS(I,J) + IF ( ALLOCATED( DELP ) ) PRINT*, 'DELP : ', DELP(L,I,J) + IF ( ALLOCATED( DTRAIN ) ) PRINT*, 'DTRAIN : ', DTRAIN(I,J,L) + IF ( ALLOCATED( GWETTOP ) ) PRINT*, 'GWETTOP : ', GWETTOP(I,J) + IF ( ALLOCATED( HFLUX ) ) PRINT*, 'HFLUX : ', HFLUX(I,J) + IF ( ALLOCATED( HKBETA ) ) PRINT*, 'HKBETA : ', HKBETA(I,J,L) + IF ( ALLOCATED( HKETA ) ) PRINT*, 'HKETA : ', HKETA(I,J,L) + IF ( ALLOCATED( LWI ) ) PRINT*, 'LWI : ', LWI(I,J) + IF ( ALLOCATED( MOISTQ ) ) PRINT*, 'MOISTQ : ', MOISTQ(L,I,J) + IF ( ALLOCATED( OPTD ) ) PRINT*, 'OPTD : ', OPTD(L,I,J) + IF ( ALLOCATED( OPTDEP ) ) PRINT*, 'OPTDEP : ', OPTDEP(L,I,J) + IF ( ALLOCATED( PBL ) ) PRINT*, 'PBL : ', PBL(I,J) + IF ( ALLOCATED( PREACC ) ) PRINT*, 'PREACC : ', PREACC(I,J) + IF ( ALLOCATED( PRECON ) ) PRINT*, 'PRECON : ', PRECON(I,J) + IF ( ALLOCATED( PS1 ) ) PRINT*, 'PS1 : ', PS1(I,J) + IF ( ALLOCATED( PS2 ) ) PRINT*, 'PS2 : ', PS2(I,J) + IF ( ALLOCATED( PSC2 ) ) PRINT*, 'PSC2 : ', PSC2(I,J) + IF ( ALLOCATED( RADLWG ) ) PRINT*, 'RADLWG : ', RADLWG(I,J) + IF ( ALLOCATED( RADSWG ) ) PRINT*, 'RADSWG : ', RADSWG(I,J) + IF ( ALLOCATED( RH ) ) PRINT*, 'RH : ', RH(I,J,L) + IF ( ALLOCATED( SLP ) ) PRINT*, 'SLP : ', SLP(I,J) + IF ( ALLOCATED( SNOW ) ) PRINT*, 'SNOW : ', SNOW(I,J) + IF ( ALLOCATED( SPHU1 ) ) PRINT*, 'SPHU1 : ', SPHU1(I,J,L) + IF ( ALLOCATED( SPHU2 ) ) PRINT*, 'SPHU2 : ', SPHU2(I,J,L) + IF ( ALLOCATED( SPHU ) ) PRINT*, 'SPHU : ', SPHU(I,J,L) + IF ( ALLOCATED( SUNCOS ) ) PRINT*, 'SUNCOS : ', SUNCOS(IJ) + IF ( ALLOCATED( SUNCOS_5hr)) PRINT*, 'SUNCOS_5hr: ',SUNCOS_5hr(IJ) + IF ( ALLOCATED( SUNCOSB ) ) PRINT*, 'SUNCOSB : ', SUNCOSB(IJ) + IF ( ALLOCATED( TMPU1 ) ) PRINT*, 'TMPU1 : ', TMPU1(I,J,L) + IF ( ALLOCATED( TMPU2 ) ) PRINT*, 'TMPU2 : ', TMPU2(I,J,L) + IF ( ALLOCATED( T ) ) PRINT*, 'TMPU : ', T(I,J,L) + IF ( ALLOCATED( TROPP ) ) PRINT*, 'TROPP : ', TROPP(I,J) + IF ( ALLOCATED( TS ) ) PRINT*, 'TS : ', TS(I,J) + IF ( ALLOCATED( TSKIN ) ) PRINT*, 'TSKIN : ', TSKIN(I,J) + IF ( ALLOCATED( U10M ) ) PRINT*, 'U10M : ', U10M(I,J) + IF ( ALLOCATED( USTAR ) ) PRINT*, 'USTAR : ', USTAR(I,J) + IF ( ALLOCATED( UWND1 ) ) PRINT*, 'UWND1 : ', UWND1(I,J,L) + IF ( ALLOCATED( UWND2 ) ) PRINT*, 'UWND2 : ', UWND2(I,J,L) + IF ( ALLOCATED( UWND ) ) PRINT*, 'UWND : ', UWND(I,J,L) + IF ( ALLOCATED( V10M ) ) PRINT*, 'V10M : ', V10M(I,J) + IF ( ALLOCATED( VWND1 ) ) PRINT*, 'VWND1 : ', VWND1(I,J,L) + IF ( ALLOCATED( VWND2 ) ) PRINT*, 'VWND2 : ', VWND2(I,J,L) + IF ( ALLOCATED( VWND ) ) PRINT*, 'VWND : ', VWND(I,J,L) + IF ( ALLOCATED( Z0 ) ) PRINT*, 'Z0 : ', Z0(I,J) + IF ( ALLOCATED( ZMEU ) ) PRINT*, 'ZMEU : ', ZMEU(I,J,L) + IF ( ALLOCATED( ZMMD ) ) PRINT*, 'ZMMD : ', ZMMD(I,J,L) + IF ( ALLOCATED( ZMMU ) ) PRINT*, 'ZMMU : ', ZMMU(I,J,L) + + ! Flush the output buffer + CALL FLUSH( 6 ) + + ! Return to MAIN program + END SUBROUTINE MET_FIELD_DEBUG + +!----------------------------------------------------------------------------- + + SUBROUTINE CALC_ADJ_FORCE_FOR_OBS ( ) +! +!****************************************************************************** +! Subroutine CALC_ADJ_FORCE_FOR_OBS calculates the cost function and its first +! derivative w.r.t. the dependent variables. (dkh, 9/01/04) +! +! NOTE: +! (1 ) This routine assumes that the first NOBS of RPOUT are the observations +! (2 ) Corrected the limitation in (1) by switching to OBS_STT and CHK_STT, +! both of which are same size, and indexed similarly to ADJ_STT, though +! they contain 3 more species than ADJ_STT. Make sure that CHK_STT and +! OBS_STT are in ug/m3, so that if WEIGHT is dimentionless, J has units +! of ug2/m6. (dkh, 03/03/05) +! (3 ) Now supports the LWSCALE option, where we can resale the weight matrix +! by 1 / OBS^2. (dkh, 03/24/05) +! (4 ) Now error check for exploding adjoints and NaN. (dkh, 03/24/05) +! (5 ) Now OBS_STT and CHK_STT in [kg/box] +! (6 ) Now include factor of 1/2 in cost function. (dkh, 07/24/06) +! (7 ) Get rid of LWSCALE. (dkh, 09/29/06) +! (8 ) Add UNITS option to evaluate cost function in a units of ug/m3 for +! sensitivity calculations. (dkh, 10/13/06) +! (9 ) Add support for NO2_SAT_OBS. (dkh, 11/08/06) +! (10) Addu suppprt for IMPROVE_OBS. (dkh, 11/21/06) +! (11) Add support for UNITS = 'ppb'. (dkh, 02/12/07) +! (12) Add support for CASTNET_OBS. (dkh, 04/24/07) +! (13) Add support for spatial/temporal average of O3 (cspec_ppb). (dkh, 11/20/07) +! (14) Add support for attainment functions calculated in ATTAINMENT_MOD. (dkh, 11/20/07) +! (15) Replace ATTAINMENT with PM_ATTAINMENT and O3_ATTAINMENT +! (16) Add support for TES_NH3_OBS. (dkh, 05/05/09) +! (17) Major updates, renaming, etc. (dkh, ks, mak, cs 06/08/09) +! (18) Add support for TES_O3_OBS. (dkh, 05/06/10) +! (19) Add support for GOSAT_CO2_OBS. (dkh, 11/18/10) +! (20) Add support for LMAX_OBS for PSEUDO_OBS. (dkh, 02/11/11) +! (21) Add support for MODIS_AOD_OBS (xxu, dkh, 01/09/12, adj32_011) +! (22) Now calculate a relative OBS_ERR for PSEUDO_OBS (nb, dkh, 08/02/12, adj33g) +! (23) Add support for OMI_SO2_OBS (ywang, 04/21/15) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ, ADJ_FORCE + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION + USE ADJ_ARRAYS_MOD, ONLY : OBS_STT + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT, READ_OBS_FILE + USE ERROR_MOD, ONLY : DEBUG_MSG, IT_IS_NAN, ERROR_STOP + USE ERROR_MOD, ONLY : IS_SAFE_DIV + USE DAO_MOD, ONLY : AIRVOL, AD + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS + USE TRACER_MOD, ONLY : N_TRACERS + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + +#if defined ( IMPROVE_SO4_NIT_OBS ) + USE IMPROVE_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS_STOP + USE IMPROVE_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS_START + USE IMPROVE_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS + USE IMPROVE_MOD, ONLY : CALC_IMPRV_FORCE, + & ADJ_RESET_AEROAVE, + & ADJ_UPDATE_AEROAVE +#endif + + ! (yhmao, dkh, 01/13/12, adj32_013) +#if defined ( IMPROVE_BC_OC_OBS ) + USE IMPROVE_BC_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS_STOP + USE IMPROVE_BC_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS_START + USE IMPROVE_BC_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS + USE IMPROVE_BC_MOD, ONLY : CALC_IMPRV_FORCE, + & ADJ_RESET_AEROAVE, + & ADJ_UPDATE_AEROAVE +#endif + + +#if defined ( PM_ATTAINMENT ) + USE ATTAINMENT_MOD, ONLY : ITS_TIME_FOR_AVE_STOP + USE ATTAINMENT_MOD, ONLY : ITS_TIME_FOR_AVE_START + USE ATTAINMENT_MOD, ONLY : ITS_TIME_FOR_AVE + USE ATTAINMENT_MOD, ONLY : CALC_AVE_FORCE, + & ADJ_RESET_AVE, + & ADJ_UPDATE_AVE +#endif + +#if defined ( CASTNET_NH4_OBS ) + USE CASTNET_MOD, ONLY : ITS_TIME_FOR_CAST_OBS_STOP + USE CASTNET_MOD, ONLY : ITS_TIME_FOR_CAST_OBS_STOP + USE CASTNET_MOD, ONLY : ITS_TIME_FOR_CAST_OBS_START + USE CASTNET_MOD, ONLY : ITS_TIME_FOR_CAST_OBS + USE CASTNET_MOD, ONLY : CALC_CAST_FORCE, + & ADJ_RESET_CASTCHK, + & ADJ_UPDATE_CASTCHK + USE CASTNET_MOD, ONLY : RESET_CAST_OBS_TO_FALSE +#endif + +#if defined (SCIA_KNMI_NO2_OBS) + USE READ_SCIANO2_MOD, ONLY : CALC_SCIANO2_FORCE +#endif + +! add OMI L3 SO2 (ywang, 04/21/15) +#if defined (OMI_SO2_OBS) + USE OMI_SO2_OBS_MOD, ONLY : CALC_OMI_SO2_FORCE +#endif + + USE TIME_MOD, ONLY : GET_LOCALTIME, GET_NYMD, GET_NHMS + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TRACERID_MOD + ! added (dkh, 10/25/07) + USE COMODE_MOD, ONLY : JLOP, CSPEC + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + +#if defined ( SOMO35_ATTAINMENT ) + USE O3_ATTAIN_MOD, ONLY : CALC_O3_FORCE +#endif + +#if defined(TES_NH3_OBS) + USE TES_NH3_MOD, ONLY : CALC_TES_NH3_FORCE +#endif + +#if defined(TES_O3_OBS) + USE TES_O3_MOD, ONLY : CALC_TES_O3_FORCE +#endif + +#if defined(TES_O3_IRK) + USE TES_O3_IRK_MOD, ONLY : CALC_TES_O3_IRK_FORCE +#endif + +#if defined(GOSAT_CO2_OBS) + USE GOSAT_CO2_MOD, ONLY : CALC_GOS_CO2_FORCE +#endif + +! Add MOPITT v5 (zhej, dkh, 01/16/12, adj32_016) +#if defined( MOPITT_v5_CO_OBS ) || defined ( MOPITT_V6_CO_OBS ) || defined ( MOPITT_V7_CO_OBS ) + USE MOPITT_OBS_MOD, ONLY : READ_MOPITT_FILE, + & ITS_TIME_FOR_MOPITT_OBS, + & CALC_MOPITT_FORCE +#endif + +!xzhang: IASI CO partial column observations +#if defined(IASI_CO_OBS) + USE IASI_CO_OBS_MOD, ONLY : CALC_IASI_CO_FORCE +#endif + +#if defined( SCIA_BRE_CO_OBS ) +!#if defined( GEOS_4 ) + USE SCIAbr_CO_OBS_MOD, ONLY : READ_SCIAbr_CO_FILE, + & ITS_TIME_FOR_SCIAbr_CO_OBS, + & CALC_SCIAbr_CO_FORCE + +#endif + +#if defined( AIRS_CO_OBS ) + USE AIRS_CO_OBS_MOD, ONLY : READ_AIRS_CO_FILES, + & ITS_TIME_FOR_AIRS_CO_OBS, + & CALC_AIRS_CO_FORCE +#endif + +#if defined( MODIS_AOD_OBS ) + USE MODIS_AOD_OBS_MOD, ONLY : CALC_MODIS_AOD_FORCE +#endif + +! add CH4 operators (kjw, dkh, 02/12/12, adj32_023) +#if defined(TES_CH4_OBS) + USE TES_CH4_MOD, ONLY : CALC_TES_CH4_FORCE +#endif +#if defined(MEM_CH4_OBS) + USE MEM_CH4_MOD, ONLY : CALC_MEM_CH4_FORCE +#endif +#if defined(SCIA_CH4_OBS) + USE SCIA_CH4_MOD, ONLY : CALC_SCIA_CH4_FORCE +#endif +#if defined(LEO_CH4_OBS) + USE LEO_CH4_MOD, ONLY : CALC_LEO_CH4_FORCE +#endif +#if defined(GEOCAPE_CH4_OBS) + USE GEOCAPE_CH4_MOD, ONLY : CALC_GEOCAPE_CH4_FORCE +#endif +#if defined(OSIRIS_OBS) + USE OSIRIS_OBS_MOD, ONLY : READ_OSIRIS_FILE, + & ITS_TIME_FOR_OSIRIS_OBS, + & CALC_OSIRIS_FORCE, + & CALC_GC_O3 +#endif +!xzhang: MLS O3 column observations + +#if defined(MLS_O3_OBS) + USE MLS_O3_OBS_MOD, ONLY : READ_MLS_O3_FILE, + & CALC_MLS_O3_FORCE +#endif +!xzhang: IASI O3 partial column observations +#if defined(IASI_O3_OBS) + USE IASI_O3_OBS_MOD, ONLY : CALC_IASI_O3_FORCE +#endif + +!xzhang: MLS HNO3 column observations + +#if defined(MLS_HNO3_OBS) + USE MLS_HNO3_OBS_MOD, ONLY : CALC_MLS_HNO3_FORCE + USE MLS_HNO3_OBS_MOD, ONLY : READ_MLS_HNO3_FILE +#endif + +!mkeller: OMI NO2 column observations +#if defined(OMI_NO2_OBS) + USE OMI_NO2_OBS_MOD, ONLY : CALC_OMI_NO2_FORCE +#endif + +!xzhang: OMI CH2O column observations + +#if defined(OMI_CH2O_OBS) + USE OMI_CH2O_OBS_MOD, ONLY : CALC_OMI_CH2O_FORCE +#endif + +!xzhang: OSIRIS NO2 column observations + +#if defined(OSIRIS_NO2_OBS) + USE OSIRIS_NO2_OBS_MOD, ONLY : CALC_OSIRIS_NO2_FORCE +#endif + + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! XNUMOL + ! added (dkh, 10/25/07) +# include "comode.h" ! IGAS, ITLOOP +# include "define_adj.h" ! obs operators + + ! Internal variables + REAL*8 :: DIFF + REAL*8 :: NEW_COST(IIPAR,JJPAR,LLPAR,N_TRACERS) + INTEGER :: I, J, L, N + INTEGER :: ADJ_EXPLD_COUNT + INTEGER, PARAMETER :: MAX_ALLOWED_EXPLD = 10 + REAL*8, PARAMETER :: MAX_ALLOWED_INCREASE = 10D10 + REAL*8 :: MAX_ADJ_TMP + REAL*8 :: TARGET_STT + REAL*8 :: FACTOR + REAL*8 :: CF_PRIOR + REAL*8 :: CF_TESNH3 + REAL*8 :: CF_TESO3, CF_IASIO3 + REAL*8 :: CF_GOSCO2 + REAL*8 :: CF_MODIS_AOD + REAL*8 :: CF_OMI_SO2 + REAL*8 :: CF_IMPRV + REAL*8 :: CF_TESCH4 + REAL*8 :: CF_SCIACH4 + REAL*8 :: CF_MEMCH4 + REAL*8 :: CF_GEOCAPECH4 + REAL*8 :: CF_LEOCH4 + REAL*8 :: CF_OSIRIS + REAL*8 :: CF_MOPITT, CF_IASICO + REAL*8 :: CF_OMINO2 + REAL*8 :: CF_OMICH2O + REAL*8 :: CF_MLSHNO3 + REAL*8 :: CF_OSIRISNO2 + REAL*8 :: OBS_ERR + REAL*8 :: MIN_MEAN_OBS + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER, SAVE :: OBS_COUNT = 0 + LOGICAL, SAVE :: SECOND = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME +110 FORMAT(F18.6,1X) + + !================================================================ + ! CALC_ADJ_FORCE_FOR_OBS begins here! + !================================================================ + +! Not sure this is necessary to have ppc flags here. LMAX_OBS should suffice +!#if defined ( PSEUDO_OBS ) + ! implement a cap on total number of observations (dkh, 02/11/11) + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + 1 + IF ( OBS_COUNT > NSPAN ) RETURN + ENDIF +!#endif + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C A L C A D J F O R C E - O B S ' + + ! Some error checking stuff + MAX_ADJ_TMP = MAXVAL( STT_ADJ ) + ADJ_EXPLD_COUNT = 0 + + !================================================================ + ! NO2 from the SCIA instrument using the KNMI retrieval + !================================================================ +#if defined( SCIA_KNMI_NO2_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! Calculate cost and forcing from satellite NO2 observations + ! note: forcing applied directly to ADCSPEC vi ADJ_NO2_AFTER_CHEM + ! and ADJ_CSPEC_NO2. (dkh, 11/08/06) + CALL CALC_SCIANO2_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_SCIA = CF_SCIA + COST_FUNC - CF_PRIOR + +#endif + + + !================================================================ + ! Sulfate and nitrate filter measurements from the IMPROVE netwrk + !================================================================ +#if defined ( IMPROVE_SO4_NIT_OBS ) + + IF ( ITS_TIME_FOR_IMPRV_OBS_STOP( -1 ) ) THEN + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! just to be safe: + CALL ADJ_RESET_AEROAVE + + CALL CALC_IMPRV_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_IMPRV = CF_IMPRV + COST_FUNC - CF_PRIOR + + ENDIF + + IF ( ITS_TIME_FOR_IMPRV_OBS() ) THEN + + CALL ADJ_UPDATE_AEROAVE( STT_ADJ(:,:,1,IDADJNIT), + & STT_ADJ(:,:,1,IDADJSO4), + & STT_ADJ(:,:,1,IDADJNH4) ) + + ENDIF + + IF ( ITS_TIME_FOR_IMPRV_OBS_START( -1 ) ) THEN + + ! Reset + CALL ADJ_RESET_AEROAVE + + ENDIF +#endif + + !================================================================ + ! BC and OC measurements from the IMPROVE netwrk !yhmao + !================================================================ +#if defined ( IMPROVE_BC_OC_OBS ) + IF ( ITS_TIME_FOR_IMPRV_OBS_STOP( -1 ) ) THEN + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! just to be safe: + CALL ADJ_RESET_AEROAVE + + CALL CALC_IMPRV_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_IMPRV = CF_IMPRV + COST_FUNC - CF_PRIOR + + ENDIF + + IF ( ITS_TIME_FOR_IMPRV_OBS() ) THEN + + + CALL ADJ_UPDATE_AEROAVE( STT_ADJ(:,:,1,IDTBCPI), + & STT_ADJ(:,:,1,IDTBCPO)) + !& STT_ADJ(:,:,1,IDTOCPI), + ! & STT_ADJ(:,:,1,IDTOCPO)) + + ENDIF + + IF ( ITS_TIME_FOR_IMPRV_OBS_START( -1 ) ) THEN + + ! Reset + CALL ADJ_RESET_AEROAVE + + ENDIF +#endif + + !================================================================ + ! NH3 profiles from the TES instrument with the AER retrieval + !================================================================ +#if defined ( TES_NH3_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_TES_NH3_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_TESNH3 = CF_TESNH3 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! O3 profiles from the TES instrument + !================================================================ +#if defined ( TES_O3_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_teso3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 121, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_TES_O3_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_TESO3 = CF_TESO3 + COST_FUNC - CF_PRIOR + WRITE (121,110) (CF_TESO3) +#endif + + !=================================================================== + !xzhang: O3 columns from IASI + !=================================================================== + +#if defined ( IASI_O3_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 127, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + CF_PRIOR = COST_FUNC + + CALL CALC_IASI_O3_FORCE( COST_FUNC ) + CF_IASIO3 = CF_IASIO3 + COST_FUNC - CF_PRIOR + WRITE(127,110) (CF_IASIO3) +#endif + + !================================================================ + ! O3 radiative kernels from the TES instrument + !================================================================ +#if defined ( TES_O3_IRK ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_TES_O3_IRK_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_TESO3 = CF_TESO3 + COST_FUNC - CF_PRIOR + +#endif + + + !================================================================ + ! CH4 profiles from the TES instrument (kjw, 02/12/12, adj32_023) + !================================================================ +#if defined ( TES_CH4_OBS ) +! IF ( LTES_PSO .EQ. .TRUE. ) THEN + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_TES_CH4_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_TESCH4 = CF_TESCH4 + COST_FUNC - CF_PRIOR + +! ENDIF +#endif + + !================================================================ + ! CH4 profiles from the SCIA instrument (kjw, 02/12/12, adj32_023) + !================================================================ +#if defined ( SCIA_CH4_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_SCIA_CH4_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_SCIACH4 = CF_SCIACH4 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! CH4 profiles from theoretical new instrument + ! (kjw, 02/12/12, adj32_023) + !================================================================ +#if defined ( MEM_CH4_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_MEM_CH4_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_MEMCH4 = CF_MEMCH4 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! CH4 profiles from theoretical new instrument + ! (kjw, 02/12/12, adj32_023) + !================================================================ +#if defined ( LEO_CH4_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_LEO_CH4_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_LEOCH4 = CF_LEOCH4 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! CH4 profiles from theoretical new instrument + ! (kjw, 02/12/12, adj32_023) + !================================================================ +#if defined ( GEOCAPE_CH4_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_GEOCAPE_CH4_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_GEOCAPECH4 = CF_GEOCAPECH4 + COST_FUNC - CF_PRIOR + +#endif + + + !================================================================ + ! CO2 profiles from the GOSAT instrument + !================================================================ +#if defined ( GOSAT_CO2_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_GOS_CO2_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_GOSCO2 = CF_GOSCO2 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! Ammonium filter measurements from CASTNet + !================================================================ +#if defined ( CASTNET_NH4_OBS ) + + ! Reset the CAST OBS flag to FALSE the first time through + ! so that we don't try to calculate any adjoint forcing before + ! reading an observation file. + IF ( FIRST ) THEN + + COST_FUNC = 0D0 + + CALL RESET_CAST_OBS_TO_FALSE + + FIRST = .FALSE. + + ENDIF + + IF ( ITS_TIME_FOR_CAST_OBS_START( -1 ) ) THEN + + ! Reset + CALL ADJ_RESET_CASTCHK + + ENDIF + + IF ( ITS_TIME_FOR_CAST_OBS_STOP( -1 ) ) THEN + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! just to be safe: + CALL ADJ_RESET_CASTCHK + + CALL CALC_CAST_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_CAST = CF_CAST + COST_FUNC - CF_PRIOR + + ENDIF + + IF ( ITS_TIME_FOR_CAST_OBS() ) THEN + + CALL ADJ_UPDATE_CASTCHK( STT_ADJ(:,:,1,IDADJNH4) ) + + ENDIF + +#endif + + !================================================================ + ! SOMO35 O3 air quality index + !================================================================ +#if defined ( SOMO35_ATTAINMENT ) + + CALL CALC_O3_FORCE( COST_FUNC ) + +#endif + + !================================================================ + ! PM2.5 24 average threshold attainment + !================================================================ +#if defined ( PM_ATTAINMENT ) + + IF ( ITS_TIME_FOR_AVE_STOP( -1 ) ) THEN + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! just to be safe: + CALL ADJ_RESET_AVE + + CALL CALC_AVE_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_AVE = CF_AVE + COST_FUNC - CF_PRIOR + + ENDIF + + IF ( ITS_TIME_FOR_AVE() ) THEN + + CALL ADJ_UPDATE_AVE( ) + + ENDIF + +#endif + + !================================================================ + ! Ozone profiles from TES + !================================================================ +#if defined ( TES_O3_OBS ) + +#endif + + !================================================================ + ! NO2 columns from SCIA instrument using the Dalhousie retrieval + !================================================================ +#if defined ( SCIA_DAL_NO2_OBS ) + +#endif + + !================================================================ + ! OMI L3 SO2 + !================================================================ +#if defined ( OMI_SO2_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_OMI_SO2_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_OMI_SO2 = CF_OMI_SO2 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! NDEP obs (e.g., NADP_OBS etc.) are called directly from + ! within DO_WETDEP_ADJ + !================================================================ + + !================================================================ + ! CO columns from the MOPITT instrument + ! Add v5 (zhej, dkh, 01/16/12, adj32_016) + !================================================================ +#if defined (MOPITT_V5_CO_OBS) || defined ( MOPITT_V6_CO_OBS ) || defined ( MOPITT_V7_CO_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 122, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + CF_PRIOR = COST_FUNC + ! Read MOPITT file just before midnight of the day of obs + !if first then read obs file to get hour + IF ( GET_NHMS() .ge. 230000 ) THEN + PRINT*, 'about to read mopitt file' + CALL READ_MOPITT_FILE( GET_NYMD(), GET_NHMS() ) + ENDIF + + IF ( ITS_TIME_FOR_MOPITT_OBS() ) THEN + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'CALC ADJ FORCE MOPITT' + + CALL CALC_MOPITT_FORCE + CF_MOPITT = CF_MOPITT + COST_FUNC - CF_PRIOR + WRITE(122,110) (CF_MOPITT) + ENDIF + + +#endif + +!=================================================================== +!xzhang: CO partial columns from IASI +!=================================================================== + +#if defined ( IASI_CO_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_iasico.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 128, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + CF_PRIOR = COST_FUNC + + CALL CALC_IASI_CO_FORCE( COST_FUNC ) + CF_IASICO = CF_IASICO + COST_FUNC - CF_PRIOR + WRITE(128,110) (CF_IASICO) +#endif +!=================================================================== +!xzhang: O3 columns from MLS +!=================================================================== + +#if defined ( MLS_O3_OBS ) + + ! Read MLS file just before midnight of the day of obs + !if first then read obs file to get hour + IF ( GET_NHMS() .ge. 230000 ) THEN + PRINT*, 'about to read MLS O3 file' + CALL READ_MLS_O3_FILE( GET_NYMD(), GET_NHMS() ) + ENDIF + + CALL CALC_MLS_O3_FORCE + +#endif + +!=================================================================== +!xzhang: HNO3 columns from MLS +!=================================================================== + +#if defined ( MLS_HNO3_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_mlshno3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 123, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + ! Read MLS file just before midnight of the day of obs + !if first then read obs file to get hour + IF ( GET_NHMS() .ge. 230000 ) THEN + PRINT*, 'about to read MLS HNO3 file' + CALL READ_MLS_HNO3_FILE( GET_NYMD(), GET_NHMS() ) + ENDIF + CF_PRIOR = COST_FUNC + CALL CALC_MLS_HNO3_FORCE + CF_MLSHNO3 = CF_MLSHNO3 + COST_FUNC - CF_PRIOR + WRITE(123,110) (CF_MLSHNO3) +#endif + +!=================================================================== +!mkeller: NO2 columns from OMI +!=================================================================== + +#if defined ( OMI_NO2_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 124, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + !IF ( GET_NHMS() .EQ. 0 ) THEN + !PRINT*, 'about to write OMI NO2 file' + !CALL WRITE_OMI_NO2_FILE( GET_NYMD(), GET_NHMS() ) + !ENDIF + CF_PRIOR = COST_FUNC + CALL CALC_OMI_NO2_FORCE + CF_OMINO2 = CF_OMINO2 + COST_FUNC - CF_PRIOR + WRITE(124,110) (CF_OMINO2) +#endif + +!=================================================================== +!xzhang: CH2O columns from OMI +!=================================================================== + +#if defined ( OMI_CH2O_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_omich2o.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 125, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + CF_PRIOR = COST_FUNC + + !IF ( GET_NHMS() .EQ. 0 ) THEN + !PRINT*, 'about to write OMI NO2 file' + !CALL WRITE_OMI_NO2_FILE( GET_NYMD(), GET_NHMS() ) + !ENDIF + CALL CALC_OMI_CH2O_FORCE + CF_OMICH2O = CF_OMICH2O + COST_FUNC - CF_PRIOR + WRITE(125,110) (CF_OMICH2O) +#endif +!=================================================================== +!xzhang: NO2 vertical profile from OSIRIS +!=================================================================== + +#if defined ( OSIRIS_NO2_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 126, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + ! Read OSIRIS file just before midnight of the day of obs + + !IF ( GET_NHMS() .EQ. 0 ) THEN + !PRINT*, 'about to write OMI NO2 file' + !CALL WRITE_OMI_NO2_FILE( GET_NYMD(), GET_NHMS() ) + !ENDIF + CF_PRIOR = COST_FUNC + CALL CALC_OSIRIS_NO2_FORCE + CF_OSIRISNO2 = CF_OSIRISNO2 + COST_FUNC - CF_PRIOR + WRITE(126,110) (CF_OSIRISNO2) +#endif + + !================================================================ + ! CO columns from the SCIA instrument using the Bremen retrieval + !================================================================ +#if defined ( SCIA_BRE_CO_OBS ) + + ! Read SCIA file at the first call or when the month changes + IF ( GET_NHMS() .ge. 230000 ) THEN + + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + PRINT*, 'about to read SCIA Bremen CO file' + CALL READ_SCIAbr_CO_FILE( GET_NYMD(), GET_NHMS() ) + + ENDIF + + IF ( ITS_TIME_FOR_SCIAbr_CO_OBS() ) THEN + PRINT*, 'its time for SCIA CO obs' + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'CALC ADJ FORCE SCIA Bremen CO' + + CALL CALC_SCIAbr_CO_FORCE + ENDIF + +#endif + + !================================================================ + ! CO columns from the AIRS instrument + !================================================================ +#if defined ( AIRS_CO_OBS ) + + ! Read AIRS file just before midnight of the day of obs + !if first then read obs file to get hour + IF ( GET_NHMS() .ge. 230000 ) THEN + + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + PRINT*, 'about to read AIRS CO file' + CALL READ_AIRS_CO_FILES( GET_NYMD(), GET_NHMS() ) + + ENDIF + + IF ( ITS_TIME_FOR_AIRS_CO_OBS() ) THEN + + PRINT*, 'its time for AIRS CO obs' + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'CALC ADJ FORCE AIRS CO' + + CALL CALC_AIRS_CO_FORCE + ENDIF + +#endif + + !================================================================ + ! Aerosol retrieval from MODIS (xxu, dkh, 01/09/12, adj32_011) + !================================================================ +#if defined ( MODIS_AOD_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_MODIS_AOD_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_MODIS_AOD = CF_MODIS_AOD + COST_FUNC - CF_PRIOR +#endif + + ! Added for OSIRIS obs (tww, 20120223) + !================================================================ + ! O3 obs from OSIRIS + !================================================================ +#if defined ( OSIRIS_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 126, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! Read file just before midnight of the day of obs + ! if first then read obs file to get hours of obs + IF ( GET_NHMS() .ge. 230000 ) THEN + + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + PRINT *, 'about to read OSIRIS file' + CALL READ_OSIRIS_FILE( GET_NYMD(), GET_NHMS() ) + + ENDIF + + IF (ITS_TIME_FOR_OSIRIS_OBS() ) THEN + + PRINT *, 'its time for OSIRIS obs' + ! Echo some input to the screen + WRITE ( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE ( 6, '(a,/)' ) 'CALC ADJ FORCE OSIRIS' + + CALL CALC_OSIRIS_FORCE( COST_FUNC ) + + ENDIF + CALL CALC_GC_O3 + ! Track cost function contributions + CF_OSIRIS = CF_OSIRIS + COST_FUNC - CF_PRIOR + WRITE(126,110) (CF_OSIRIS) +#endif + + !================================================================ + ! Psuedo observations generated from GEOS-Chem reference run + !================================================================ + +#if defined ( PSEUDO_OBS ) + + WRITE(6,*) ' READ PSEUDO OBS ' + + ! Read obs file + CALL READ_OBS_FILE ( GET_NYMD(), GET_NHMS() ) + + ! mak debug + PRINT*, 'min/max of OBS_STT:', minval(OBS_STT), maxval(OBS_STT) + PRINT*, 'min/max of CHK_STT:', minval(CHK_STT), maxval(CHK_STT) + + ! Initialize to be safe + NEW_COST = 0d0 + + FACTOR = 0.01d0 / ( IIPAR * JJPAR ) + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + DO L = 1, LLPAR + + MIN_MEAN_OBS = SUM( OBS_STT(:,:,L,N) ) * FACTOR + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, OBS_ERR) +!$OMP+PRIVATE( DIFF ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( GET_CF_REGION(I,J,L) > 0d0 ) THEN + + ! from each species + DIFF = ( CHK_STT(I,J,L,N) - OBS_STT(I,J,L,N) ) + + ! Calculate new additions to cost function + ! Now we calculate the error as being proportional to the observation + ! value + OBS_ERR = MAX( OBS_STT(I,J,L,N), MIN_MEAN_OBS )**2 + + ! Trap for dividing by small numbers + IF ( ( IS_SAFE_DIV( 1d0, OBS_ERR ) ) .AND. + & ( OBS_ERR .GT. 1e-19 ) ) THEN + + NEW_COST(I,J,L,N) = 0.5d0 / OBS_ERR + & * GET_CF_REGION(I,J,L) + & * DIFF ** 2 + + ! Force the adjoint variables x with dJ/dx + ADJ_FORCE(I,J,L,N) = GET_CF_REGION(I,J,L) + & * DIFF / OBS_ERR + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + & + ADJ_FORCE(I,J,L,N) + ENDIF + + ELSE + + ADJ_FORCE(I,J,L,N) = 0d0 + + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDDO + ENDIF + ENDDO + + ! + PRINT *,"OBS_COST: ", SUM ( NEW_COST ) + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + +#endif + + ! Error checking: warn of exploding adjoit values, except + ! the first jump up from zero (MAX_ADJ_TMP = 0 first few times) + IF ( MAXVAL(ABS(STT_ADJ)) > (MAX_ADJ_TMP * MAX_ALLOWED_INCREASE) + & .AND. ( MAX_ADJ_TMP > 0d0 ) ) THEN + + WRITE(6,*)' *** - WARNING: EXPLODING adjoints in ADJ_AEROSOL' + WRITE(6,*)' *** - MAX(STT_ADJ) before = ',MAX_ADJ_TMP + WRITE(6,*)' *** - MAX(STT_ADJ) after = ',MAXVAL(ABS(STT_ADJ)) + + ADJ_EXPLD_COUNT = ADJ_EXPLD_COUNT + 1 + + IF (ADJ_EXPLD_COUNT > MAX_ALLOWED_EXPLD ) + & CALL ERROR_STOP('Too many exploding adjoints', + & 'geos_chem_adj_mod.f') + + ENDIF + + + ! mak debug + WRITE(6,*) 'MIN/MAX OF STT_ADJ:', minval(stt_adj), maxval(stt_adj) + WRITE(6,*) 'COST_FUN = ', COST_FUNC + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Return to calling progam + END SUBROUTINE CALC_ADJ_FORCE_FOR_OBS + +!------------------------------------------------------------------------------ + SUBROUTINE CALC_ADJ_FORCE_FOR_SENS( ) +! +!****************************************************************************** +! Subroutine CALC_ADJ_FORCE_FOR_SENS calculates the cost function for +! sensitivity calculations. (dkh, ks, mak, cs 06/08/09) +! +! NOTE: +! (1 ) Split off from CALC_ADJ_FORCE (dkh, ks, mak, cs 06/08/09) +! (2 ) Add UNITS = 'ppm_free_trop'. (dkh, 05/06/10) +! (3 ) BUG FIX: correct units for cspec_ppb (fgap, dkh, 02/03/11) +! (4 ) Now control units via input.gcadj. Add LMAX_OBS and NSPAN. (dkh, 02/09/11) +! (5 ) Delete old code and add LPOP_UGM3 (sev, dkh, 02/13/12, adj32_024) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION, NTR2NOBS + USE ADJ_ARRAYS_MOD, ONLY : OBS_STT + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE ADJ_ARRAYS_MOD, ONLY : CNAME + USE ADJ_ARRAYS_MOD, ONLY : ADJOINT_AREA_M2 + USE ADJ_ARRAYS_MOD, ONLY : DEP_UNIT + USE ADJ_ARRAYS_MOD, ONLY : TRACER_IND + USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE ADJ_ARRAYS_MOD, ONLY : CS_DDEP_CONV + USE ADJ_ARRAYS_MOD, ONLY : DDEP_TRACER + USE ADJ_ARRAYS_MOD, ONLY : DDEP_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : WDEP_CV + USE ADJ_ARRAYS_MOD, ONLY : WDEP_LS + USE CHECKPT_MOD, ONLY : CHK_STT + USE ERROR_MOD, ONLY : DEBUG_MSG, IT_IS_NAN, ERROR_STOP + USE DAO_MOD, ONLY : AIRVOL, AD + USE DIAG_MOD, ONLY : AD44 + USE DIAG_MOD, ONLY : AD38 + USE DIAG_MOD, ONLY : AD39 + USE DRYDEP_MOD, ONLY : NUMDEP + USE DRYDEP_MOD, ONLY : NTRAIND + USE TIME_MOD, ONLY : GET_LOCALTIME + USE TIME_MOD, ONLY : GET_TS_CHEM + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TRACERID_MOD + USE COMODE_MOD, ONLY : JLOP, CSPEC + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE COMODE_MOD, ONLY : VOLUME + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDO3 + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM +#if defined ( LIDORT ) + USE LIDORT_MOD, ONLY : CALC_RF_FORCE +#endif + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS + USE LOGICAL_ADJ_MOD, ONLY : LKGBOX + USE LOGICAL_ADJ_MOD, ONLY : LUGM3 + USE LOGICAL_ADJ_MOD, ONLY : LSTT_PPB + USE LOGICAL_ADJ_MOD, ONLY : LSTT_TROP_PPM + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_PPB + USE LOGICAL_ADJ_MOD, ONLY : LPOP_UGM3 + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LKGNHAYR + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_OBS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_MOD, ONLY : LCHEM + USE PBL_MIX_MOD, ONLY : GET_PBL_TOP_L + USE PBL_MIX_MOD, ONLY : GET_PBL_MAX_L + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP + USE POPULATION_MOD, ONLY : POP_WEIGHT_COST + USE TIME_MOD, ONLY : GET_TS_DYN + USE TIME_MOD, ONLY : GET_TS_CHEM + USE WETSCAV_MOD, ONLY : GET_WETDEP_IDWETD + USE WETSCAV_MOD, ONLY : NSOL + ! for flux based cost function (hml,06/13/12) + USE LOGICAL_ADJ_MOD, ONLY : LFLX_UGM2 + USE GRID_MOD, ONLY : GET_AREA_M2 + ! for Antarctica cost function (hml,07/16/12) + USE DAO_MOD, ONLY : IS_ICE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! XNUMOL + ! added (dkh, 10/25/07) +# include "comode.h" ! IGAS, ITLOOP + + + ! Internal variables + REAL*8 :: DIFF + REAL*8 :: NEW_COST(IIPAR,JJPAR,LLPAR,N_TRACERS) + REAL*8 :: ADJ_FORCE(IIPAR,JJPAR,LLPAR,N_TRACERS) + INTEGER :: I, J, L, N + INTEGER :: ADJ_EXPLD_COUNT + INTEGER, PARAMETER :: MAX_ALLOWED_EXPLD = 10 + REAL*8, PARAMETER :: MAX_ALLOWED_INCREASE = 10D10 + REAL*8 :: MAX_ADJ_TMP + REAL*8 :: TARGET_STT + REAL*8 :: FACTOR + !CHARACTER(LEN=40) :: UNITS + REAL*8 :: CF_PRIOR + REAL*8 :: VCD + LOGICAL, SAVE :: FIRST = .TRUE. + REAL*8 :: DTCHEM + REAL*8 :: NTSCHEM + REAL*8 :: PBL_MAX + REAL*8 :: CONV_TIME, CONV_AREA(IIPAR,JJPAR) + REAL*8 :: CONV_C(N_TRACERS) + INTEGER :: NN + + + ! added to support observation (or sensitivity wrt) of CSPEC species + INTEGER :: JLOOP + REAL*8 :: NEW_COST_CSPEC(ITLOOP,NOBS_CSPEC) + REAL*8 :: NEW_COST_AIR(ITLOOP) + REAL*8 :: AIR_SUM + REAL*8 :: NEW_CF + REAL*8, PARAMETER :: CONVERT_FAC = 1d3 / 28.966d0 * 6.023D23 + ! Parameter coverning temporal averaging range (total nmber of chem time steps) + ! Now use NSPAN, set in input.gcadj + !REAL*8, PARAMETER :: NTSCHEM = 24d0 * 30d0 + + ! Parameters covering spatial averaging range for CSPEC-based cost functions. + ! For STT-based cost functions, use CF_REGION to mask spatial regions. + INTEGER, PARAMETER :: LMIN = 1 + INTEGER, PARAMETER :: LMAX = LLTROP + INTEGER, PARAMETER :: JMIN = 1 + INTEGER, PARAMETER :: JMAX = JJPAR + INTEGER, PARAMETER :: IMIN = 1 + INTEGER, PARAMETER :: IMAX = IIPAR + + INTEGER, SAVE :: OBS_COUNT = 0 + + ! Parameters covering chemical range (can't set a PARAMETER to a tracerid) + INTEGER :: NMIN + INTEGER :: NMAX + + ! for flux based cost function (hml, 06/13/12) + REAL*8 :: COST_AREA + + !================================================================ + ! CALC_ADJ_FORCE_FOR_SENSE begins here! + !================================================================ + + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + 1 + IF ( OBS_COUNT > NSPAN ) RETURN + ENDIF + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C A L C A D J F O R C E - S E N S E ' + + ! Some error checking stuff + MAX_ADJ_TMP = MAXVAL( STT_ADJ ) + ADJ_EXPLD_COUNT = 0 + + ! Radiative forcing sensitivities (dkh, 07/30/10) +#if defined( LIDORT ) + CALL CALC_RF_FORCE( COST_FUNC, N_CALC ) + RETURN +#endif + + + NEW_COST = 0d0 + + ! Evaulate J in units of kg/box is default for global FD tests. + ! Deposition adjoint forcing is applied elsewhere for FD tests. + IF ( ( LFD_GLOB .and. ( .not. LADJ_FDEP ) ) .or. LKGBOX ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) + DO NN = 1, NOBS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Get tracer index of current observation + N = TRACER_IND(NN) + + ! Determine the contribution to the cost function in each grid cell + ! from each species + + ! dkh -- I use N_CALC = 1 to do JACOBIAN test + NEW_COST(I,J,L,N) = GET_CF_REGION(I,J,L) * CHK_STT(I,J,L,N) + + ! Force the adjoint variables x with dJ/dx=1 + ADJ_FORCE(I,J,L,N) = GET_CF_REGION(I,J,L) + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + ADJ_FORCE(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + + ! Evaulate J in units of ug/m3 + ELSEIF ( LUGM3 ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) +!$OMP+PRIVATE( DIFF ) + DO NN = 1, NOBS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Get tracer number for current obs + N = TRACER_IND(NN) + + ! Determine the contribution to the cost function in each grid cell + ! from each species + + ! dkh -- I use N_CALC = 1 to do JACOBIAN test + ! Convert to ug/m3 (dkh, 10/13/06) + NEW_COST(I,J,L,N) = GET_CF_REGION(I,J,L) * CHK_STT(I,J,L,N) + & * 1d9 / AIRVOL(I,J,L) + + ! Force the adjoint variables x with dJ/dx=1 + ! Account for unit conversion to ug/m3 (dkh, 10/13/06) + ADJ_FORCE(I,J,L,N) = GET_CF_REGION(I,J,L) + & * 1d9 / AIRVOL(I,J,L) + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + ADJ_FORCE(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + + ! Evaulate J in units of ppb + ELSEIF ( LSTT_PPB ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) +!$OMP+PRIVATE( DIFF ) + DO NN = 1, NOBS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Get tracer number for current obs + N = TRACER_IND(NN) + + ! Determine the contribution to the cost function in each grid cell + ! from each species + + ! dkh -- I use N_CALC = 1 to do JACOBIAN test + NEW_COST(I,J,L,N) = GET_CF_REGION(I,J,L) * CHK_STT(I,J,L,N) + & * TCVV(N) / AD(I,J,L) * 1d9 + + ! Force the adjoint variables x with dJ/dx=1 + ADJ_FORCE(I,J,L,N) = GET_CF_REGION(I,J,L) + & * TCVV(N) / AD(I,J,L) * 1d9 + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + ADJ_FORCE(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + + ! Evaulate J in units of ppm and only in the free trop + ELSEIF ( LSTT_TROP_PPM ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) +!$OMP+PRIVATE( DIFF ) + DO NN = 1, NOBS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Get tracer number for current obs + N = TRACER_IND(NN) + + IF ( L > GET_PBL_TOP_L(I,J) ) THEN + ! Determine the contribution to the cost function in each grid cell + ! from each species + + ! dkh -- I use N_CALC = 1 to do JACOBIAN test + NEW_COST(I,J,L,N) = GET_CF_REGION(I,J,L) + & * CHK_STT(I,J,L,N) + & * TCVV(N) / AD(I,J,L) * 1d6 + + ! Force the adjoint variables x with dJ/dx=1 + ADJ_FORCE(I,J,L,N) = GET_CF_REGION(I,J,L) + & * TCVV(N) / AD(I,J,L) * 1d6 + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + ADJ_FORCE(I,J,L,N) + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + + + ! Evaulate J in units of ppb, but observe a species (CSPEC) rather + ! than a tracer (STT). Consider the temporal / spatial average of O3. (dkh, 10/25/07) + ELSEIF ( LCSPEC_PPB ) THEN + + ! Always initialize this to 0d0 becuase it will always get added to ADCSPEC in + ! chemdr_adj + CSPEC_AFTER_CHEM_ADJ(:,:) = 0D0 + + ! Clear arrays + NEW_COST_CSPEC(:,:) = 0D0 + NEW_COST_AIR(:) = 0D0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, JLOOP ) +!$OMP+PRIVATE( DIFF ) + DO L = LMIN, LMAX + DO J = JMIN, JMAX + DO I = IMIN, IMAX + + ! 1-D SMVGEAR grid box index + JLOOP = JLOP(I,J,L) + IF ( JLOOP == 0 ) CYCLE + + + DO N = 1, NOBS_CSPEC + + ! Save the # of species and air molecules in each cell relevant to our cost function. + ! For O3, convert [#/cm3] --> [#] (note: AIRVOL is in m3) + NEW_COST_CSPEC(JLOOP,N) = CSPEC_AFTER_CHEM(JLOOP,N) + & * AIRVOL(I,J,L) + & * 1d6 + + ENDDO + + ! for AIR, convert [kg] --> [#]: + ! + ! AD [kg air] AVN [# air / mole] 1d3 [g air] + ! = ------------ * --------------------- * ----------- + ! MW Air [g air / mole] [kg air] + ! + ! The non-spatially dependent terms are bundled into CONVERT_FAC and calculated + ! only once ahead of time. The remaining terms are calculated within the loop. + NEW_COST_AIR(JLOOP) = AD(I,J,L) * CONVERT_FAC + + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + AIR_SUM = SUM( NEW_COST_AIR(:) ) + + ! Cost function is the mean concentration of in ppb, averaged + ! over the whole month. Multiply by 1d9 to convert to ppb and + ! divide by the total number of chemistry time steps during + ! the month. + COST_FUNC = COST_FUNC + & + SUM( NEW_COST_CSPEC(:,:) ) / AIR_SUM + & * 1d9 / NSPAN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, JLOOP ) +!$OMP+PRIVATE( DIFF ) + DO L = LMIN, LMAX + DO J = JMIN, JMAX + DO I = IMIN, IMAX + + ! 1-D SMVGEAR grid box index + JLOOP = JLOP(I,J,L) + IF ( JLOOP == 0 ) CYCLE + + ! Store the adjoint forcing in CSPEC_ADJ_FORCE, + ! which will be applied to ADCSPEC directly before the + ! adjoint of chemistry. + !------------------------------------------------------ + ! BUG FIX: + ! OLD code: + ! J = sum(O3 * AIRVOL) / sum( AIR ) / NTSCHEM * 1d9 + ! dJ/dO3 = * AIRVOL / sum( AIR ) / NTSCHEM * 1d9 + !CSPEC_ADJ_FORCE(JLOOP,IDO3) = AIRVOL(I,J,L) + & ! / AIR_SUM / NTSCHEM * 1d9 + ! NEW code: don't forget that O3 is multiplied by 1d6 + ! and now we use CSPEC_AFTER_CHEM_ADJ (fagp, dkh, 02/09/11) + ! J = sum(O3 * AIRVOL * 1d6) / sum( AIR ) / NTSCHEM * 1d9 + ! dJ/dO3 = * AIRVOL * 1d6 / sum( AIR ) / NTSCHEM * 1d9 + DO N = 1, NOBS_CSPEC + + CSPEC_AFTER_CHEM_ADJ(JLOOP,N) = AIRVOL(I,J,L) * 1d6 + & / AIR_SUM / NSPAN * 1d9 + ENDDO + !------------------------------------------------------ + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ! Call population weighted ug/m3 (sev, dkh, 02/13/12, adj32_024) + ELSEIF ( LPOP_UGM3 ) THEN + + CALL POP_WEIGHT_COST + + ! >> Evaluate J in units of ug/m2/hr (hml, 06/12/12) + ELSEIF ( LFLX_UGM2 ) THEN + + ! Clear array + COST_AREA = 0d0 + + DO J = JMIN, 8 !(90S-60S) + DO I = IMIN, IMAX + + ! For Antarctica (hml, 04/10/13) + IF ( IS_ICE(I,J) ) THEN + + ! To get the total area of cost function + COST_AREA = COST_AREA + GET_AREA_M2(J) + + ENDIF + + ENDDO + ENDDO + + WRITE(6,*)' COST_AREA (m2) = ', COST_AREA + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) + DO N = 1, NOBS + DO L = 1, 1 ! This option only valid for one level; Default is surface. + DO J = JMIN, 8 !(90S-60S) + DO I = IMIN, IMAX + + NN = NTR2NOBS(N) + + ! For Antarctica (hml, 04/10/13) + IF ( IS_ICE(I,J) ) THEN + + + ! Determine the contribution to the cost function in each grid cell + ! from each species + + ! Unit conversion from kg/box to ug/m2/hr after the loop + ! for efficiency (hml, 06/13/12) + NEW_COST(I,J,L,NN) = GET_CF_REGION(I,J,L) + & *CHK_STT(I,J,L,NN) + + ! Force the adjoint variables x with dJ/dx=1 + ! Convert to ug/m2 (hml, 06/13/12) + ADJ_FORCE(I,J,L,NN) = GET_CF_REGION(I,J,L) + & / COST_AREA / NSPAN * 1d9 + + STT_ADJ(I,J,L,NN) = STT_ADJ(I,J,L,NN) + & +ADJ_FORCE(I,J,L,NN) + + ENDIF + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + & / COST_AREA / NSPAN * 1d9 + ! << + + ! species dry deposition forcing + ELSEIF ( LADJ_FDEP ) THEN + + ! tracer dry dep cost function + IF ( LADJ_DDEP_TRACER ) THEN + + ! Aerosol drydep forcings are applied directly withing sulfate_adj_mod.f + + ! Compute the cost function + IF ( FIRST ) THEN + + ! Update cost function + NEW_CF = SUM( DDEP_TRACER(:,:,:) ) + WRITE(6,*) ' DRY DEP STT COST FUNCTION = ', NEW_CF + COST_FUNC = COST_FUNC + NEW_CF + + ENDIF + + ENDIF + + IF ( LADJ_DDEP_CSPEC .and. LCHEM ) THEN + + ! Always initialize this to 0d0 becuase it will always get added to ADCSPEC in + ! chemdr_adj + CSPEC_AFTER_CHEM_ADJ(:,:) = 0D0 + + DTCHEM = GET_TS_CHEM() * 60d0 + NTSCHEM = NSPAN / ( GET_TS_CHEM() / 60D0 ) + + PBL_MAX = GET_PBL_MAX_L() + + + !default is molec/cm2/s + CONV_TIME = 1D0 / DTCHEM * 1D0 / NTSCHEM + + DO I = 1, IIPAR + DO J = 1, JJPAR + CONV_AREA(I,J) = 1d0 / GET_AREA_CM2(J) + ENDDO + ENDDO + + DO N = 1, NOBS_CSPEC + + WRITE(*,*) ' - FORCE DRY DEPOSITION: ', + & TRIM(CNAME(N)),' (',TRIM(DEP_UNIT),')' + + ENDDO + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, JLOOP, N ) + DO N = 1, NOBS_CSPEC + DO L = 1, PBL_MAX + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( GET_FRAC_UNDER_PBLTOP( I, J, L ) > 0d0 ) THEN + + JLOOP = JLOP(I,J,L) + + CSPEC_AFTER_CHEM_ADJ(JLOOP,N) = + & VOLUME(JLOOP) + & * CONV_TIME + & * CONV_AREA(I,J) + & * GET_CF_REGION(I,J,L) + & * CS_DDEP_CONV(J,N) + & + CSPEC_AFTER_CHEM_ADJ(JLOOP,N) + + + ENDIF + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF ( FIRST ) THEN + + ! Update cost function + NEW_CF = SUM( DDEP_CSPEC(:,:,:) ) + WRITE(6,*) ' DRY DEP CSPEC COST FUNCTION = ', NEW_CF + COST_FUNC = COST_FUNC + NEW_CF + + ENDIF + + ENDIF + + ! Wet deposition LS forcing + IF ( LADJ_WDEP_LS ) THEN + + ! Forcings are applied in WETSCAV_ADJ_FORCE, which is called directly from + ! DO_WETDEP_ADJ + + ! Compute the cost function using the AD44 diagnostic + IF ( FIRST ) THEN + + ! Update cost function + NEW_CF = SUM( WDEP_LS(:,:,:) ) + WRITE(6,*) ' WET DEP LS COST FUNCTION = ', NEW_CF + COST_FUNC = COST_FUNC + NEW_CF + + ENDIF + + ENDIF + + ! Wet deposition CV forcing + IF ( LADJ_WDEP_CV ) THEN + + ! Forcings are applied in ADJ_NFCLDMX, which is called directly from + ! DO_CONVECTION_ADJ + + ! Compute the cost function using the AD44 diagnostic + IF ( FIRST ) THEN + + ! Update cost function + NEW_CF = SUM( WDEP_CV(:,:,:) ) + WRITE(6,*) ' WET DEP CV COST FUNCTION = ', NEW_CF + COST_FUNC = COST_FUNC + NEW_CF + + ENDIF + + ENDIF + + ELSE + + CALL ERROR_STOP('COST FUNCTION option not defined ', + & 'geos_chem_adj_mod.f' ) + + + ENDIF ! Units + + + ! Echo output to screen + IF ( LPRINTFD ) THEN + WRITE(6,*) ' ADJ_FORCE(:) = ', ADJ_FORCE(IFD,JFD,LFD,NFD) + WRITE(6,*) ' Using predicted value (CHK_STT) = ' + & , CHK_STT(IFD,JFD,LFD,NFD) + WRITE(6,*) ' Using CF_REGION = ', GET_CF_REGION(IFD,JFD,LFD) + WRITE(6,*) ' STT_ADJ(IFD,JFD,LFD,NFD) = ' + & , STT_ADJ(IFD,JFD,LFD,NFD) + WRITE(6,*) ' MIN/MAX OF STT_ADJ:', + & MINVAL(STT_ADJ), MAXVAL(STT_ADJ) + ENDIF + + ! Error checking: warn of exploding adjoit values, except + ! the first jump up from zero (MAX_ADJ_TMP = 0 first few times) + IF ( MAXVAL(ABS(STT_ADJ)) > (MAX_ADJ_TMP * MAX_ALLOWED_INCREASE) + & .AND. ( MAX_ADJ_TMP > 0d0 ) ) THEN + + WRITE(6,*)' *** - WARNING: EXPLODING adjoints in ADJ_AEROSOL' + WRITE(6,*)' *** - MAX(STT_ADJ) before = ',MAX_ADJ_TMP + WRITE(6,*)' *** - MAX(STT_ADJ) after = ',MAXVAL(ABS(STT_ADJ)) + + ADJ_EXPLD_COUNT = ADJ_EXPLD_COUNT + 1 + + IF (ADJ_EXPLD_COUNT > MAX_ALLOWED_EXPLD ) + & CALL ERROR_STOP('Too many exploding adjoints', + & 'ADJ_AEROSOL, adjoint_mod.f') + + ENDIF + + FIRST = .FALSE. + + WRITE(6,*) 'COST_FUN = ', COST_FUNC + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Return to calling progam + END SUBROUTINE CALC_ADJ_FORCE_FOR_SENS + +!------------------------------------------------------------------------------ + + SUBROUTINE LOAD_CHECKPT_DATA( NYMD, NHMS ) +! +!****************************************************************************** +! Subroutine LOAD_CHECKPT_DATA reads in information stored during the forward +! calculation. Some of the data (CSPEC) needs to be rotated. +! (dkh, 08/10/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NYMD (INTEGER) : NYMD in adjoint integration +! (2 ) NHMS (INTEGER) : NHMS in adjoint integration +! +! NOTES: +! (1 ) Added support for full chemistry. This subroutine is old code that's +! been lumped together, plus now we also rotate CSPEC and load STT. +! (2 ) Now save copy of ozone concentration to O3_AFTER_CHEM. Now reference +! IDO3 in TRACERID_MOD. +! (3 ) Add NO2_AFTER_CHEM. Now reference IDNO2 in TRACERID_MOD. (dkh, 11/07/06) +! (4 ) Updated to v8 adjoint (dkh, ks, mak, cs 06/14/09) +! (5 ) BUG FIX: LVARTROP treated correctly (dkh, 01/26/11) +! (6 ) Now use CSPEC_AFTER_CHEM to replace O3_AFTER_CHEM and NO2_AFTER_CHEM +! (dkh, 02/09/11) +! (7 ) Now check to make sure FD cell is in trop before printing out debug +! info (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! Reference to f90 modules + USE TIME_MOD, ONLY : ITS_TIME_FOR_CHEM + USE CHECKPT_MOD, ONLY : READ_CHECKPT_FILE, CHK_STT, CHK_PSC, + & CHK_STT_BEFCHEM, RP_IN, + & CHK_HSAVE, PART_CASE, + & READ_CHK_CON_FILE ! (dkh, 09/15/08) + USE COMODE_MOD, ONLY : CHK_CSPEC, CSPEC , JLOP, + & CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : HSAVE + USE DAO_MOD, ONLY : AIRVOL, AIRDEN, BXHEIGHT, + & DELP, AIRQNT, AD + USE PRESSURE_MOD, ONLY : SET_FLOATING_PRESSURE + USE TRACERID_MOD, ONLY : IDO3, IDNO2 + USE GEOS_CHEM_MOD, ONLY : NSECb + USE GCKPP_ADJ_GLOBAL, ONLY : NVAR !, SMAL2 -- SMAL2 is in comode.h + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_MOD, ONLY : LCHEM + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + + ! add (dkh, 02/02/09) + USE CHECKPT_MOD, ONLY : READ_CHK_DYN_FILE + + ! Now add TMP met fields, which are loaded here + USE DAO_MOD, ONLY : SLP, SLP_TMP + USE DAO_MOD, ONLY : LWI, LWI_TMP + USE DAO_MOD, ONLY : TO3, TO3_TMP + USE DAO_MOD, ONLY : TTO3, TTO3_TMP + + ! LVARTROP support for adj (dkh, 01/26/11) + USE COMODE_MOD, ONLY : CSPEC_FULL + USE COMODE_MOD, ONLY : IXSAVE, IYSAVE, IZSAVE + USE LOGICAL_MOD, ONLY : LVARTROP + USE COMODE_MOD, ONLY : ISAVE_PRIOR + + + +# include "CMN_SIZE" ! Size params +# include "comode.h" ! ITLOOP, IGAS +# include "define.h" ! ITLOOP, IGAS + + + ! Arguments + INTEGER, INTENT(IN) :: NYMD, NHMS + + ! Local variables + INTEGER :: I, J, L, JLOOP, N + INTEGER :: IDCSPEC + LOGICAL, SAVE :: TURNAROUND = .TRUE. + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! LOAD_CHECKPT_DATA begins here! + !================================================================= + + ! Load the TMP met fields so they can rotate in later. + IF ( FIRST ) THEN + SLP_TMP(:,:) = SLP(:,:) +#if defined( GEOS_3 ) || defined( GEOS_4 ) || defined( GEOS_5 ) || defined(GEOS_FP) + LWI_TMP(:,:) = LWI(:,:) +#endif +#if defined( GEOS_5 ) || defined(GEOS_FP) + TO3_TMP(:,:) = TO3(:,:) + TTO3_TMP(:,:) = TTO3(:,:) +#endif + FIRST = .FALSE. + ENDIF + + IF ( ITS_TIME_FOR_CHEM() ) THEN + + ! Rotate arrays for fullchem + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + IF ( TURNAROUND .and. IDO3 /= 0 .and. IDNO2 /=0 ) THEN + + ! Added in v16 (dkh, 08/27/06) + ! Get directly from CSPEC the first time +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP, N, IDCSPEC ) + DO JLOOP = 1, ITLOOP + DO N = 1, NOBS_CSPEC + + IDCSPEC = IDCSPEC_ADJ(N) + ! Now make this more general (dkh, 02/09/11) + !O3_AFTER_CHEM(JLOOP) = CSPEC(JLOOP,IDO3) + !NO2_AFTER_CHEM(JLOOP) = CSPEC(JLOOP,IDNO2) + CSPEC_AFTER_CHEM(JLOOP,N) = CSPEC(JLOOP,IDCSPEC) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ELSEIF ( IDO3 /= 0 .and. IDNO2 /=0 ) THEN + + ! Don't need to do this rotate stuff, (dkh, 08/29/05) + ! Actually, we do need the values of ozone after chem + ! because we need to know O3 concentrations for additional + ! sulfate chemistry. (dkh, 10/12/05) + ! Use the checkpted values from last file read. + ! For using satellite data, we know also need NO2 after chemistry + ! so that we can interpolate NO2 at time of observation (dkh, 11/07/06) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP, N, IDCSPEC ) + DO JLOOP = 1, ITLOOP + DO N = 1, NOBS_CSPEC + + IDCSPEC = IDCSPEC_ADJ(N) + + + ! Replace these with CSPEC_AFTER_CHEM (dkh, 02/09/11) + !O3_AFTER_CHEM(JLOOP) = CHK_CSPEC(JLOOP,IDO3) + !NO2_AFTER_CHEM(JLOOP) = CHK_CSPEC(JLOOP,IDNO2) + CSPEC_AFTER_CHEM(JLOOP,N) = CHK_CSPEC(JLOOP,IDCSPEC) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ! Turnaround will be false after the first time through this routine + TURNAROUND = .FALSE. + + ENDIF ! fullchem + + ! Read data from file + CALL READ_CHECKPT_FILE ( NYMD, NHMS ) + + IF ( ITS_A_FULLCHEM_SIM() .AND. LCHEM ) THEN + + ! Reset STT and CSPEC so that chemical rxn rates can be recalculated +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + STT(I,J,L,N) = CHK_STT_BEFCHEM(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! LVARTROP support for adj (dkh, 01/26/11) + IF ( LVARTROP ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( N, JLOOP, I, J, L ) + DO N = 1, IGAS + DO JLOOP = 1, NTLOOP + + ! 3-D array indices + I = ISAVE_PRIOR(JLOOP,1) + J = ISAVE_PRIOR(JLOOP,2) + L = ISAVE_PRIOR(JLOOP,3) + + ! Copy from 3-D array + CHK_CSPEC(JLOOP,N) = CSPEC_FULL(I,J,L,N) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! Load in the values of CSPEC from the previous (fwd) time step that + ! were saved as CPSEC_PRIOR. +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP, N ) + DO N = 1, IGAS + DO JLOOP = 1, ITLOOP + + ! Reset small values that have been read in as zero from the checkpt file. + ! These values were set to SMAL2, but in reading and writing to 8bit file + ! they get converted to zero, which lead to NaN in PARTITION. Only a problem + ! for the firt NVAR entries. (dkh, 08/29/05) + IF ( CHK_CSPEC(JLOOP,N) < SMAL2 .AND. N <= NVAR ) + & CHK_CSPEC(JLOOP,N) = SMAL2 + + CSPEC(JLOOP,N) = CHK_CSPEC(JLOOP,N) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ! dkh debug + !IF ( LPRINTFD ) THEN + IF ( LPRINTFD .and. JLOP(IFD,JFD,LFD) > 0 ) THEN + print*, 'CSPEC read = ', CSPEC(JLOP(IFD,JFD,LFD),:) + print*, 'JLOP read = ', JLOP(IFD,JFD,LFD) + ENDIF + + ! Reset HSAVE to the value from previous time step, written to + ! chk file corresponding to this time step. (dkh, 09/06/05) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO I = 1, IIPAR + DO J = 1, JJPAR + DO L = 1, LLTROP + + HSAVE(I,J,L) = CHK_HSAVE(I,J,L) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !IF ( LPRINTFD ) THEN + IF ( LPRINTFD .and. JLOP(IFD,JFD,LFD) > 0 ) THEN + WRITE(6,*) 'CHK_STT(FD) = ', CHK_STT(IFD,JFD,LFD,NFD) + WRITE(6,*) 'CHK_STT_BEFCHEM(FD) =', + & CHK_STT_BEFCHEM(IFD,JFD,LFD,NFD) + WRITE(6,*) 'PART_CASE(FD) = ', + & PART_CASE(JLOP(IFD,JFD,LFD)) + ENDIF + + ENDIF ! fullchem + + + ENDIF ! ITS_TIME_FOR_CHEM + + ! Now read variables checkpointed at the dynamic time step (dkh, 02/02/09) + CALL READ_CHK_DYN_FILE( NYMD, NHMS ) + + ! Set the surface pressure to be consistant with the forward run + ! Note: if, at some point, want to include adjoints of any of the + ! the processes that occur before transport in fwd run, want to use + ! CHK_PSC(:,:,1) (for example lightning NOX emissions?). + CALL SET_FLOATING_PRESSURE( CHK_PSC(:,:,2) ) + + ! Add mak and ks checkpointing files. Make sure they get read every + ! dynamic time step. (dkh, 10/10/08) +#if defined( GEOS_4 ) + CALL READ_CHK_CON_FILE ( NYMD, NHMS ) +#endif + + ! Recompute airmasses + CALL AIRQNT + + IF ( LPRINTFD ) THEN + WRITE(6,*) + & ' AD(FD) = ', AD(IFD,JFD,LFD), + & ' AIRVOL(FD) =', AIRVOL(IFD,JFD,LFD), + & ' AIRDEN(FD) =', AIRDEN(LFD,IFD,JFD), + & ' BXHEIGHT = ', BXHEIGHT(IFD,JFD,LFD), + & ' DELP = ', DELP(LFD,IFD,JFD) + ENDIF + + + ! Return to calling program + END SUBROUTINE LOAD_CHECKPT_DATA + +!------------------------------------------------------------------------------ + SUBROUTINE RESCALE_ADJOINT( ) +! +!****************************************************************************** +! Subroutine RESCALE_ADJOINT multiplies the adjoint sensitivities by the +! initial concentrations read from the restart file. +! dkh, 02/20/05 +! +! NOTES: +! (1 ) Don't use the RESTART array anymore. Need to make a +! STT2ADJ lookup table. (dkh, 03/03/05) +! (2 ) Save original tracer values (in ug/m3) to ORIG_STT. Remultiply by this +! rather than reading in the restart file again. (06/15/05) +! (3 ) Now ORIG_STT in [kg/box] +! (4 ) Add support for EMISSIONS case. (dkh, 07/23/06) +! (5 ) Cosmetic changes and lots of comments. (dkh, 10/04/06) +! (6 ) Add FK to penalize equally for scaling up or down (dkh, 12/07/06). +! (7 ) Update to v8 (mak, 6/18/09) +! (8 ) Potential problem (especially with L3DVAR option: READ_RESTART_FILE +! overwrites the current value of STT, which is ok at the end of +! the adjoint run, but otherwise, STT has the checkpointed STT value. +! So for now, the only option in optimizing LICS is optimizing +! concentrations at the very first time step only. (mak, 6/19/09) +! (9 ) Clean up and simplify to only calculate ICS_SF_ADJ. (dkh, 11/06/09) +!****************************************************************************** +! + ! Reference to f90 modules + USE TRACERID_MOD ! IDTxxx + USE ERROR_MOD, ONLY : ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ, COST_FUNC, + & ICS_SF, ICS_SF0, + & MMSCL, NNEMS, ICS_SF_ADJ, + & OPT_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : STT_ORIG + USE TRACER_MOD, ONLY : N_TRACERS, STT + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST, LICS, L4DVAR, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LSENS + +# include "CMN_SIZE" + + ! Local variables + INTEGER :: I, J, L, N, M + + !====================================================================== + ! RESCALE_ADJOINT begins here! + !====================================================================== + + ! Only rescale, no regularize, for FD or sensitivity TEST + IF ( LICS ) THEN + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + + ! Rescale all gradients by ORIG_STT so that the gradients + ! are dCOST/dscaling factor. + ICS_SF_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) * STT_ORIG(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! mak debug 6/19/09 + PRINT*, 'MIN/MAX OF ICS_SF_ADJ:', minval(ICS_SF_ADJ), + & maxval(ICS_SF_ADJ) + PRINT*, 'MIN/MAX OF STT_ADJ:', minval(STT_ADJ), + & maxval(STT_ADJ) + + + END SUBROUTINE RESCALE_ADJOINT + + +!------------------------------------------------------------------------------ + + SUBROUTINE LOG_RESCALE_ADJOINT +! +!****************************************************************************** +! Subroutine LOG_RESCALE_ADJOINT converts that adjoint scaling factors to be +! those of log based scaling factors. (dkh, 04/25/07) +! +! +! NOTES: +! (1 ) Updated to v8 (mak, 6/19/09) +! (2 ) Clean up and simplify to only to log-rescaling (dkh, 11/06/09) +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ, MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : STT_ORIG + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF0 + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS, LFDTEST + USE TRACER_MOD, ONLY : N_TRACERS, STT + +# include "CMN_SIZE" + + ! Local variables + INTEGER :: I, J, L, N, M + + !====================================================================== + ! LOG_RESCALE_ADJOINT begins here! + !====================================================================== + + + + IF ( LICS ) THEN + + ! Transform back to exponential scaling factors + ICS_SF_ADJ(:,:,:,:) = ICS_SF_ADJ(:,:,:,:) * ICS_SF(:,:,:,:) + ICS_SF(:,:,:,:) = LOG(ICS_SF(:,:,:,:)) + ICS_SF0(:,:,:,:) = LOG(ICS_SF0(:,:,:,:)) + + ENDIF + + IF ( LADJ_EMS ) THEN + + ! Transform back to exponential scaling factors + EMS_SF_ADJ(:,:,:,:) = EMS_SF_ADJ(:,:,:,:) * EMS_SF(:,:,:,:) + EMS_SF(:,:,:,:) = LOG(EMS_SF(:,:,:,:)) + EMS_SF0(:,:,:,:) = LOG(EMS_SF0(:,:,:,:)) + + ENDIF + + + END SUBROUTINE LOG_RESCALE_ADJOINT + +! Obsolete (zhej, dkh, 01/16/12, adj32_016) +!!------------------------------------------------------------------------------ +! +! SUBROUTINE NESTED_RESCALE_ADJOINT +!! +!!****************************************************************************** +!! Subroutine NESTED_RESCALE_ADJOINT set the gradient in the cushion region to +!! ZERO. (zhe 11/28/10) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ +! USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS, NOR +! +!# include "CMN_SIZE" +! +! ! Local variables +! REAL*8 :: EMS_SF_ADJ_SAVE(IIPAR,JJPAR,MMSCL,NNEMS) +! +! !====================================================================== +! ! NESTED_RESCALE_ADJOINT begins here! +! !====================================================================== +! +! +! EMS_SF_ADJ_SAVE = EMS_SF_ADJ +! EMS_SF_ADJ = 0d0 +! +! ! Nested observation region +! EMS_SF_ADJ(NOR(1):NOR(2),NOR(3):NOR(4),:,:) = +! & EMS_SF_ADJ_SAVE(NOR(1):NOR(2),NOR(3):NOR(4),:,:) +! +! ! Return to calling routine +! END SUBROUTINE NESTED_RESCALE_ADJOINT +! +!!------------------------------------------------------------------------------ + + + SUBROUTINE CALC_APRIORI + +!****************************************************************************** +! Subroutine CALC_APRIORI computes a priori term of the cost function and +! gradient. So that for cost function defined as: +! J(x) = (y-f(x))^T * Se^-1 *(y-f(x)) + (x-xa)^T * Sa^-1 * (x-xa) +! CALC_APRIORI computes (x-xa)^T Sa^-1 (x-xa), where xa are original scaling +! factors and x are currently optimized scaling factors and Sa^-1 is an +! inverse diagonal matrix of a priori source variance +! For gradient defined as: +! grad(J(x)) = 2 * grad(f(x)) * Se^-1 * (y-f(x)) + 2 * Sa^-1 * (x-xa) +! CALC_APRIORI computes 2 * Sa^-1 * (x-xa) +! for a time-independent inversion (MMSCL=1) +! (mak, 4/20/06) +! +! NOTES: +! ( 1) Currently the entire subroutine relies on Streets et al, 2003 inventory +! errors, following the setup in Colette Heald's 2004 inversion paper; +! Here, we specify 11 or so regions (12 splitting Korea and Japan) with +! 3 types of CO source (FF, BF, BB) +! ( 2) APGRAD needs to contain MMSCL dimensions (mak, 12/02/08) +! ( 3) Updated to v8 and new interface, make REG_PARAM come from input (mak, 6/19/09) +! ( 4) Minor compatibility updates (mak, 9/28/09) +! ( 5) Add a priori constraint for fulchem LOG_OPT (dkh, 12/15/09) +! ( 6) Now make ERR_EMS depend on the emissions type / species (dkh, 09/09/10) +! ( 7) Replace REG_PARAM_SPEC with REG_PARAM_ICS (dkh, 02/09/11) +! ( 8) Consolidate and cleanup (zhej, dkh, 01/18/12, adj32_017) +!****************************************************************************** +! + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF0, ICS_SF, ICS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_EMS, REG_PARAM_ICS + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ, ICS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_EMS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : ICS_ERROR + USE LOGICAL_ADJ_MOD, ONLY : L4DVAR, LADJ_EMS, LICS + USE TRACER_MOD, ONLY : N_TRACERS +#if defined ( TES_NH3_OBS ) + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_an1 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_sh + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENOX_so + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENOX_bb +#endif +#if defined ( LBKCOV_ERR ) + USE COVARIANCE_MOD , ONLY : CALC_COV_ERROR +#endif +# include "CMN_SIZE" + + INTEGER :: I, J, L, M, N, AS + + ! Obsolete (zhej, dkh, 01/18/12, adj32_017) + !REAL*8, ALLOCATABLE :: APCOST(:,:,:,:) + !REAL*8, ALLOCATABLE :: APGRAD(:,:,:,:) + !REAL*8, ALLOCATABLE :: ERR_PERCENT(:,:,:) + !REAL*8, ALLOCATABLE :: invSa(:,:,:) + !INTEGER :: count + !LOGICAL, SAVE :: TRACEP = .FALSE. + !LOGICAL, SAVE :: SEASONAL = .FALSE. + + ! for fullchem LOG_OPT runs (dkh, 12/15/09) + REAL*8 :: S2_INV + REAL*8 :: REG + + ! Replace TEMP2 with APCOST (zhej, dkh, 01/18/12, adj32_017) + !REAL*8 :: TEMP2(IIPAR,JJPAR,MMSCL,NNEMS) + REAL*8, ALLOCATABLE :: APCOST(:,:,:,:) + + ! Obsolete (zhej, dkh, 01/18/12, adj32_017) + !count = 0 + !TEMP2 = 0D0 + + ! Implement a priori term as was done in GCv6 adjoint. For now, keep this entirely + ! sep from monika's implementation. Merge these in the near future. (dkh, 12/15/09) + ! Now they are merged (zhej, dkh, 01/18/12, adj32_017) + !IF ( L4DVAR .and. ITS_A_FULLCHEM_SIM() .and. LADJ_EMS ) THEN + IF ( L4DVAR .and. LADJ_EMS ) THEN + + +#if defined ( TES_NH3_OBS ) + ! 100% error for NH3 emissions + EMS_ERROR(IDADJ_ENH3_an:IDADJ_ENH3_bf) = EXP(1d0) + + ! 25% error for SO2 emissions + EMS_ERROR(IDADJ_ESO2_an1:IDADJ_ESO2_sh) = EXP(0.25d0) + + ! 50% error for NOx emissions + EMS_ERROR(IDADJ_ENOX_so:IDADJ_ENOX_bb) = EXP(0.50d0) + + REG_PARAM_EMS(:) = 10d0 +#endif + + ! Replace TEMP2 with APCOST (zhej, dkh, 01/18/12, adj32_017) + ALLOCATE( APCOST( IIPAR,JJPAR,MMSCL,NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'APCOST' ) + APCOST = 0 + +#if ! defined ( LBKCOV_ERR ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, REG, S2_INV ) + DO N = 1, NNEMS + + ! Now skip emissions that are not included in optimization (dkh, 09/09/10) + IF ( .not. OPT_THIS_EMS(N) ) CYCLE + + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! diagonal of inverse error covariance +#if defined ( LOG_OPT ) + S2_INV = 1d0 / ( EMS_ERROR(N)/EMS_SF0(I,J,M,N) )**2 +#else + S2_INV = 1d0 / ( EMS_ERROR(N) )**2 +#endif + + REG = EMS_SF(I,J,M,N) - EMS_SF0(I,J,M,N) + + ! Calculate the contribution to the cost function, weighted by REG_PARAM + ! Replace TEMP2 with APCOST (zhej, dkh, 01/18/12, adj32_017) + APCOST(I,J,M,N) = 0.5d0 * REG_PARAM_EMS(N) * S2_INV + & * REG ** 2 + + ! Add this to the gradients + EMS_SF_ADJ(I,J,M,N) = EMS_SF_ADJ(I,J,M,N) + & + REG_PARAM_EMS(N) * S2_INV * REG + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO +#else + ! inverse of error covariance with off-diagonal terms + CALL CALC_COV_ERROR ( APCOST ) +#endif + + + ! Updated and merged (zhej, dkh, 01/18/12, adj32_017) + ELSEIF ( L4DVAR .AND. LICS ) THEN + + ALLOCATE( APCOST( IIPAR,JJPAR,LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'APCOST' ) + APCOST = 0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, REG, S2_INV ) + DO N = 1, N_TRACERS + + ! Now skip tracer that are not included in optimization (dkh, 09/09/10) + IF ( .not. OPT_THIS_TRACER(N) ) CYCLE + + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ! diagonal of inverse error covariance +#if defined ( LOG_OPT ) + S2_INV = 1d0 / ( ICS_ERROR(N) / ICS_SF0(I,J,L,N) )**2 +#else + S2_INV = 1d0 / ( ICS_ERROR(N) )**2 +#endif + + REG = ICS_SF(I,J,L,N) - ICS_SF0(I,J,L,N) + + ! Calculate the contribution to the cost function, weighted by REG_PARAM + APCOST(I,J,L,N) = 0.5d0 * REG_PARAM_ICS(N) * S2_INV + & * REG ** 2 + + ! Add this to the gradients + ICS_SF_ADJ(I,J,L,N) = ICS_SF_ADJ(I,J,L,N) + & + REG_PARAM_ICS(N) * S2_INV * REG + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ELSE + + PRINT*, 'OTHER SIMULATION TYPES NOT YET SUPPORTED' + PRINT*, 'ONLY L4DVAR with LICS OR LEMS (not even both)' + CALL ERROR_STOP('bad APRIORI option','geos_chem_adj_mod.f') + + ENDIF + + WRITE(6,*) 'COST_FUNC before apriori = ', COST_FUNC + + ! Add total regularization penalty to cost function + COST_FUNC = COST_FUNC + SUM(APCOST(:,:,:,:)) + + ! Write some output + WRITE(6,*) 'Total cost with penalty ...' + WRITE(6,*) 'COST_FUNC after adding apriori: ', COST_FUNC + WRITE(6,*) ' MAX APCOST = ', MAXVAL(APCOST(:,:,:,:)) + WRITE(6,*) ' SUM APCOST = ', SUM(APCOST(:,:,:,:)) + + + END SUBROUTINE CALC_APRIORI + +!----------------------------------------------------------------------- + + SUBROUTINE CALC_APRIORI_CO2 + +!****************************************************************************** +! Subroutine CALC_APRIORI_CO2 computes a priori term of the cost function and +! gradient for the CO2 simulation. (dkh, 01/09/11) +! +! In this routine, we assume that we have specified the standard deviation +! (error) in the EMS_ERROR array. +! +! For linear scaling factors, EMS_ERROR = p, where p is the pertent +! error in the emissions (as a decimal, ie 1 = 100%) +! +! For log scaling factors, EMS_ERROR = f, where f is a fractional error. f +! must be greater than 1. +! +! There is also a regularization parameter that is specified for each +! emissions inventory, REG_PARAM_EMS, in input.gcadj. +! +! NOTES: +! ( 1) Based on CALC_APRIORI +! +!****************************************************************************** + + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : COST_ARRAY, COST_FUNC, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR,COV_ERROR_LX,COV_ERROR_LY + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_EMS + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ, TEMP2 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ECO2ff, IDADJ_ECO2ocn + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS, LBKCOV + USE GRID_MOD , ONLY : GET_XMID, GET_YMID +#if defined ( LBKCOV_ERR ) + USE COVARIANCE_MOD , ONLY : CALC_COV_ERROR +#endif +# include "CMN_SIZE" + + REAL*8 :: S2_INV_2D(IIPAR,JJPAR) + REAL*8 :: REG_4D(IIPAR, JJPAR,MMSCL, NNEMS) + REAL*8 :: S2_INV + REAL*8 :: REG + REAL*8, ALLOCATABLE :: APCOST(:,:,:,:) + REAL :: TEMP(IIPAR,JJPAR) + INTEGER :: I, J, M, N, STATUS, NCID, VARID + CHARACTER(255) :: SCALEFN + + !================================================================= + ! CALC_APRIORI_CO2 begins here! + !================================================================= + +! ! For the moment, hardcode the emissions errors here. In the +! ! future, we should define these via input files. +!#if defined ( LOG_OPT ) +! ! assume a factor of two error +! EMS_ERROR(:) = 2d0 +!#else +! ! assume a 100% error +! EMS_ERROR(:) = 1d0 +! +! ! Alter a few to test if it's working +! !EMS_ERROR(IDADJ_ECO2ff) = 1d-2 +! !EMS_ERROR(IDADJ_ECO2ocn) = 1d2 +! +!#endif + print*, ' debug: EMS_ERROR = ', EMS_ERROR + + + ! So far have only developed this for emissions constraints + IF ( .not. LADJ_EMS ) THEN + + CALL ERROR_STOP( 'APRIORI_CO2 only for LICS', + & 'geos_chem_adj_mod.f' ) + + ENDIF + +#if ! defined ( LBKCOV_ERR ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, REG, S2_INV ) + DO N = 1, NNEMS + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + +#if defined ( LOG_OPT ) + ! inverse of error covariance (assume diagonal) + S2_INV = 1d0 / ( EMS_ERROR(N)/EMS_SF0(I,J,M,N) )**2 +#else + S2_INV = 1d0 / ( EMS_ERROR(N) ** 2 ) +#endif + + REG = EMS_SF(I,J,M,N) - EMS_SF0(I,J,M,N) + + ! Calculate the contribution to the cost function, weighted by REG_PARAM + TEMP2(I,J,M,N) = 0.5d0 * REG_PARAM_EMS(N) * S2_INV * REG ** 2 + + ! Add this to the gradients + EMS_SF_ADJ(I,J,M,N) = EMS_SF_ADJ(I,J,M,N) + & + REG_PARAM_EMS(N) * S2_INV * REG + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + +#else + ! inverse of error covariance with off-diagonal terms + CALL CALC_COV_ERROR ( APCOST ) +#endif + + WRITE(6,*) 'COST = ', COST_FUNC + + ! Add total regularization penalty to cost function + COST_FUNC = COST_FUNC + SUM(TEMP2(:,:,:,:)) !REG_COST + + ! Write some output + WRITE(6,*) 'Total cost with penalty = ', COST_FUNC + WRITE(6,*) ' MAX REG_COST = ', MAXVAL(TEMP2(:,:,:,:)) + WRITE(6,*) ' SUM REG_COST = ', SUM(TEMP2(:,:,:,:)) + + + END SUBROUTINE CALC_APRIORI_CO2 + +!----------------------------------------------------------------------- + + SUBROUTINE CALC_APRIORI_BCOC + +!****************************************************************************** +! Subroutine CALC_APRIORI_BCOC computes a priori term of the cost function and +! gradient for the BC simulation. (yhmao, dkh, 01/13/12, adj32_013) +! +! In this routine, we assume that we have specified the standard deviation +! (error) in the EMS_ERROR array. +! +! For linear scaling factors, EMS_ERROR = p, where p is the pertent +! error in the emissions (as a decimal, ie 1 = 100%) +! +! For log scaling factors, EMS_ERROR = f, where f is a fractional error. f +! must be greater than 1. +! +! There is also a regularization parameter that is specified for each +! emissions inventory, REG_PARAM_EMS, in input.gcadj. +! +! NOTES: +! ( 1) Based on CALC_APRIORI +! +! +!****************************************************************************** +! + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : COST_ARRAY, COST_FUNC, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_EMS + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS + +# include "CMN_SIZE" + + REAL*8 :: S2_INV + REAL*8 :: REG + REAL*8 :: TEMP2(IIPAR,JJPAR,MMSCL,NNEMS) + INTEGER :: I, J, M, N + + !================================================================= + ! CALC_APRIORI_BCOC begins here! + !================================================================= + + ! Initialize + TEMP2 = 0d0 + + + ! So far have only developed this for emissions constraints + IF ( .not. LADJ_EMS ) THEN + + CALL ERROR_STOP( 'APRIORI_BCPC not for LICS', + & 'geos_chem_adj_mod.f' ) + + ENDIF + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, REG, S2_INV ) + DO N = 1, NNEMS + IF ( .not. OPT_THIS_EMS(N) ) CYCLE + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + +#if defined ( LOG_OPT ) + ! inverse of error covariance (assume diagonal) + S2_INV = 1d0 / ( EMS_ERROR(N)/EMS_SF0(I,J,M,N) )**2 +#else + S2_INV = 1d0 / ( EMS_ERROR(N) ** 2 ) +#endif + + REG = EMS_SF(I,J,M,N) - EMS_SF0(I,J,M,N) + + ! Calculate the contribution to the cost function, weighted by REG_PARAM + TEMP2(I,J,M,N) = 0.5d0 * REG_PARAM_EMS(N) * S2_INV * REG ** 2 + + ! Add this to the gradients + EMS_SF_ADJ(I,J,M,N) = EMS_SF_ADJ(I,J,M,N) + & + REG_PARAM_EMS(N) * S2_INV * REG + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + WRITE(6,*) 'COST = ', COST_FUNC + + ! Add total regularization penalty to cost function + COST_FUNC = COST_FUNC + SUM(TEMP2(:,:,:,:)) !REG_COST + + ! Write some output + WRITE(6,*) 'Total cost with penalty = ', COST_FUNC + WRITE(6,*) ' MAX REG_COST = ', MAXVAL(TEMP2(:,:,:,:)) + WRITE(6,*) ' SUM REG_COST = ', SUM(TEMP2(:,:,:,:)) + + ! Return to calling program + END SUBROUTINE CALC_APRIORI_BCOC + +!----------------------------------------------------------------------- + + SUBROUTINE READ_APERROR( ERR_PERCENT ) +! +!****************************************************************************** +! Subroutine READ_APERROR reads observation error from binary punch files +! (zhe 6/6/11, adj32_018) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE TIME_MOD, ONLY : GET_TAUb + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + REAL*8 :: ERR_PERCENT( IIPAR,JJPAR, 2 ) + REAL*4 :: EMS_ERROR( IIPAR,JJPAR, 2 ) + + !================================================================= + ! READ_ERROR_VARIANCE begins here! + !================================================================= + + ! Filename + FILENAME = TRIM( 'APERROR_' ) // GET_RES_EXT() + + ! Echo some information to the standard output + WRITE( 6, 110 ) TRIM( FILENAME ) + 110 FORMAT( ' - READ_APERROR: Reading ERR_PERCENT + & from: ', a ) + + ! Read data from the binary punch file + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & GET_TAUb(), IGLOB, JGLOB, + & 1, EMS_ERROR, QUIET=.TRUE. ) + + ERR_PERCENT = EMS_ERROR + + ! Return to calling program + END SUBROUTINE READ_APERROR + +!----------------------------------------------------------------------- + + ! End of program + END MODULE GEOS_CHEM_ADJ_MOD diff --git a/code/adjoint/geos_chem_adj_mod.f~ b/code/adjoint/geos_chem_adj_mod.f~ new file mode 100644 index 0000000..c193621 --- /dev/null +++ b/code/adjoint/geos_chem_adj_mod.f~ @@ -0,0 +1,4342 @@ +!$Id: geos_chem_adj_mod.f,v 1.33 2012/09/24 21:44:47 yanko Exp $ +! ============================================================= +! + MODULE GEOS_CHEM_ADJ_MOD +! +!****************************************************************************** +! +! +! GGGGGG CCCCCC A DDDDD J OOO I N N TTTTTTT +! G C A A D D J O O I NN N T +! G GGG C == AAAAA D D J 0 O I N N N T +! G G C A A D D J J 0 O I N NN T +! GGGGGG CCCCCC A A DDDDD JJJ OOO I N N T +! +! +! for 4 x 5, 2 x 2.5 global grids and 1 x 1 nested grids +! +! Contact: Daven Henze (daven.henze@colorado.edu) +! +!****************************************************************************** +! +! See the GEOS-Chem-Adj wiki: +! +! http://wiki.seas.harvard.edu/geos-chem/index.php/GEOS-Chem_Adjoint +! +! for the most up-to-date GEOS-CHEM documentation on the following topics: +! +! - installation, compilation, and execution +! - coding practice and style +! - input files and met field data files +! - horizontal and vertical resolution +! - modification history +! +!****************************************************************************** + + IMPLICIT NONE + + ! Header files +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic switches, NJDAY +# include "CMN_GCTM" ! Physical constants +# include "define_adj.h" ! Obs operators + + CONTAINS + + SUBROUTINE DO_GEOS_CHEM_ADJ + + ! References to F90 modules + USE A3_READ_MOD, ONLY : GET_A3_FIELDS + USE A3_READ_MOD, ONLY : OPEN_A3_FIELDS + USE A3_READ_MOD, ONLY : UNZIP_A3_FIELDS + USE A6_READ_MOD, ONLY : GET_A6_FIELDS + USE A6_READ_MOD, ONLY : OPEN_A6_FIELDS + USE A6_READ_MOD, ONLY : UNZIP_A6_FIELDS + USE BENCHMARK_MOD, ONLY : STDRUN + USE CARBON_MOD, ONLY : WRITE_GPROD_APROD + USE CONVECTION_MOD, ONLY : DO_CONVECTION + USE COMODE_MOD, ONLY : INIT_COMODE + USE DIAG_MOD, ONLY : DIAGCHLORO + USE DIAG41_MOD, ONLY : DIAG41, ND41 + USE DIAG42_MOD, ONLY : DIAG42, ND42 + USE DIAG48_MOD, ONLY : DIAG48, ITS_TIME_FOR_DIAG48 + USE DIAG49_MOD, ONLY : DIAG49, ITS_TIME_FOR_DIAG49 + USE DIAG50_MOD, ONLY : DIAG50, DO_SAVE_DIAG50 + USE DIAG51_MOD, ONLY : DIAG51, DO_SAVE_DIAG51 + USE DIAG_OH_MOD, ONLY : PRINT_DIAG_OH + USE DAO_MOD, ONLY : AD, AIRQNT + USE DAO_MOD, ONLY : AVGPOLE, CLDTOPS + USE DAO_MOD, ONLY : CONVERT_UNITS, COPY_I6_FIELDS + USE DAO_MOD, ONLY : COSSZA, INIT_DAO + USE DAO_MOD, ONLY : INTERP, PS1 + USE DAO_MOD, ONLY : PS2, PSC2 + USE DAO_MOD, ONLY : T, TS + USE DAO_MOD, ONLY : SUNCOS, SUNCOSB + USE DAO_MOD, ONLY : SUNCOS_5hr + USE DAO_MOD, ONLY : MAKE_RH + USE DRYDEP_MOD, ONLY : DO_DRYDEP + USE EMISSIONS_MOD, ONLY : DO_EMISSIONS + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_BPCH, IU_DEBUG + USE FILE_MOD, ONLY : IU_ND48, IU_SMV2LOG + USE FILE_MOD, ONLY : CLOSE_FILES + USE GLOBAL_CH4_MOD, ONLY : INIT_GLOBAL_CH4, CH4_AVGTP + USE GCAP_READ_MOD, ONLY : GET_GCAP_FIELDS + USE GCAP_READ_MOD, ONLY : OPEN_GCAP_FIELDS + USE GCAP_READ_MOD, ONLY : UNZIP_GCAP_FIELDS + USE GWET_READ_MOD, ONLY : GET_GWET_FIELDS + USE GWET_READ_MOD, ONLY : OPEN_GWET_FIELDS + USE GWET_READ_MOD, ONLY : UNZIP_GWET_FIELDS + USE I6_READ_MOD, ONLY : GET_I6_FIELDS_1 + USE I6_READ_MOD, ONLY : GET_I6_FIELDS_2 + USE I6_READ_MOD, ONLY : OPEN_I6_FIELDS + USE I6_READ_MOD, ONLY : UNZIP_I6_FIELDS + USE INPUT_MOD, ONLY : READ_INPUT_FILE + USE LAI_MOD, ONLY : RDISOLAI + USE LIGHTNING_NOX_MOD, ONLY : LIGHTNING + USE LOGICAL_MOD, ONLY : LEMIS, LCHEM, LUNZIP, LDUST + USE LOGICAL_MOD, ONLY : LLIGHTNOX, LPRT, LSTDRUN, LSVGLB + USE LOGICAL_MOD, ONLY : LWAIT, LTRAN, LUPBD, LCONV + USE LOGICAL_MOD, ONLY : LWETD, LTURB, LDRYD, LMEGAN + USE LOGICAL_MOD, ONLY : LDYNOCEAN, LSOA, LVARTROP + USE LOGICAL_MOD, ONLY : LSULF + USE MEGAN_MOD, ONLY : INIT_MEGAN + USE MEGAN_MOD, ONLY : UPDATE_T_15_AVG + USE MEGAN_MOD, ONLY : UPDATE_T_DAY + USE PBL_MIX_MOD, ONLY : DO_PBL_MIX + USE OCEAN_MERCURY_MOD, ONLY : MAKE_OCEAN_Hg_RESTART + USE OCEAN_MERCURY_MOD, ONLY : READ_OCEAN_Hg_RESTART + USE PLANEFLIGHT_MOD, ONLY : PLANEFLIGHT + USE PLANEFLIGHT_MOD, ONLY : SETUP_PLANEFLIGHT + USE PRESSURE_MOD, ONLY : INIT_PRESSURE + USE PRESSURE_MOD, ONLY : SET_FLOATING_PRESSURE, get_pedge + USE TIME_MOD, ONLY : GET_NYMDb, GET_NHMSb + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_A3_TIME, GET_FIRST_A3_TIME + USE TIME_MOD, ONLY : GET_A6_TIME, GET_FIRST_A6_TIME + USE TIME_MOD, ONLY : GET_I6_TIME, GET_MONTH + USE TIME_MOD, ONLY : GET_TAU, GET_TAUb + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_TS_DYN + USE TIME_MOD, ONLY : GET_ELAPSED_SEC, GET_TIME_AHEAD + USE TIME_MOD, ONLY : GET_DAY_OF_YEAR, ITS_A_NEW_DAY + USE TIME_MOD, ONLY : ITS_A_NEW_SEASON, GET_SEASON + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH, GET_NDIAGTIME + USE TIME_MOD, ONLY : ITS_A_LEAPYEAR, GET_YEAR + USE TIME_MOD, ONLY : ITS_TIME_FOR_A3, ITS_TIME_FOR_A6 + USE TIME_MOD, ONLY : ITS_TIME_FOR_I6, ITS_TIME_FOR_CHEM + USE TIME_MOD, ONLY : ITS_TIME_FOR_CONV,ITS_TIME_FOR_DEL + USE TIME_MOD, ONLY : ITS_TIME_FOR_DIAG,ITS_TIME_FOR_DYN + USE TIME_MOD, ONLY : ITS_TIME_FOR_EMIS,ITS_TIME_FOR_EXIT + USE TIME_MOD, ONLY : ITS_TIME_FOR_UNIT,ITS_TIME_FOR_UNZIP + USE TIME_MOD, ONLY : ITS_TIME_FOR_BPCH + USE TIME_MOD, ONLY : SET_CT_CONV, SET_CT_DYN + USE TIME_MOD, ONLY : SET_CT_EMIS, SET_CT_CHEM + USE TIME_MOD, ONLY : SET_DIAGb, SET_DIAGe + USE TIME_MOD, ONLY : SET_CURRENT_TIME, PRINT_CURRENT_TIME + USE TIME_MOD, ONLY : SET_ELAPSED_MIN, SYSTEM_TIMESTAMP + USE TRACER_MOD, ONLY : CHECK_STT, N_TRACERS, STT, TCVV + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_A_H2HD_SIM + USE TRACER_MOD, ONLY : ITS_A_MERCURY_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGOX_SIM + USE TRANSPORT_MOD, ONLY : DO_TRANSPORT + USE TROPOPAUSE_MOD, ONLY : READ_TROPOPAUSE, CHECK_VAR_TROP + USE RESTART_MOD, ONLY : MAKE_RESTART_FILE, READ_RESTART_FILE + USE UPBDFLX_MOD, ONLY : DO_UPBDFLX, UPBDFLX_NOY + USE UVALBEDO_MOD, ONLY : READ_UVALBEDO + USE WETSCAV_MOD, ONLY : INIT_WETSCAV, DO_WETDEP + USE XTRA_READ_MOD, ONLY : GET_XTRA_FIELDS, OPEN_XTRA_FIELDS + USE XTRA_READ_MOD, ONLY : UNZIP_XTRA_FIELDS + USE ERROR_MOD, ONLY : IT_IS_NAN, IT_IS_FINITE !yxw + ! USE STATEMENTS FOR ADJOINT + USE CHECKPT_MOD, ONLY : CHK_PSC + USE CHECKPOINT_MOD, ONLY : READ_CONVECTION_CHKFILE + USE CHECKPOINT_MOD, ONLY : READ_PRESSURE_CHKFILE + USE DAO_MOD, ONLY : COPY_I6_FIELDS_ADJ + USE DAO_MOD, ONLY : INTERP_ADJ + USE ERROR_MOD, ONLY : ERROR_STOP + USE I6_READ_MOD, ONLY : OPEN_I6_FIELDS_ADJ + USE I6_READ_MOD, ONLY : GET_I6_FIELDS_1_ADJ + USE A6_READ_MOD, ONLY : OPEN_A6_FIELDS_ADJ + USE A3_READ_MOD, ONLY : OPEN_A3_FIELDS_ADJ + USE GWET_READ_MOD, ONLY : OPEN_GWET_FIELDS_ADJ + USE CHECKPOINT_MOD, ONLY : READ_CHEMISTRY_CHKFILE + USE GEOS_CHEM_MOD, ONLY : DISPLAY_MET + USE GEOS_CHEM_MOD, ONLY : NSECb + USE MEGAN_MOD, ONLY : UPDATE_T_DAY_ADJ + USE MEGAN_MOD, ONLY : UPDATE_T_15_AVG_ADJ + USE TIME_MOD, ONLY : GET_ELAPSED_MIN + USE TIME_MOD, ONLY : SET_ELAPSED_MIN_ADJ + USE TIME_MOD, ONLY : ITS_TIME_FOR_EXIT_ADJ + USE TIME_MOD, ONLY : ITS_A_NEW_DAY_ADJ + USE TIME_MOD, ONLY : ITS_TIME_FOR_A3_ADJ + USE TIME_MOD, ONLY : ITS_TIME_FOR_A6_ADJ + USE TIME_MOD, ONLY : ITS_TIME_FOR_I6_ADJ + USE TIME_MOD, ONLY : GET_I6_TIME_ADJ + USE TIME_MOD, ONLY : GET_A6_TIME_ADJ + USE TIME_MOD, ONLY : GET_A3_TIME_ADJ + USE TIME_MOD, ONLY : GET_TIME_BEHIND_ADJ + USE TRACER_MOD, ONLY : ITS_A_CO2_SIM + USE TRANSPORT_MOD, ONLY : DO_TRANSPORT_ADJ + ! To save CSPEC_FULL restart (dkh, 02/12/09) + USE LOGICAL_MOD, ONLY : LSVCSPEC + USE RESTART_MOD, ONLY : MAKE_CSPEC_FILE + + !!! geos-fp (lzh, 07/10/2014) + USE TIME_MOD, ONLY : ITS_TIME_FOR_A1 + USE TIME_MOD, ONLY : ITS_TIME_FOR_A1_ADJ + USE TIME_MOD, ONLY : ITS_TIME_FOR_I3_ADJ + USE TIME_MOD, ONLY : GET_I3_TIME_ADJ + USE TIME_MOD, ONLY : GET_A1_TIME_ADJ + USE GEOSFP_READ_MOD + + ! adjoint specific modules (adj_group, 6/09/09) + USE ADJ_ARRAYS_MOD, ONLY : DAY_OF_SIM, DAYS + USE ADJ_ARRAYS_MOD, ONLY : ITS_TIME_FOR_OBS + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : CHECK_STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : CHECK_STT_05x0666_ADJ + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE TIME_MOD, ONLY : SET_DIRECTION + USE CHEMISTRY_ADJ_MOD, ONLY : DO_CHEMISTRY_ADJ + USE CHECKPT_MOD, ONLY : MAKE_ADJ_FILE + USE CONVECTION_ADJ_MOD,ONLY : DO_CONVECTION_ADJ + USE EMISSIONS_ADJ_MOD, ONLY : DO_EMISSIONS_ADJ + USE LOGICAL_ADJ_MOD, ONLY : LADJ_TRAJ, LADJ_CHEM + USE LOGICAL_ADJ_MOD, ONLY : LAPSRC + USE LOGICAL_ADJ_MOD, ONLY : LSENS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE PBL_MIX_ADJ_MOD, ONLY : DO_PBL_MIX_ADJ + USE UPBDFLX_ADJ_MOD, ONLY : UPBDFLX_NOY_ADJ + USE UPBDFLX_ADJ_MOD, ONLY : DO_UPBDFLX_ADJ + USE WETSCAV_ADJ_MOD, ONLY : INIT_WETSCAV_ADJ + USE WETSCAV_ADJ_MOD, ONLY : ADJ_INIT_WETSCAV + USE WETSCAV_ADJ_MOD, ONLY : DO_WETDEP_ADJ + + ! dkh debug + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD, ICSFD + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ + USE DRYDEP_MOD, ONLY : DEPSAV + + ! mkeller: weak constraint + + USE WEAK_CONSTRAINT_MOD, ONLY : READ_FORCE_U_FILE + USE WEAK_CONSTRAINT_MOD, ONLY : FORCE_U_FULLGRID + USE WEAK_CONSTRAINT_MOD, ONLY : DO_WEAK_CONSTRAINT + USE WEAK_CONSTRAINT_MOD, ONLY : ITS_TIME_FOR_U + USE WEAK_CONSTRAINT_MOD, ONLY : SET_CT_U + USE WEAK_CONSTRAINT_MOD, ONLY : SET_CT_MAIN_U + USE WEAK_CONSTRAINT_MOD, ONLY : CT_SUB_U + USE WEAK_CONSTRAINT_MOD, ONLY : CT_MAIN_U + USE WEAK_CONSTRAINT_MOD, ONLY : CALC_GRADNT_U + + ! Force all variables to be declared explicitly +! IMPLICIT NONE +! +! ! Header files +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_DIAG" ! Diagnostic switches, NJDAY +!# include "CMN_GCTM" ! Physical constants +!# include "define_adj.h" ! Obs operators + + ! Local variables + LOGICAL :: FIRST = .TRUE. + LOGICAL :: LXTRA + INTEGER :: I, IOS, J, K, L + INTEGER :: N, JDAY, NDIAGTIME, N_DYN + !---------------------------------------------------------------------- + ! BUG FIX: now use value of NSECb from geos_chem_mod.f (dkh, 01/25/10) + !INTEGER :: N_DYN_STEPS, NSECb, N_STEP, DATE(2) + INTEGER :: N_DYN_STEPS, N_STEP, DATE(2) + !---------------------------------------------------------------------- + INTEGER :: YEAR, MONTH, DAY, DAY_OF_YEAR + INTEGER :: SEASON, NYMD, NYMDb, NHMS + INTEGER :: ELAPSED_SEC, NHMSb + REAL*8 :: TAU, TAUb + CHARACTER(LEN=255) :: ZTYPE + + ! (dkh, ks, mak, cs 06/12/09) + INTEGER :: FINAL_ELAPSED_MIN + INTEGER :: MIN_ADJ + INTEGER :: NSECb_ADJ + INTEGER :: I62_DATE(2) + INTEGER :: BEHIND_DATE(2) + +! CONTAINS +! +! SUBROUTINE DO_GEOS_CHEM_ADJ + + INTEGER, SAVE :: LOCAL_DAY + + ! mkeller: logical variable to initialize weak constraint 4D-Var + LOGICAL :: FIRST_WEAK + + !================================================================= + ! GEOS-CHEM-ADJ starts here! + !================================================================= + + !================================================================= + ! ***** I N I T I A L I Z A T I O N ***** + !================================================================= + + !---------------------------------------------------------------------- + ! BUG FIXED: now reference NSECb from geos_chem_mod. (dkh, 01/25/10) + ! old code: + !! Scary but true -- take this out and NSECb will be corrupt + !! Need to find the memory leak somewhere? (dkh, 11/07/09) + !print*, ' NSECb adj = ', NSECb + !---------------------------------------------------------------------- + + ! mkeller + FIRST_WEAK = .TRUE. + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'B A C K W A R D I N T E G R A T I O N' + + ! Now set DIRECTION to -1 to indicate that it's adjoint integration + CALL SET_DIRECTION( -1 ) + + ! Initialize allocatable arrays + !CALL INIT_ADJOINT + !CALL INIT_ADJ_ANTHROEMS + + ! Move these to fwd model to facilitate forcing calculation therein + !CALL INIT_CF_REGION + ! + !!fp + !IF (LADJ_FDEP) THEN + ! CALL INIT_UNITS_DEP + !ENDIF + + + ! Open BACKWD_met file + CALL DISPLAY_MET(165,0) + + ! Define time variables for use below + NHMS = GET_NHMS() + NYMD = GET_NYMD() + TAU = GET_TAU() + + ! Check for NaN, Negatives, Infinities in STT_ADJ once per hour + IF ( ITS_TIME_FOR_DIAG() ) THEN + + ! Sometimes STT in the stratosphere can be negative at + ! the nested-grid domain edges. Force them to be zero before + ! CHECK_STT (yxw) +#if defined( GEOS_5 ) && defined( GRID05x0666 ) + CALL CHECK_STT_05x0666_ADJ( 'End of Dynamic Loop' ) +#endif + + CALL CHECK_STT_ADJ( 'End of Dynamic Loop' ) + ENDIF + + ! BUG FIX: need to reset EMS_SF_ADJ so that gradients do not + ! accumulate from one iteration to the next. (zj, dkh, 07/30/10) + IF ( LADJ_EMS ) EMS_SF_ADJ = 0D0 + + ! for new strat. chem. (hml, 08/09/11, adj32_025) + IF ( LADJ_STRAT ) THEN + PROD_SF_ADJ = 0D0 + LOSS_SF_ADJ = 0D0 + ENDIF + + ! for rrate sensitivity (hml, 06/08/13) + IF ( LADJ_RRATE ) RATE_SF_ADJ = 0D0 + + !================================================================= + ! ***** 6 - H O U R T I M E S T E P L O O P ***** + !================================================================= + + ! Echo message before first timestep + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) REPEAT( '*', 44 ) + WRITE( 6, '(a)' ) '* B e g i n T i m e S t e p p i n g !! *' + WRITE( 6, '(a)' ) REPEAT( '*', 44 ) + WRITE( 6, '(a)' ) + + ! NSTEP is the number of dynamic timesteps w/in a 6-h interval + ! N_DYN_STEPS = 360 / GET_TS_DYN() + ! now with geos-fp (lzh, 07/10/2014) +#if defined( GEOS_FP ) + N_DYN_STEPS = 180 / GET_TS_DYN() ! GEOS-5.7.x has a 3-hr interval +#else + N_DYN_STEPS = 360 / GET_TS_DYN() ! All other met has a 6hr interval +#endif + + FINAL_ELAPSED_MIN = GET_ELAPSED_MIN() + + ! Start a new 6-h loop + DO + + ! Get dynamic timestep in seconds + N_DYN = 60d0 * GET_TS_DYN() + + ! Compute time parameters at start of 6-h loop + CALL SET_CURRENT_TIME + + !================================================================= + ! ***** D Y N A M I C T I M E S T E P L O O P ***** + !================================================================= + DO MIN_ADJ = FINAL_ELAPSED_MIN - GET_TS_DYN(), 0, - GET_TS_DYN() + + ! mak debug + WRITE(6,*)'start of adj time step' + WRITE(6,*)'MIN/MAX OF STT_ADJ:',minval(stt_adj),maxval(stt_adj) + + CALL SET_ELAPSED_MIN_ADJ + + ! Compute & print time quantities at start of dyn step + CALL SET_CURRENT_TIME + + ! Set time variables for dynamic loop + !DAY = GET_DAY() + DAY_OF_YEAR = GET_DAY_OF_YEAR() + ELAPSED_SEC = GET_ELAPSED_SEC() + MONTH = GET_MONTH() + NHMS = GET_NHMS() + NYMD = GET_NYMD() + TAU = GET_TAU() + YEAR = GET_YEAR() + SEASON = GET_SEASON() + + !CALL MAKE_ADJOINT_CHKFILE( NYMD, NHMS, TAU ) + + ! Get info from the perturbed forward run + CALL LOAD_CHECKPT_DATA( NYMD, NHMS ) + + ! mkeller: weak constraint stuff + IF(DO_WEAK_CONSTRAINT) THEN + + IF( .NOT. FIRST_WEAK) THEN + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) + CALL CALC_GRADNT_U(GET_NYMD(), GET_NHMS()) + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) + ENDIF + + ENDIF + + !============================================================ + ! ***** R E A D M E T F I E L D S ***** + !============================================================ + ! If it is the first time through, we will use i6 field from the + ! forward calculation, and all we need to do is set NSECb_ADJ + IF ( FIRST ) THEN + + ! This only happens if stop time is a 6h interval, in which + ! case NSECb gets advanced 6hrs beyond what it actually was + ! last used as, so set it back here. +! IF ( NSECb > GET_ELAPSED_SEC() ) THEN +! NSECb = NSECb - 6 * 3600 +! WRITE(6,*) ' -- Pushing NSECb back by 6h ' +! ENDIF + ! now with geos-fp (lzh, 04/29/2014) +#if defined ( GEOS_FP ) + IF ( NSECb > GET_ELAPSED_SEC() ) THEN + NSECb = NSECb - 3 * 3600 + WRITE(6,*) ' -- Pushing NSECb back by 3h ' + ENDIF +#else + IF ( NSECb > GET_ELAPSED_SEC() ) THEN + NSECb = NSECb - 6 * 3600 + WRITE(6,*) ' -- Pushing NSECb back by 6h ' + ENDIF +#endif + + NSECb_ADJ = NSECb + + ! Instead of this, now keep the currently loaded I-6 met + ! arrays that don't get interpolated (ie SLP) as _TMP. + ! They will come into rotation when COPY_I6_FIELDS_ADJ + ! is called. (dkh, 06/17/09) +! ! GET SLP1 and TROPP1 at the beginning of the last I-6 interval +! I62_DATE = GET_TIME_BEHIND_ADJ( +! & ( GET_ELAPSED_SEC() - NSECb ) / 60 ) +! +! +! CALL OPEN_I6_FIELDS_ADJ( I62_DATE(1), I62_DATE(2) ) +! CALL GET_I6_FIELDS_2( I62_DATE(1), I62_DATE(2) ) + + +! ! Now we don't reset this until after reading daily data + !FIRST = .FALSE. + ENDIF + + !============================================================== + ! ***** R E A D I - 6 F I E L D S ***** + !============================================================== +!!! geos-fp (lzh, 07/10/2014) +#if defined( GEOS_FP ) + IF ( ITS_TIME_FOR_I3_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR I-3 ' + + !================================================================= + ! ***** C O P Y I - 3 F I E L D S ***** + ! + ! The I-6 fields at the beginning of the next ( forward ) + ! timestep become the fields at the end of this timestep + !================================================================= + CALL COPY_I6_FIELDS_ADJ + + ! Get the date/time for the previous I-6 data block + BEHIND_DATE = GET_I3_TIME_ADJ() + + ! Open and read files + CALL GEOSFP_READ_I3_1( BEHIND_DATE(1), BEHIND_DATE(2) ) +! CALL OPEN_I6_FIELDS_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) +! CALL GET_I6_FIELDS_1_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) + PRINT*,'I3 DATE = ',BEHIND_DATE(1),BEHIND_DATE(2) + + ! Compute avg pressure at polar caps (for ADJ argument is PS1, not PS2) + CALL AVGPOLE( PS1 ) + + ! Set NSECb_ADJ to be used for the interpolation + ! where NSECb_ADJ is the total elapsed time in seconds at the + ! beginning of the current 6h time step which contains ELAPSED_MIN + NSECb_ADJ = ( MIN_ADJ + GET_TS_DYN() ) * 60 - 3 * 3600 + ENDIF +#else + + IF ( ITS_TIME_FOR_I6_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR I-6 ' + + !================================================================= + ! ***** C O P Y I - 6 F I E L D S ***** + ! + ! The I-6 fields at the beginning of the next ( forward ) + ! timestep become the fields at the end of this timestep + !================================================================= + CALL COPY_I6_FIELDS_ADJ + + ! Get the date/time for the previous I-6 data block + BEHIND_DATE = GET_I6_TIME_ADJ() + + ! Open and read files + CALL OPEN_I6_FIELDS_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) + CALL GET_I6_FIELDS_1_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) + PRINT*,'I6 DATE = ',BEHIND_DATE(1),BEHIND_DATE(2) + + ! Compute avg pressure at polar caps (for ADJ argument is PS1, not PS2) + CALL AVGPOLE( PS1 ) + + ! Set NSECb_ADJ to be used for the interpolation + ! where NSECb_ADJ is the total elapsed time in seconds at the + ! beginning of the current 6h time step which contains ELAPSED_MIN + NSECb_ADJ = ( MIN_ADJ + GET_TS_DYN() ) * 60 - 6 * 3600 + + ENDIF + +! (lzh, 07/10/2014) geos-fp +#endif + + !============================================================== + ! ***** R E A D A - 6 F I E L D S ***** + !============================================================== +! (lzh, 07/10/2014) geos-fp +#if defined( GEOS_FP ) + IF ( ITS_TIME_FOR_A3_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR A-3 ' + + ! Get the date/time for the previous A-3 data block + BEHIND_DATE = GET_A3_TIME_ADJ() + + ! Open and read files + CALL GEOSFP_READ_A3( BEHIND_DATE(1), BEHIND_DATE(2) ) + + ENDIF +#else + + IF ( ITS_TIME_FOR_A6_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR A-6 ' + + ! Get the date/time for the previous A-6 data block + BEHIND_DATE = GET_A6_TIME_ADJ() + + ! Open and read files + CALL OPEN_A6_FIELDS_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) + CALL GET_A6_FIELDS( BEHIND_DATE(1), BEHIND_DATE(2) ) + + ENDIF +#endif + + !============================================================== + ! ***** R E A D A - 3 F I E L D S ***** + !============================================================== +! (lzh, 07/10/2014) geos-fp +#if defined( GEOS_FP ) + IF ( ITS_TIME_FOR_A1_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR A-1 ' + + ! Get the date/time for the previous A-1 data block + BEHIND_DATE = GET_A1_TIME_ADJ() + + ! Open & read A-3 fields + CALL GEOSFP_READ_A1( BEHIND_DATE(1), BEHIND_DATE(2) ) +! CALL OPEN_A3_FIELDS_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) +! CALL GET_A3_FIELDS( BEHIND_DATE(1), BEHIND_DATE(2) ) + + ! Update daily mean temperature archive for MEGAN biogenics + ! For adjoint, read in checkpointed values (dkh, 01/23/10) + IF ( LMEGAN ) CALL UPDATE_T_DAY_ADJ + ENDIF +#else + IF ( ITS_TIME_FOR_A3_ADJ() ) THEN + + WRITE(6,*) ' ADJ: TIME FOR A-3 ' + + ! Get the date/time for the previous A-3 data block + BEHIND_DATE = GET_A3_TIME_ADJ() + + ! Open & read A-3 fields + CALL OPEN_A3_FIELDS_ADJ( BEHIND_DATE(1), BEHIND_DATE(2) ) + CALL GET_A3_FIELDS( BEHIND_DATE(1), BEHIND_DATE(2) ) + + ! Update daily mean temperature archive for MEGAN biogenics + ! For adjoint, read in checkpointed values (dkh, 01/23/10) + IF ( LMEGAN ) CALL UPDATE_T_DAY_ADJ + +#if defined( GEOS_3 ) + ! + IF ( LDUST ) THEN + CALL OPEN_GWET_FIELDS_ADJ( BEHIND_DATE(1), + & BEHIND_DATE(2) ) + CALL GET_GWET_FIELDS( BEHIND_DATE(1), BEHIND_DATE(2) ) + ENDIF +#endif + + ENDIF + +#endif + + !DAY_OF_SIM initialized to -1 in INIT_ADJ_ARRAYS + ! keeps tabs of day of simulation, going backward in time + ! this is handy for storing diagnostic files that have dimensions + ! (IIPAR,JJPAR,DAYS), where DAYS is number of days in simulation + ! (adj_group, 6/09/09) + ! bug fix: can't use ITS_A_NEW_DAY because it advances to the + ! next day when time is 00h + IF( DAY_OF_SIM == -1) THEN + + DAY_OF_SIM = DAYS + LOCAL_DAY = GET_DAY_OF_YEAR() + + PRINT*, 'TODAY IS', DAY_OF_SIM, 'th day of simulation' + + ELSEIF( LOCAL_DAY .ne. GET_DAY_OF_YEAR() ) THEN + + DAY_OF_SIM = DAY_OF_SIM - 1 + LOCAL_DAY = GET_DAY_OF_YEAR() + + PRINT*, 'TODAY IS',DAY_OF_SIM,'th day of simulation' + + ENDIF + + + !============================================================== + ! ***** M O N T H L Y O R S E A S O N A L D A T A ***** + !============================================================== + + ! UV albedoes + IF ( LCHEM .and. ITS_A_NEW_MONTH() ) THEN + CALL READ_UVALBEDO( MONTH ) + ENDIF + + ! Fossil fuel emissions (SMVGEAR) + ! THIS IS IN THE FORWARD DRIVER, but NOT IN THE GCV7 ADJ? + ! (dkh, 06/08/09) + IF ( ITS_A_FULLCHEM_SIM() .or. ITS_A_TAGCO_SIM() ) THEN + IF ( LADJ_EMS .and. ITS_A_NEW_SEASON() ) THEN + CALL ANTHROEMS( SEASON ) + ENDIF + ENDIF + + + !============================================================== + ! ***** D A I L Y D A T A ***** + ! + ! RDLAI returns today's leaf-area index + ! RDSOIL returns today's soil type information + !============================================================== + ! Read daily data at 11:30 p.m. on any new day, not counting the + ! "first" day of the adjoint integration, during which we can + ! still use values from the forward integration. + ! OLD: + !IF ( GET_NHMS() == 233000 .AND. ( .not. FIRST ) ) THEN + ! NEW: make more generic + !IF ( ( GET_NHMS() == 240000 - ( GET_TS_DYN() * 100d0 ) ) + ! NEWER: correctly make more generic (dkh, 10/26/09) + !IF ( ( GET_NHMS() == 236000 - ( GET_TS_DYN() * 100d0 ) ) +! & .AND. ( .not. FIRST ) ) THEN + ! Even NEWER: Now use ITS_A_NEW_DAY_ADJ + IF ( ITS_A_NEW_DAY_ADJ() ) THEN + + ! Now we checkpt XYLAI (dkh, 10/14/09) + !! Read leaf-area index (needed for drydep) + !CALL RDLAI( DAY_OF_YEAR, MONTH ) + + ! For MEGAN biogenics ... + IF ( LMEGAN ) THEN + + ! Read AVHRR daily leaf-area-index + CALL RDISOLAI( GET_DAY_OF_YEAR(), GET_MONTH() ) + + ! Compute 15-day average temperature for MEGAN + ! This will need to be checkpointed or + ! recalculated correctly (dkh, 06/08/09) + ! Now we read in the checkpointed values. + CALL UPDATE_T_15_AVG_ADJ + + ENDIF + + ! Also read soil-type info for fullchem simulation + ! OLD: + !IF ( ITS_A_FULLCHEM_SIM() ) CALL RDSOIL + ! NEW: for v8-02-1 + IF ( ITS_A_FULLCHEM_SIM() .or. ITS_A_H2HD_SIM() ) THEN + CALL RDSOIL + ENDIF + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG ( '### GEOS_CHEM_ADJ: a DAILY DATA' ) + ENDIF + + ENDIF + + ! Reset first-time flag + IF ( FIRST ) FIRST = .FALSE. + + !============================================================== + ! ***** I N T E R P O L A T E Q U A N T I T I E S ***** + ! + ! Interpolate I-6 fields to current dynamic timestep, + ! based on their values at NSEC and NSEC+NTDT + !============================================================== + +#if defined ( GEOS_3 ) + CALL INTERP( NSECb_ADJ, GET_ELAPSED_SEC(), N_DYN ) +#else + IF ( LTRAN ) THEN + CALL INTERP_ADJ( NSECb_ADJ, GET_ELAPSED_SEC(), N_DYN ) + ELSE + CALL INTERP( NSECb_ADJ, GET_ELAPSED_SEC(), N_DYN ) + ENDIF +#endif + + ! If we are not doing transport, then make sure that + ! the floating pressure is set to PSC2 (bdf, bmy, 8/22/02) + IF ( .not. LTRAN ) CALL SET_FLOATING_PRESSURE( PSC2 ) + + ! Compute airmass quantities at each grid box + CALL AIRQNT + + ! OLD: + !! (dkh, 11/07/05) + !! Compute the cosine of the solar zenith angle at each grid box + !CALL COSSZA( GET_DAY_OF_YEAR(), GET_NHMSb(), + ! GET_ELAPSED_SEC(), SUNCOS ) + ! + !! For SMVGEAR II, we also need to compute SUNCOS at + !! the end of this chemistry timestep (bdf, bmy, 4/1/03) + !IF ( LCHEM .and. ITS_A_FULLCHEM_SIM() ) THEN + ! CALL COSSZA( GET_DAY_OF_YEAR(), GET_NHMSb(), + ! GET_ELAPSED_SEC()+GET_TS_CHEM()*60, SUNCOSB ) + !ENDIF + ! NEW for v8-02-01 + ! Compute the cosine of the solar zenith angle array SUNCOS + ! NOTE: SUNCOSB is not really used in PHYSPROC (bmy, 2/13/07) + CALL COSSZA( DAY_OF_YEAR, SUNCOS ) + CALL COSSZA( DAY_OF_YEAR, SUNCOS_5hr, FIVE_HR=.TRUE. ) + + CALL DO_PBL_MIX( .FALSE. ) + + +#if defined( GEOS_3 ) + + ! 1998 GEOS-3 carries the ground temperature and not the air + ! temperature -- thus TS will be 2-3 K too high. As a quick fix, + ! copy the temperature at the first sigma level into TS. + ! (mje, bnd, bmy, 7/3/01) + ! OLD: + !IF ( YEAR == 1998 ) STOP + ! NEW: + IF ( YEAR == 1998 ) THEN + CALL ERROR_STOP( '1998 not supported GEOS-3', + & 'geos_chem_adj_mod.f' ) + ENDIF +#endif + + ! decrement elapsed time +! CALL SET_ELAPSED_MIN_ADJ +! +! CALL SET_CURRENT_TIME +! NHMS = GET_NHMS() +! NYMD = GET_NYMD() + + !============================================================== + ! ***** B E G I N A D J O I N T P R O C E S S E S ***** + ! This is where we start calling adjoint routines in the + ! reverse order of the forward model. + ! (dkh, ks, mak, cs 06/08/09) + !============================================================== + + !============================================================== + ! ***** U P D A T E C O S T F U N C T I O N ***** + !============================================================== + IF ( ITS_TIME_FOR_OBS( ) ) THEN + + ! Update cost function and calculate adjoint forcing + + ! for sensitivity calculations... + IF ( LSENS ) THEN + + CALL CALC_ADJ_FORCE_FOR_SENS + + ! ... for cost functions involving observations (real or pseudo) + ELSE + + CALL CALC_ADJ_FORCE_FOR_OBS + + ENDIF + ENDIF + + ! mkeller: weak constraint stuff + IF ( DO_WEAK_CONSTRAINT ) THEN + IF ( FIRST_WEAK ) THEN + + CALL SET_CT_U( FLIP=.TRUE. ) + + IF ( CT_SUB_U == 0 ) CALL SET_CT_MAIN_U(INCREASE=.FALSE.) + CALL SET_CT_U(INCREASE=.TRUE.) + + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) + + CALL CALC_GRADNT_U(GET_NYMD(), GET_NHMS()) + + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) + + ! first-time flag + FIRST_WEAK = .FALSE. + + ENDIF + ENDIF + + ! Initialize wet scavenging and wetdep fields after + ! the airmass quantities are reset after transport + !IF ( LCONV .or. LWETD ) CALL INIT_WETSCAV_ADJ + ! note: sulfate chemistry adjoint needs SO2s_ADJ and + ! H2O2s_ADJ to be allocated even if LCONV, LWETD = F. + IF ( LCONV .or. LWETD .or. ( LCHEM .and. LSULF ) ) THEN + CALL INIT_WETSCAV_ADJ + ENDIF + + !============================================================== + ! ***** W E T D E P O S I T I O N (rainout + washout) ***** + !============================================================== + IF ( LWETD .and. ITS_TIME_FOR_DYN() ) CALL DO_WETDEP_ADJ + + + !=============================================================== + ! Recalculate the emission and drydep rates here (dkh, 08/06/09) + !=============================================================== + !------------------------------- + ! Test for emission timestep + !------------------------------- + IF ( ITS_TIME_FOR_EMIS() ) THEN + + ! Increment emission counter + CALL SET_CT_EMIS( INCREMENT=.TRUE. ) + + !======================================================== + ! ***** D R Y D E P O S I T I O N ***** + !======================================================== + IF ( LDRYD .and. ( .not. ITS_A_H2HD_SIM() ) ) CALL DO_DRYDEP + + !======================================================== + ! ***** E M I S S I O N S ***** + ! ( only need to do this for fullchem ) + !======================================================== + IF ( LEMIS .and. ( ITS_A_FULLCHEM_SIM() .or. + & ITS_AN_AEROSOL_SIM() )) + & CALL DO_EMISSIONS + + ENDIF + + !=========================================================== + ! ***** C H E M I S T R Y ***** + !=========================================================== + + ! Also need to compute avg P, T for CH4 chemistry (bmy, 1/16/01) + ! fwd: + !IF ( ITS_A_CH4_SIM() ) CALL CH4_AVGTP + ! Now supported (kjw, dkh, 02/12/12, adj32_023) + !IF ( ITS_A_CH4_SIM() ) THEN + ! CALL ERROR_STOP( 'CH4_SIM not supported', 'geos_chem_adj') + !ENDIF + + ! Every chemistry timestep... + IF ( ITS_TIME_FOR_CHEM() ) THEN + + ! mak: try adj chemistry (6/20/09) + IF ( LCHEM .AND. LADJ_CHEM ) THEN + + ! Use dkh checkpt scheme (dkh, 06/12/09) + !CALL READ_CHEMISTRY_CHKFILE( NYMD, NHMS ) + + ! adj_group + IF ( LPRINTFD ) THEN + write(6,*) ' Before CHEMISTRY : = ', + & STT(IFD,JFD,LFD,:) + ENDIF + + + ! Call the appropriate chemistry routine + CALL DO_CHEMISTRY_ADJ + + END IF + + ENDIF + + !------------------------------- + ! Test for emission timestep + !------------------------------- + IF ( ITS_TIME_FOR_EMIS() .and. LADJ_EMS ) THEN + + !======================================================== + ! ***** E M I S S I O N S ***** + !======================================================== + + IF ( LEMIS ) CALL DO_EMISSIONS_ADJ + + ENDIF + + + !============================================================== + ! ***** U N I T C O N V E R S I O N ( J/kg -> J/[v/v] ) ***** + !============================================================== + IF ( ITS_TIME_FOR_UNIT() ) THEN + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG( '### GEOS_CHEM_ADJ: a CONVERT_UNITS:2' ) + ENDIF + + ENDIF + + !===================================================== + ! ***** CONVECTION ADJOINT ***** + !===================================================== + IF ( ITS_TIME_FOR_CONV() ) THEN + + !=========================================================== + ! ***** C L O U D C O N V E C T I O N ***** + !=========================================================== + IF ( LCONV ) THEN + + !-------------------------------------------------------------- + ! ***** CHECKPOINTING EVERY DYNAMIC TIME STEP ***** + !-------------------------------------------------------------- + + ! Use READ_CHK_CON_FILE (dkh, 06/14/09) + !CALL READ_CONVECTION_CHKFILE( NYMD, NHMS ) + + ! dkh debug (dkh, 09/07/09) + print*, ' before DO_CONVECTION_ADJ' + CALL CHECK_STT_ADJ( 'before DO_CONVECTION_ADJ' ) + + CALL DO_CONVECTION_ADJ + + ! dkh debug (dkh, 09/07/09) + print*, ' after DO_CONVECTION_ADJ' + CALL CHECK_STT_ADJ( 'After DO_CONVECTION_ADJ' ) + + ENDIF + + !=========================================================== + ! ***** M I X E D L A Y E R M I X I N G ***** + !=========================================================== + !IF ( LPRINTFD ) THEN + ! CALL DISPLAY_MET(165,3) + ! CALL DISPLAY_MET(165,5) + !ENDIF + + CALL DO_PBL_MIX_ADJ( LTURB ) + + !IF ( LPRINTFD ) THEN + ! CALL DISPLAY_MET(165,4) + !ENDIF + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG( '### GEOS_CHEM_ADJ: a PBL_MIX_ADJ:1' ) + ENDIF + + + ENDIF + + !===================================================== + ! ***** TRANSPORT ADJOINT ***** + !===================================================== + + IF ( ITS_TIME_FOR_DYN() ) THEN + + + !IF( LTRAN ) THEN + ! CALL READ_PRESSURE_CHKFILE( NYMD, NHMS ) + ! CALL SET_FLOATING_PRESSURE( TMP_PRESS(:,:) ) + !ENDIF + + IF ( LCONV .or. LWETD .or. ( LCHEM .and. LSULF ) ) THEN + CALL ADJ_INIT_WETSCAV + ENDIF + + IF ( LPRINTFD ) THEN + CALL DISPLAY_MET( 165 , 1 ) + ENDIF + + !-------------------------------------------------------------- + ! BUG FIX: apply an additional unit conversion to + ! go from discrete to continuous adjointg (jkoo, dkh, 02/14/11) + ! OLD: + !IF ( LTRAN ) CALL DO_TRANSPORT_ADJ + ! NEW: + IF ( LTRAN ) THEN + + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) + + CALL DO_TRANSPORT_ADJ + + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) + + ENDIF + !-------------------------------------------------------------- + + ! Reset air mass quantities + CALL AIRQNT + + IF ( LPRINTFD ) THEN + CALL DISPLAY_MET( 165 , 2 ) + ENDIF + + + ! Replace with strat chem (hml, dkh, 02/27/12, adj32_025) + !! Repartition [NOy] species after transport + !IF ( LUPBD .and. ITS_A_FULLCHEM_SIM() ) THEN + ! CALL UPBDFLX_NOY_ADJ( 1 ) + !ENDIF + +#if !defined( GEOS_5 ) && !defined( GEOS_FP ) + ! Get relative humidity + ! (after recomputing pressure quantities) + ! NOTE: for GEOS-5 we'll read this from disk instead + CALL MAKE_RH +#endif + + + ENDIF + + !============================================================== + ! ***** S T R A T O S P H E R I C F L U X E S ***** + !============================================================== + ! Replace with strat chem (hml, dkh, 02/27/12, adj32_025) + !IF ( LUPBD ) CALL DO_UPBDFLX_ADJ + + !============================================================== + ! ***** U N I T C O N V E R S I O N ( J/[v/v] -> J/kg ) ***** + !============================================================== + IF ( ITS_TIME_FOR_UNIT() ) THEN + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG( '### GEOS_CHEM_ADJ: a CONVERT_UNITS:1' ) + ENDIF + + ENDIF + + ! mkeller: weak constraint stuff + IF( DO_WEAK_CONSTRAINT ) CALL SET_CT_U(INCREASE=.TRUE.) + + ! Check for NaN, Negatives, Infinities in STT_ADJ once per hour + IF ( ITS_TIME_FOR_DIAG() ) THEN + + ! Sometimes STT in the stratosphere can be negative at + ! the nested-grid domain edges. Force them to be zero before + ! CHECK_STT (yxw) +#if defined( GEOS_5 ) && defined( GRID05x0666 ) + CALL CHECK_STT_05x0666_ADJ( 'End of Dynamic Loop' ) +#endif + + CALL CHECK_STT_ADJ( 'End of Dynamic Loop' ) + ENDIF + + ! dkh debug + print*, ' MIN / MAX STT_ADJ = ', + & MINVAL(STT_ADJ), MAXVAL(STT_ADJ) + print*, ' MIN / MAX loc = ', + & MINLOC(STT_ADJ), MAXLOC(STT_ADJ) + + ! Save adjoint values to *.adj.* file +! IF ( LADJ_TRAJ ) THEN + ! (lzh, 07/10/2014) save adj files every hour + IF ( LADJ_TRAJ .and. ( ITS_TIME_FOR_A1() ) ) THEN + CALL MAKE_ADJ_FILE( GET_NYMD(), GET_NHMS() ) + ENDIF + + !============================================================== + ! ***** T E S T F O R E N D O F R U N ***** + !============================================================== + IF ( ITS_TIME_FOR_EXIT_ADJ() ) GOTO 9999 + + ENDDO + + ENDDO + + !================================================================= + ! ***** C L E A N U P A N D Q U I T ***** + !================================================================= + 9999 CONTINUE + + !WRITE(141,*) f + + ! Get ICS_SF_ADJ from STT_ADJ (dkh, 07/23/06, mak, 6/19/09) + CALL RESCALE_ADJOINT + + ! Transform to ICS_SF_ADJ and EMS_SF_ADJ to log scaling if desired +#if defined ( LOG_OPT ) + CALL LOG_RESCALE_ADJOINT +#endif + +! Obsolete (zhej, dkh, 01/16/12, adj32_015) +! ! Set gradient in cushion as ZERO (zhe 11/28/10) +!#if defined( GRID05x0666 ) .and. defined (NESTED_CH) +! CALL NESTED_RESCALE_ADJOINT +!#endif + + ! dkh debug + print*, ' MIN / MAX ICS_SF_ADJ = ', + & MINVAL(ICS_SF_ADJ), MAXVAL(ICS_SF_ADJ) + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG( '### GEOS_CHEM_ADJ: a RESCALE' ) + ENDIF + + + ! dkh debug + print*, ' MIN / MAX STT = ', + & MINVAL(STT ), MAXVAL(STT ) + +! ! dkh debug +! print*, ' MIN / MAX ICS_SF_ADJ = ', +! & MINVAL(ICS_SF_ADJ), MAXVAL(ICS_SF_ADJ) + + + !============================================ + ! BACKGROUND COST AND GRADIENT UPDATE + ! + ! aka A PRIORI TERM CALCULATION + !============================================ + + ! Now we have separate subroutines for these (dkh, 02/09/11) + IF ( LAPSRC ) THEN + + IF ( ITS_A_FULLCHEM_SIM() .or. ITS_A_TAGCO_SIM() .or. + & ITS_A_CH4_SIM() ) THEN + CALL CALC_APRIORI + + ELSEIF ( ITS_A_CO2_SIM() ) THEN + + CALL CALC_APRIORI_CO2 + + ! (yhmao, dkh, 01/13/12, adj32_013) + ELSEIF (ITS_AN_AEROSOL_SIM()) THEN + + CALL CALC_APRIORI_BCOC + + ELSE + + CALL ERROR_STOP( 'APRIORI calc not defined', + & 'geos_chem_adj_mod' ) + + ENDIF + + PRINT*, 'Added (x-xa)T invSa (x-xa) to the cost func' + + ENDIF + + ! Print ending time of simulation + CALL DISPLAY_END_TIME + + ! Return to calling routine. + END SUBROUTINE DO_GEOS_CHEM_ADJ + +! Moved these routines to time_mod.f (dkh, 01/23/10) +!!------------------------------------------------------------------------------ +! +! FUNCTION ITS_TIME_FOR_I6_ADJ() RESULT( FLAG ) +!! +!!****************************************************************************** +!! Function ITS_TIME_FOR_I6_ADJ returns TRUE if it is time to read in I-6 +!! (instantaneous 6-h fields) and FALSE otherwise. This happens when TIME_ADJ is +!! at a 6h interval, which is equivalent to when ELAPSED_TIME+TS_DYN is at a +!! 6h interval. (dkh, 8/25/04) +!! +!! NOTES: +!! (1 ) Don't read in i6 fields when we are still within the last 6 h interval +!! from the forward simulation, in which case just use the i6 fields that +!! are already loaded. (dkh, 9/30/04) +!! (2 ) FIXED BUG: Use EXTRA so that NHMS + (TS_DYN) is divisible by 6 h +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_NHMS, GET_ELAPSED_SEC +! USE TIME_MOD, ONLY : GET_TS_DYN +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GEOS_CHEM_MOD, ONLY : NSECb +! +! ! Function value +! LOGICAL :: FLAG +! +! ! Local variable +! INTEGER :: EXTRA +! +! !================================================================= +! ! ITS_TIME_FOR_I6_ADJ begins here! +! !================================================================= +! IF ( GET_ELAPSED_SEC() >= NSECb ) THEN +! +! ! We can use I6 fields still loaded from forward run +! FLAG = .FALSE. +! +! ! Echo this fact to the screen +! WRITE(6,*) ' -- USE I6 FIELDS FROM FORWARD RUN ' +! +! ELSE +! +! ! EXTRA set so that current NHMS + 1 dynamic time step is +! ! divisible by 060000 +! ! Original, hardwired to 30 min dynamic time step +! !EXTRA = 7000 +! ! Qinbin's formula, assumes TS_DYN <= 60 min +! EXTRA = 4000 + GET_TS_DYN()*100 +! +! IF ( GET_TS_DYN() > 60 ) CALL ERROR_STOP( 'Invalid EXTRA!', +! & 'ITS_TIME_FOR_I6_ADJ (adjoint.f)' ) +! +! ! We read in I-6 fields at 00, 06, 12, 18 GMT +! FLAG = ( MOD( GET_NHMS() + EXTRA, 060000 ) == 0 ) +! +! ENDIF +! +! ! Return to calling program +! END FUNCTION ITS_TIME_FOR_I6_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_I6_TIME_ADJ( ) RESULT( BEHIND_DATE ) +!! +!!****************************************************************************** +!! Function GET_I6_TIME_ADJ returns the correct YYYYMMDD and HHMMSS values +!! that are needed to read in the previous instantaneous 6-hour (I-6) fields. +!! (dkh, 8/25/04) +!! +!! NOTES: +!! This is only called if ITS_TIME_FOR_I6_ADJ is true +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_TS_DYN +! +! ! Arguments +! INTEGER :: BEHIND_DATE(2) +! +! !================================================================= +! ! GET_I6_TIME_ADJ begins here! +! !================================================================= +! +! ! We need to read in the I-6 fields 6h (360 mins) behind of TIME_ADJ +! ! which is the same as 360 - TS_DYN behind ELAPSED_TIME +! BEHIND_DATE = GET_TIME_BEHIND_ADJ( 360 - GET_TS_DYN() ) +! +! ! Return to calling program +! END FUNCTION GET_I6_TIME_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION ITS_TIME_FOR_A6_ADJ() RESULT( FLAG ) +!! +!!****************************************************************************** +!! Function ITS_TIME_FOR_A6_ADJ returns TRUE if it is time to read in I-A +!! (average 6-h fields) and FALSE otherwise. This happens when TIME_ADJ is +!! at a 6h interval (03, 09, 15,21), which is equivalent to when +!! ELAPSED_TIME+TS_DYN is at a 6h interval. (dkh, 03/04/05) +!! +!! NOTES: +!! (1 ) Don't read in A6 fields when we are still within the last 6 h interval +!! from the forward simulation, in which case just use the A6 fields that +!! are already loaded. NSECb is the total elapsed seconds at the last fwd +!! I6 interval, so if we are more than 3 hr past this, can use A6 fields +!! from forward run. (dkh, 03/04/05) +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_NHMS, GET_ELAPSED_SEC +! USE TIME_MOD, ONLY : GET_TS_DYN +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GEOS_CHEM_MOD, ONLY : NSECb +! +! ! Function value +! LOGICAL :: FLAG +! +! ! Local variable +! INTEGER :: EXTRA +! INTEGER :: DATE(2) +! +! !================================================================= +! ! ITS_TIME_FOR_A6_ADJ begins here! +! !================================================================= +! +! IF ( GET_ELAPSED_SEC() >= NSECb + 3 * 3600 ) THEN +! +! ! We can use A6 fields still loaded from forward run +! FLAG = .FALSE. +! +! ! Echo this fact to the screen +! WRITE(6,*) ' -- USE A6 FIELDS FROM FORWARD RUN ' +! +! ELSE +! +!#if defined( GEOS_4 ) && defined( A_LLK_03 ) || defined ( GCAP ) +! +! ! For GEOS-4 "a_llk_03" data, we need to read A-6 fields when it +! ! is 00, 06, 12, 18 GMT. DATE is the current time -- test below. +! DATE = GET_TIME_AHEAD( 0 ) +! +!#else +! +! ! For GEOS-1, GEOS-S, GEOS-3, and GEOS-4 "a_llk_04" data, +! ! we need to read A-6 fields when it is 03, 09, 15, 21 GMT. +! ! DATE is the time 3 before now -- test below. +! DATE = GET_TIME_BEHIND_ADJ( 180 ) +! +!#endif +! ! EXTRA set so that current NHMS + 1 dynamic time step is +! ! divisible by 060000 +! ! Original formula, assumes dynamic time step is 30 min +! ! EXTRA = 7000 +! ! Qinbin's formula, assumes dynamic time step <= 60 +! EXTRA = 4000 + GET_TS_DYN() * 100 +! +! IF ( GET_TS_DYN() > 60 ) CALL ERROR_STOP( 'Invalid EXTRA!', +! & 'ITS_TIME_FOR_A6_ADJ (adjoint.f)' ) +! +! ! We read in A-6 fields at 03, 09, 15, 21 GMT +! FLAG = ( MOD( DATE(2) + EXTRA, 060000 ) == 0 ) +! +! ENDIF +! +! ! Return to calling program +! END FUNCTION ITS_TIME_FOR_A6_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_A6_TIME_ADJ( ) RESULT( BEHIND_DATE ) +!! +!!****************************************************************************** +!! Function GET_A6_TIME_ADJ returns the correct YYYYMMDD and HHMMSS values +!! that are needed to read in the previous average 6-hour (A-6) fields. +!! (dkh, 03/04/05) +!! +!! NOTES: +!! (1 ) This is only called if ITS_TIME_FOR_A6_ADJ is true +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_TS_DYN +! +! ! Arguments +! INTEGER :: BEHIND_DATE(2) +! +! !================================================================= +! ! GET_A6_TIME_ADJ begins here! +! !================================================================= +! +! ! Return the time 3h (180m) before now, since there is a 3-hour +! ! offset between the actual time when the A-6 fields are read +! ! and the time that the A-6 fields are stamped with. Also apply +! ! offset of TS_DYN. +! BEHIND_DATE = GET_TIME_BEHIND_ADJ( 180 - GET_TS_DYN() ) +! !BEHIND_DATE = GET_TIME_BEHIND_ADJ( - TS_DYN ) +! +! ! Return to calling program +! END FUNCTION GET_A6_TIME_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION ITS_TIME_FOR_A3_ADJ() RESULT( FLAG ) +!! +!!****************************************************************************** +!! Function ITS_TIME_FOR_A3_ADJ returns TRUE if it is time to read in A-3 +!! (average 3-h fields) and FALSE otherwise. This happens when TIME_ADJ is +!! at a 3h interval, which is equivalent to when +!! ELAPSED_TIME+TS_DYN is at a 3h interval. (dkh, 03/04/05) +!! +!! NOTES: +!! (1 ) Don't read in 3 fields when we are still within the last 3 h interval +!! from the forward simulation, in which case just use the A3 fields that +!! are already loaded. NSECb is the total elapsed seconds at the last fwd +!! I6 interval, so if we are more than 3 hr past this, can use A3 fields +!! from forward run. (dkh, 03/04/05) +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_NHMS, GET_ELAPSED_SEC +! USE TIME_MOD, ONLY : GET_TS_DYN +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GEOS_CHEM_MOD, ONLY : NSECb +! +! ! Function value +! LOGICAL :: FLAG +! +! ! Local variable +! INTEGER :: EXTRA +! +! !================================================================= +! ! ITS_TIME_FOR_A3_ADJ begins here! +! !================================================================= +! +! IF ( GET_ELAPSED_SEC() >= NSECb + 3 * 3600 ) THEN +! !IF ( GET_ELAPSED_SEC() >= NSECb + 3 * 3600 + 30*60 ) THEN +! +! ! We can use A3 fields still loaded from forward run +! FLAG = .FALSE. +! +! ! Echo this fact to the screen +! WRITE(6,*) ' -- USE A3 FIELDS FROM FORWARD RUN ' +! +! ELSE +! ! EXTRA set so that current NHMS + 1 dynamic time step is +! ! divisible by 030000 +! ! Original formula, assumes dynamic time step is 30 min +! !EXTRA = 7000 +! ! Qinbin's formula, assumes dynamic time step <= 60 min +! EXTRA = 4000 + GET_TS_DYN() * 100 +! +! IF ( GET_TS_DYN() > 30 ) CALL ERROR_STOP( 'Invalid EXTRA!', +! & 'ITS_TIME_FOR_A3_ADJ (adjoint.f)' ) +! +! ! We read in A-3 every 3 hours +! FLAG = ( MOD( GET_NHMS() + EXTRA, 030000 ) == 0 ) +! +! ENDIF +! +! ! Return to calling program +! END FUNCTION ITS_TIME_FOR_A3_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_A3_TIME_ADJ( ) RESULT( BEHIND_DATE ) +!! +!!****************************************************************************** +!! Function GET_A3_TIME_ADJ returns the correct YYYYMMDD and HHMMSS values +!! that are needed to read in the previous average 3-hour (A-3) fields. +!! (dkh, 03/04/05) +!! +!! NOTES: +!! (1 ) This is only called if ITS_TIME_FOR_A3_ADJ is true +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TIME_MOD, ONLY : GET_TS_DYN +! +! ! Arguments +! INTEGER :: BEHIND_DATE(2) +! +! !================================================================= +! ! GET_A3_TIME_ADJ begins here! +! !================================================================= +! +!!#if defined( GEOS_4 ) +!#if defined( GEOS_4 ) || defined ( GEOS_5 ) +! +! ! For GEOS-4/fvDAS, the A-3 fields are timestamped by center time. +! ! Therefore, the difference between the actual time when the fields +! ! are read and the A-3 timestamp time is 90 minutes. +! BEHIND_DATE = GET_TIME_BEHIND_ADJ( 90 - GET_TS_DYN() ) +! +!#else +! +! ! For GEOS-1, GEOS-STRAT, GEOS-3, the A-3 fields are timestamped +! ! by ending time. Therefore, the difference between the actual time +! ! when the fields are read and the A-3 timestamp time is 180 minutes. +! !BEHIND_DATE = GET_TIME_BEHIND_ADJ( 180 - TS_DYN ) +! BEHIND_DATE = GET_TIME_BEHIND_ADJ( - GET_TS_DYN() ) +! +!#endif +! +! ! Return to calling program +! END FUNCTION GET_A3_TIME_ADJ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_TIME_BEHIND_ADJ( N_MINS ) RESULT( DATE ) +!! +!!****************************************************************************** +!! Function GET_TIME_BEHIND_ADJ returns to the calling program a 2-element vector +!! containing the YYYYMMDD and HHMMSS values at the current time minus N_MINS +!! minutes. (dkh, 8/25/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) N_MINS (INTEGER) : Minutes ahead of time to compute YYYYMMDD,HHMMSS +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! References to F90 modules +! USE TIME_MOD, ONLY : GET_JD, GET_NYMD, GET_NHMS +! USE JULDAY_MOD, ONLY : CALDATE +! +! ! Arguments +! INTEGER, INTENT(IN) :: N_MINS +! +! ! Local variables +! INTEGER :: DATE(2) +! REAL*8 :: JD +! +! !================================================================= +! ! GET_TIME_BEHIND_ADJ begins here! +! !================================================================= +! +! ! Astronomical Julian Date at current time - N_MINS +! JD = GET_JD( GET_NYMD(), GET_NHMS() ) - ( N_MINS / 1440d0 ) +! +! ! Call CALDATE to compute the current YYYYMMDD and HHMMSS +! CALL CALDATE( JD, DATE(1), DATE(2) ) +! +! ! Return to calling program +! END FUNCTION GET_TIME_BEHIND_ADJ +! +!----------------------------------------------------------------------------- + + SUBROUTINE DISPLAY_END_TIME + + !================================================================= + ! Internal subroutine DISPLAY_END_TIME prints the ending time of + ! the GEOS-CHEM simulation (bmy, 5/3/05) + !================================================================= + USE TIME_MOD, ONLY : SYSTEM_TIMESTAMP + + ! Local variables + CHARACTER(LEN=16) :: STAMP + + ! Print system time stamp + STAMP = SYSTEM_TIMESTAMP() + WRITE( 6, 100 ) STAMP + 100 FORMAT( /, '===> SIMULATION END TIME: ', a, ' <===', / ) + + ! Echo info + WRITE ( 6, 3000 ) + 3000 FORMAT + & ( /, '************** E N D O F A D J O I N T G E O S + & -- C H E M ', + & '**************' ) + + ! Return to MAIN program + END SUBROUTINE DISPLAY_END_TIME + +!------------------------------------------------------------------------------ + + SUBROUTINE MET_FIELD_DEBUG + + !================================================================= + ! Internal subroutine MET_FIELD_DEBUG prints out the maximum + ! and minimum, and sum of DAO met fields for debugging + !================================================================= + + ! References to F90 modules + USE DAO_MOD, ONLY : AD, AIRDEN, AIRVOL, ALBD1, ALBD2 + USE DAO_MOD, ONLY : ALBD, AVGW, BXHEIGHT, CLDFRC, CLDF + USE DAO_MOD, ONLY : CLDMAS, CLDTOPS, DELP + USE DAO_MOD, ONLY : DTRAIN, GWETTOP, HFLUX, HKBETA, HKETA + USE DAO_MOD, ONLY : LWI, MOISTQ, OPTD, OPTDEP, PBL + USE DAO_MOD, ONLY : PREACC, PRECON, PS1, PS2, PSC2 + USE DAO_MOD, ONLY : RADLWG, RADSWG, RH, SLP, SNOW + USE DAO_MOD, ONLY : SPHU1, SPHU2, SPHU, SUNCOS, SUNCOSB + USE DAO_MOD, ONLY : SUNCOS_5hr + USE DAO_MOD, ONLY : TMPU1, TMPU2, T, TROPP, TS + USE DAO_MOD, ONLY : TSKIN, U10M, USTAR, UWND1, UWND2 + USE DAO_MOD, ONLY : UWND, V10M, VWND1, VWND2, VWND + USE DAO_MOD, ONLY : Z0, ZMEU, ZMMD, ZMMU + +# include "CMN_SIZE" + + ! Local variables + INTEGER :: I, J, L, IJ + + !================================================================= + ! MET_FIELD_DEBUG begins here! + !================================================================= + + ! Define box to print out + I = 23 + J = 34 + L = 1 + IJ = ( ( J-1 ) * IIPAR ) + I + + !================================================================= + ! Print out met fields at (I,J,L) + !================================================================= + IF ( ALLOCATED( AD ) ) PRINT*, 'AD : ', AD(I,J,L) + IF ( ALLOCATED( AIRDEN ) ) PRINT*, 'AIRDEN : ', AIRDEN(L,I,J) + IF ( ALLOCATED( AIRVOL ) ) PRINT*, 'AIRVOL : ', AIRVOL(I,J,L) + IF ( ALLOCATED( ALBD1 ) ) PRINT*, 'ALBD1 : ', ALBD1(I,J) + IF ( ALLOCATED( ALBD2 ) ) PRINT*, 'ALBD2 : ', ALBD2(I,J) + IF ( ALLOCATED( ALBD ) ) PRINT*, 'ALBD : ', ALBD(I,J) + IF ( ALLOCATED( AVGW ) ) PRINT*, 'AVGW : ', AVGW(I,J,L) + IF ( ALLOCATED( BXHEIGHT ) ) PRINT*, 'BXHEIGHT: ', BXHEIGHT(I,J,L) + IF ( ALLOCATED( CLDFRC ) ) PRINT*, 'CLDFRC : ', CLDFRC(I,J) + IF ( ALLOCATED( CLDF ) ) PRINT*, 'CLDF : ', CLDF(L,I,J) + IF ( ALLOCATED( CLDMAS ) ) PRINT*, 'CLDMAS : ', CLDMAS(I,J,L) + IF ( ALLOCATED( CLDTOPS ) ) PRINT*, 'CLDTOPS : ', CLDTOPS(I,J) + IF ( ALLOCATED( DELP ) ) PRINT*, 'DELP : ', DELP(L,I,J) + IF ( ALLOCATED( DTRAIN ) ) PRINT*, 'DTRAIN : ', DTRAIN(I,J,L) + IF ( ALLOCATED( GWETTOP ) ) PRINT*, 'GWETTOP : ', GWETTOP(I,J) + IF ( ALLOCATED( HFLUX ) ) PRINT*, 'HFLUX : ', HFLUX(I,J) + IF ( ALLOCATED( HKBETA ) ) PRINT*, 'HKBETA : ', HKBETA(I,J,L) + IF ( ALLOCATED( HKETA ) ) PRINT*, 'HKETA : ', HKETA(I,J,L) + IF ( ALLOCATED( LWI ) ) PRINT*, 'LWI : ', LWI(I,J) + IF ( ALLOCATED( MOISTQ ) ) PRINT*, 'MOISTQ : ', MOISTQ(L,I,J) + IF ( ALLOCATED( OPTD ) ) PRINT*, 'OPTD : ', OPTD(L,I,J) + IF ( ALLOCATED( OPTDEP ) ) PRINT*, 'OPTDEP : ', OPTDEP(L,I,J) + IF ( ALLOCATED( PBL ) ) PRINT*, 'PBL : ', PBL(I,J) + IF ( ALLOCATED( PREACC ) ) PRINT*, 'PREACC : ', PREACC(I,J) + IF ( ALLOCATED( PRECON ) ) PRINT*, 'PRECON : ', PRECON(I,J) + IF ( ALLOCATED( PS1 ) ) PRINT*, 'PS1 : ', PS1(I,J) + IF ( ALLOCATED( PS2 ) ) PRINT*, 'PS2 : ', PS2(I,J) + IF ( ALLOCATED( PSC2 ) ) PRINT*, 'PSC2 : ', PSC2(I,J) + IF ( ALLOCATED( RADLWG ) ) PRINT*, 'RADLWG : ', RADLWG(I,J) + IF ( ALLOCATED( RADSWG ) ) PRINT*, 'RADSWG : ', RADSWG(I,J) + IF ( ALLOCATED( RH ) ) PRINT*, 'RH : ', RH(I,J,L) + IF ( ALLOCATED( SLP ) ) PRINT*, 'SLP : ', SLP(I,J) + IF ( ALLOCATED( SNOW ) ) PRINT*, 'SNOW : ', SNOW(I,J) + IF ( ALLOCATED( SPHU1 ) ) PRINT*, 'SPHU1 : ', SPHU1(I,J,L) + IF ( ALLOCATED( SPHU2 ) ) PRINT*, 'SPHU2 : ', SPHU2(I,J,L) + IF ( ALLOCATED( SPHU ) ) PRINT*, 'SPHU : ', SPHU(I,J,L) + IF ( ALLOCATED( SUNCOS ) ) PRINT*, 'SUNCOS : ', SUNCOS(IJ) + IF ( ALLOCATED( SUNCOS_5hr)) PRINT*, 'SUNCOS_5hr: ',SUNCOS_5hr(IJ) + IF ( ALLOCATED( SUNCOSB ) ) PRINT*, 'SUNCOSB : ', SUNCOSB(IJ) + IF ( ALLOCATED( TMPU1 ) ) PRINT*, 'TMPU1 : ', TMPU1(I,J,L) + IF ( ALLOCATED( TMPU2 ) ) PRINT*, 'TMPU2 : ', TMPU2(I,J,L) + IF ( ALLOCATED( T ) ) PRINT*, 'TMPU : ', T(I,J,L) + IF ( ALLOCATED( TROPP ) ) PRINT*, 'TROPP : ', TROPP(I,J) + IF ( ALLOCATED( TS ) ) PRINT*, 'TS : ', TS(I,J) + IF ( ALLOCATED( TSKIN ) ) PRINT*, 'TSKIN : ', TSKIN(I,J) + IF ( ALLOCATED( U10M ) ) PRINT*, 'U10M : ', U10M(I,J) + IF ( ALLOCATED( USTAR ) ) PRINT*, 'USTAR : ', USTAR(I,J) + IF ( ALLOCATED( UWND1 ) ) PRINT*, 'UWND1 : ', UWND1(I,J,L) + IF ( ALLOCATED( UWND2 ) ) PRINT*, 'UWND2 : ', UWND2(I,J,L) + IF ( ALLOCATED( UWND ) ) PRINT*, 'UWND : ', UWND(I,J,L) + IF ( ALLOCATED( V10M ) ) PRINT*, 'V10M : ', V10M(I,J) + IF ( ALLOCATED( VWND1 ) ) PRINT*, 'VWND1 : ', VWND1(I,J,L) + IF ( ALLOCATED( VWND2 ) ) PRINT*, 'VWND2 : ', VWND2(I,J,L) + IF ( ALLOCATED( VWND ) ) PRINT*, 'VWND : ', VWND(I,J,L) + IF ( ALLOCATED( Z0 ) ) PRINT*, 'Z0 : ', Z0(I,J) + IF ( ALLOCATED( ZMEU ) ) PRINT*, 'ZMEU : ', ZMEU(I,J,L) + IF ( ALLOCATED( ZMMD ) ) PRINT*, 'ZMMD : ', ZMMD(I,J,L) + IF ( ALLOCATED( ZMMU ) ) PRINT*, 'ZMMU : ', ZMMU(I,J,L) + + ! Flush the output buffer + CALL FLUSH( 6 ) + + ! Return to MAIN program + END SUBROUTINE MET_FIELD_DEBUG + +!----------------------------------------------------------------------------- + + SUBROUTINE CALC_ADJ_FORCE_FOR_OBS ( ) +! +!****************************************************************************** +! Subroutine CALC_ADJ_FORCE_FOR_OBS calculates the cost function and its first +! derivative w.r.t. the dependent variables. (dkh, 9/01/04) +! +! NOTE: +! (1 ) This routine assumes that the first NOBS of RPOUT are the observations +! (2 ) Corrected the limitation in (1) by switching to OBS_STT and CHK_STT, +! both of which are same size, and indexed similarly to ADJ_STT, though +! they contain 3 more species than ADJ_STT. Make sure that CHK_STT and +! OBS_STT are in ug/m3, so that if WEIGHT is dimentionless, J has units +! of ug2/m6. (dkh, 03/03/05) +! (3 ) Now supports the LWSCALE option, where we can resale the weight matrix +! by 1 / OBS^2. (dkh, 03/24/05) +! (4 ) Now error check for exploding adjoints and NaN. (dkh, 03/24/05) +! (5 ) Now OBS_STT and CHK_STT in [kg/box] +! (6 ) Now include factor of 1/2 in cost function. (dkh, 07/24/06) +! (7 ) Get rid of LWSCALE. (dkh, 09/29/06) +! (8 ) Add UNITS option to evaluate cost function in a units of ug/m3 for +! sensitivity calculations. (dkh, 10/13/06) +! (9 ) Add support for NO2_SAT_OBS. (dkh, 11/08/06) +! (10) Addu suppprt for IMPROVE_OBS. (dkh, 11/21/06) +! (11) Add support for UNITS = 'ppb'. (dkh, 02/12/07) +! (12) Add support for CASTNET_OBS. (dkh, 04/24/07) +! (13) Add support for spatial/temporal average of O3 (cspec_ppb). (dkh, 11/20/07) +! (14) Add support for attainment functions calculated in ATTAINMENT_MOD. (dkh, 11/20/07) +! (15) Replace ATTAINMENT with PM_ATTAINMENT and O3_ATTAINMENT +! (16) Add support for TES_NH3_OBS. (dkh, 05/05/09) +! (17) Major updates, renaming, etc. (dkh, ks, mak, cs 06/08/09) +! (18) Add support for TES_O3_OBS. (dkh, 05/06/10) +! (19) Add support for GOSAT_CO2_OBS. (dkh, 11/18/10) +! (20) Add support for LMAX_OBS for PSEUDO_OBS. (dkh, 02/11/11) +! (21) Add support for MODIS_AOD_OBS (xxu, dkh, 01/09/12, adj32_011) +! (22) Now calculate a relative OBS_ERR for PSEUDO_OBS (nb, dkh, 08/02/12, adj33g) +! (23) Add support for OMI_SO2_OBS (ywang, 04/21/15) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ, ADJ_FORCE + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION + USE ADJ_ARRAYS_MOD, ONLY : OBS_STT + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE CHECKPT_MOD, ONLY : CHK_STT, READ_OBS_FILE + USE ERROR_MOD, ONLY : DEBUG_MSG, IT_IS_NAN, ERROR_STOP + USE ERROR_MOD, ONLY : IS_SAFE_DIV + USE DAO_MOD, ONLY : AIRVOL, AD + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS + USE TRACER_MOD, ONLY : N_TRACERS + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + +#if defined ( IMPROVE_SO4_NIT_OBS ) + USE IMPROVE_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS_STOP + USE IMPROVE_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS_START + USE IMPROVE_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS + USE IMPROVE_MOD, ONLY : CALC_IMPRV_FORCE, + & ADJ_RESET_AEROAVE, + & ADJ_UPDATE_AEROAVE +#endif + + ! (yhmao, dkh, 01/13/12, adj32_013) +#if defined ( IMPROVE_BC_OC_OBS ) + USE IMPROVE_BC_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS_STOP + USE IMPROVE_BC_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS_START + USE IMPROVE_BC_MOD, ONLY : ITS_TIME_FOR_IMPRV_OBS + USE IMPROVE_BC_MOD, ONLY : CALC_IMPRV_FORCE, + & ADJ_RESET_AEROAVE, + & ADJ_UPDATE_AEROAVE +#endif + + +#if defined ( PM_ATTAINMENT ) + USE ATTAINMENT_MOD, ONLY : ITS_TIME_FOR_AVE_STOP + USE ATTAINMENT_MOD, ONLY : ITS_TIME_FOR_AVE_START + USE ATTAINMENT_MOD, ONLY : ITS_TIME_FOR_AVE + USE ATTAINMENT_MOD, ONLY : CALC_AVE_FORCE, + & ADJ_RESET_AVE, + & ADJ_UPDATE_AVE +#endif + +#if defined ( CASTNET_NH4_OBS ) + USE CASTNET_MOD, ONLY : ITS_TIME_FOR_CAST_OBS_STOP + USE CASTNET_MOD, ONLY : ITS_TIME_FOR_CAST_OBS_STOP + USE CASTNET_MOD, ONLY : ITS_TIME_FOR_CAST_OBS_START + USE CASTNET_MOD, ONLY : ITS_TIME_FOR_CAST_OBS + USE CASTNET_MOD, ONLY : CALC_CAST_FORCE, + & ADJ_RESET_CASTCHK, + & ADJ_UPDATE_CASTCHK + USE CASTNET_MOD, ONLY : RESET_CAST_OBS_TO_FALSE +#endif + +#if defined (SCIA_KNMI_NO2_OBS) + USE READ_SCIANO2_MOD, ONLY : CALC_SCIANO2_FORCE +#endif + +! add OMI L3 SO2 (ywang, 04/21/15) +#if defined (OMI_SO2_OBS) + USE OMI_SO2_OBS_MOD, ONLY : CALC_OMI_SO2_FORCE +#endif + + USE TIME_MOD, ONLY : GET_LOCALTIME, GET_NYMD, GET_NHMS + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TRACERID_MOD + ! added (dkh, 10/25/07) + USE COMODE_MOD, ONLY : JLOP, CSPEC + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + +#if defined ( SOMO35_ATTAINMENT ) + USE O3_ATTAIN_MOD, ONLY : CALC_O3_FORCE +#endif + +#if defined(TES_NH3_OBS) + USE TES_NH3_MOD, ONLY : CALC_TES_NH3_FORCE +#endif + +#if defined(TES_O3_OBS) + USE TES_O3_MOD, ONLY : CALC_TES_O3_FORCE +#endif + +#if defined(TES_O3_IRK) + USE TES_O3_IRK_MOD, ONLY : CALC_TES_O3_IRK_FORCE +#endif + +#if defined(GOSAT_CO2_OBS) + USE GOSAT_CO2_MOD, ONLY : CALC_GOS_CO2_FORCE +#endif + +! Add MOPITT v5 (zhej, dkh, 01/16/12, adj32_016) +#if defined( MOPITT_v5_CO_OBS ) || defined ( MOPITT_V6_CO_OBS ) || defined ( MOPITT_V7_CO_OBS ) + USE MOPITT_OBS_MOD, ONLY : READ_MOPITT_FILE, + & ITS_TIME_FOR_MOPITT_OBS, + & CALC_MOPITT_FORCE +#endif + +!xzhang: IASI CO partial column observations +#if defined(IASI_CO_OBS) + USE IASI_CO_OBS_MOD, ONLY : CALC_IASI_CO_FORCE +#endif + +#if defined( SCIA_BRE_CO_OBS ) +!#if defined( GEOS_4 ) + USE SCIAbr_CO_OBS_MOD, ONLY : READ_SCIAbr_CO_FILE, + & ITS_TIME_FOR_SCIAbr_CO_OBS, + & CALC_SCIAbr_CO_FORCE + +#endif + +#if defined( AIRS_CO_OBS ) + USE AIRS_CO_OBS_MOD, ONLY : READ_AIRS_CO_FILES, + & ITS_TIME_FOR_AIRS_CO_OBS, + & CALC_AIRS_CO_FORCE +#endif + +#if defined( MODIS_AOD_OBS ) + USE MODIS_AOD_OBS_MOD, ONLY : CALC_MODIS_AOD_FORCE +#endif + +! add CH4 operators (kjw, dkh, 02/12/12, adj32_023) +#if defined(TES_CH4_OBS) + USE TES_CH4_MOD, ONLY : CALC_TES_CH4_FORCE +#endif +#if defined(MEM_CH4_OBS) + USE MEM_CH4_MOD, ONLY : CALC_MEM_CH4_FORCE +#endif +#if defined(SCIA_CH4_OBS) + USE SCIA_CH4_MOD, ONLY : CALC_SCIA_CH4_FORCE +#endif +#if defined(LEO_CH4_OBS) + USE LEO_CH4_MOD, ONLY : CALC_LEO_CH4_FORCE +#endif +#if defined(GEOCAPE_CH4_OBS) + USE GEOCAPE_CH4_MOD, ONLY : CALC_GEOCAPE_CH4_FORCE +#endif +#if defined(OSIRIS_OBS) + USE OSIRIS_OBS_MOD, ONLY : READ_OSIRIS_FILE, + & ITS_TIME_FOR_OSIRIS_OBS, + & CALC_OSIRIS_FORCE, + & CALC_GC_O3 +#endif +!xzhang: MLS O3 column observations + +#if defined(MLS_O3_OBS) + USE MLS_O3_OBS_MOD, ONLY : READ_MLS_O3_FILE, + & CALC_MLS_O3_FORCE +#endif +!xzhang: IASI O3 partial column observations +#if defined(IASI_O3_OBS) + USE IASI_O3_OBS_MOD, ONLY : CALC_IASI_O3_FORCE +#endif + +!xzhang: MLS HNO3 column observations + +#if defined(MLS_HNO3_OBS) + USE MLS_HNO3_OBS_MOD, ONLY : CALC_MLS_HNO3_FORCE + USE MLS_HNO3_OBS_MOD, ONLY : READ_MLS_HNO3_FILE +#endif + +!mkeller: OMI NO2 column observations +#if defined(OMI_NO2_OBS) + USE OMI_NO2_OBS_MOD, ONLY : CALC_OMI_NO2_FORCE +#endif + +!xzhang: OMI CH2O column observations + +#if defined(OMI_CH2O_OBS) + USE OMI_CH2O_OBS_MOD, ONLY : CALC_OMI_CH2O_FORCE +#endif + +!xzhang: OSIRIS NO2 column observations + +#if defined(OSIRIS_NO2_OBS) + USE OSIRIS_NO2_OBS_MOD, ONLY : CALC_OSIRIS_NO2_FORCE +#endif + + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! XNUMOL + ! added (dkh, 10/25/07) +# include "comode.h" ! IGAS, ITLOOP +# include "define_adj.h" ! obs operators + + ! Internal variables + REAL*8 :: DIFF + REAL*8 :: NEW_COST(IIPAR,JJPAR,LLPAR,N_TRACERS) + INTEGER :: I, J, L, N + INTEGER :: ADJ_EXPLD_COUNT + INTEGER, PARAMETER :: MAX_ALLOWED_EXPLD = 10 + REAL*8, PARAMETER :: MAX_ALLOWED_INCREASE = 10D10 + REAL*8 :: MAX_ADJ_TMP + REAL*8 :: TARGET_STT + REAL*8 :: FACTOR + REAL*8 :: CF_PRIOR + REAL*8 :: CF_TESNH3 + REAL*8 :: CF_TESO3, CF_IASIO3 + REAL*8 :: CF_GOSCO2 + REAL*8 :: CF_MODIS_AOD + REAL*8 :: CF_OMI_SO2 + REAL*8 :: CF_IMPRV + REAL*8 :: CF_TESCH4 + REAL*8 :: CF_SCIACH4 + REAL*8 :: CF_MEMCH4 + REAL*8 :: CF_GEOCAPECH4 + REAL*8 :: CF_LEOCH4 + REAL*8 :: CF_OSIRIS + REAL*8 :: CF_MOPITT, CF_IASICO + REAL*8 :: CF_OMINO2 + REAL*8 :: CF_OMICH2O + REAL*8 :: CF_MLSHNO3 + REAL*8 :: CF_OSIRISNO2 + REAL*8 :: OBS_ERR + REAL*8 :: MIN_MEAN_OBS + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER, SAVE :: OBS_COUNT = 0 + LOGICAL, SAVE :: SECOND = .TRUE. + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME +110 FORMAT(F18.6,1X) + + !================================================================ + ! CALC_ADJ_FORCE_FOR_OBS begins here! + !================================================================ + +! Not sure this is necessary to have ppc flags here. LMAX_OBS should suffice +!#if defined ( PSEUDO_OBS ) + ! implement a cap on total number of observations (dkh, 02/11/11) + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + 1 + IF ( OBS_COUNT > NSPAN ) RETURN + ENDIF +!#endif + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C A L C A D J F O R C E - O B S ' + + ! Some error checking stuff + MAX_ADJ_TMP = MAXVAL( STT_ADJ ) + ADJ_EXPLD_COUNT = 0 + + !================================================================ + ! NO2 from the SCIA instrument using the KNMI retrieval + !================================================================ +#if defined( SCIA_KNMI_NO2_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! Calculate cost and forcing from satellite NO2 observations + ! note: forcing applied directly to ADCSPEC vi ADJ_NO2_AFTER_CHEM + ! and ADJ_CSPEC_NO2. (dkh, 11/08/06) + CALL CALC_SCIANO2_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_SCIA = CF_SCIA + COST_FUNC - CF_PRIOR + +#endif + + + !================================================================ + ! Sulfate and nitrate filter measurements from the IMPROVE netwrk + !================================================================ +#if defined ( IMPROVE_SO4_NIT_OBS ) + + IF ( ITS_TIME_FOR_IMPRV_OBS_STOP( -1 ) ) THEN + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! just to be safe: + CALL ADJ_RESET_AEROAVE + + CALL CALC_IMPRV_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_IMPRV = CF_IMPRV + COST_FUNC - CF_PRIOR + + ENDIF + + IF ( ITS_TIME_FOR_IMPRV_OBS() ) THEN + + CALL ADJ_UPDATE_AEROAVE( STT_ADJ(:,:,1,IDADJNIT), + & STT_ADJ(:,:,1,IDADJSO4), + & STT_ADJ(:,:,1,IDADJNH4) ) + + ENDIF + + IF ( ITS_TIME_FOR_IMPRV_OBS_START( -1 ) ) THEN + + ! Reset + CALL ADJ_RESET_AEROAVE + + ENDIF +#endif + + !================================================================ + ! BC and OC measurements from the IMPROVE netwrk !yhmao + !================================================================ +#if defined ( IMPROVE_BC_OC_OBS ) + IF ( ITS_TIME_FOR_IMPRV_OBS_STOP( -1 ) ) THEN + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! just to be safe: + CALL ADJ_RESET_AEROAVE + + CALL CALC_IMPRV_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_IMPRV = CF_IMPRV + COST_FUNC - CF_PRIOR + + ENDIF + + IF ( ITS_TIME_FOR_IMPRV_OBS() ) THEN + + + CALL ADJ_UPDATE_AEROAVE( STT_ADJ(:,:,1,IDTBCPI), + & STT_ADJ(:,:,1,IDTBCPO)) + !& STT_ADJ(:,:,1,IDTOCPI), + ! & STT_ADJ(:,:,1,IDTOCPO)) + + ENDIF + + IF ( ITS_TIME_FOR_IMPRV_OBS_START( -1 ) ) THEN + + ! Reset + CALL ADJ_RESET_AEROAVE + + ENDIF +#endif + + !================================================================ + ! NH3 profiles from the TES instrument with the AER retrieval + !================================================================ +#if defined ( TES_NH3_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_TES_NH3_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_TESNH3 = CF_TESNH3 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! O3 profiles from the TES instrument + !================================================================ +#if defined ( TES_O3_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_teso3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 121, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_TES_O3_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_TESO3 = CF_TESO3 + COST_FUNC - CF_PRIOR + WRITE (121,110) (CF_TESO3) +#endif + + !=================================================================== + !xzhang: O3 columns from IASI + !=================================================================== + +#if defined ( IASI_O3_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_iasio3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 127, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + CF_PRIOR = COST_FUNC + + CALL CALC_IASI_O3_FORCE( COST_FUNC ) + CF_IASIO3 = CF_IASIO3 + COST_FUNC - CF_PRIOR + WRITE(127,110) (CF_IASIO3) +#endif + + !================================================================ + ! O3 radiative kernels from the TES instrument + !================================================================ +#if defined ( TES_O3_IRK ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_TES_O3_IRK_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_TESO3 = CF_TESO3 + COST_FUNC - CF_PRIOR + +#endif + + + !================================================================ + ! CH4 profiles from the TES instrument (kjw, 02/12/12, adj32_023) + !================================================================ +#if defined ( TES_CH4_OBS ) +! IF ( LTES_PSO .EQ. .TRUE. ) THEN + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_TES_CH4_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_TESCH4 = CF_TESCH4 + COST_FUNC - CF_PRIOR + +! ENDIF +#endif + + !================================================================ + ! CH4 profiles from the SCIA instrument (kjw, 02/12/12, adj32_023) + !================================================================ +#if defined ( SCIA_CH4_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_SCIA_CH4_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_SCIACH4 = CF_SCIACH4 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! CH4 profiles from theoretical new instrument + ! (kjw, 02/12/12, adj32_023) + !================================================================ +#if defined ( MEM_CH4_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_MEM_CH4_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_MEMCH4 = CF_MEMCH4 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! CH4 profiles from theoretical new instrument + ! (kjw, 02/12/12, adj32_023) + !================================================================ +#if defined ( LEO_CH4_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_LEO_CH4_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_LEOCH4 = CF_LEOCH4 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! CH4 profiles from theoretical new instrument + ! (kjw, 02/12/12, adj32_023) + !================================================================ +#if defined ( GEOCAPE_CH4_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_GEOCAPE_CH4_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_GEOCAPECH4 = CF_GEOCAPECH4 + COST_FUNC - CF_PRIOR + +#endif + + + !================================================================ + ! CO2 profiles from the GOSAT instrument + !================================================================ +#if defined ( GOSAT_CO2_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_GOS_CO2_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_GOSCO2 = CF_GOSCO2 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! Ammonium filter measurements from CASTNet + !================================================================ +#if defined ( CASTNET_NH4_OBS ) + + ! Reset the CAST OBS flag to FALSE the first time through + ! so that we don't try to calculate any adjoint forcing before + ! reading an observation file. + IF ( FIRST ) THEN + + COST_FUNC = 0D0 + + CALL RESET_CAST_OBS_TO_FALSE + + FIRST = .FALSE. + + ENDIF + + IF ( ITS_TIME_FOR_CAST_OBS_START( -1 ) ) THEN + + ! Reset + CALL ADJ_RESET_CASTCHK + + ENDIF + + IF ( ITS_TIME_FOR_CAST_OBS_STOP( -1 ) ) THEN + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! just to be safe: + CALL ADJ_RESET_CASTCHK + + CALL CALC_CAST_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_CAST = CF_CAST + COST_FUNC - CF_PRIOR + + ENDIF + + IF ( ITS_TIME_FOR_CAST_OBS() ) THEN + + CALL ADJ_UPDATE_CASTCHK( STT_ADJ(:,:,1,IDADJNH4) ) + + ENDIF + +#endif + + !================================================================ + ! SOMO35 O3 air quality index + !================================================================ +#if defined ( SOMO35_ATTAINMENT ) + + CALL CALC_O3_FORCE( COST_FUNC ) + +#endif + + !================================================================ + ! PM2.5 24 average threshold attainment + !================================================================ +#if defined ( PM_ATTAINMENT ) + + IF ( ITS_TIME_FOR_AVE_STOP( -1 ) ) THEN + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! just to be safe: + CALL ADJ_RESET_AVE + + CALL CALC_AVE_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_AVE = CF_AVE + COST_FUNC - CF_PRIOR + + ENDIF + + IF ( ITS_TIME_FOR_AVE() ) THEN + + CALL ADJ_UPDATE_AVE( ) + + ENDIF + +#endif + + !================================================================ + ! Ozone profiles from TES + !================================================================ +#if defined ( TES_O3_OBS ) + +#endif + + !================================================================ + ! NO2 columns from SCIA instrument using the Dalhousie retrieval + !================================================================ +#if defined ( SCIA_DAL_NO2_OBS ) + +#endif + + !================================================================ + ! OMI L3 SO2 + !================================================================ +#if defined ( OMI_SO2_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_OMI_SO2_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_OMI_SO2 = CF_OMI_SO2 + COST_FUNC - CF_PRIOR + +#endif + + !================================================================ + ! NDEP obs (e.g., NADP_OBS etc.) are called directly from + ! within DO_WETDEP_ADJ + !================================================================ + + !================================================================ + ! CO columns from the MOPITT instrument + ! Add v5 (zhej, dkh, 01/16/12, adj32_016) + !================================================================ +#if defined (MOPITT_V5_CO_OBS) || defined ( MOPITT_V6_CO_OBS ) || defined ( MOPITT_V7_CO_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_mop.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 122, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + CF_PRIOR = COST_FUNC + ! Read MOPITT file just before midnight of the day of obs + !if first then read obs file to get hour + IF ( GET_NHMS() .ge. 230000 ) THEN + PRINT*, 'about to read mopitt file' + CALL READ_MOPITT_FILE( GET_NYMD(), GET_NHMS() ) + ENDIF + + IF ( ITS_TIME_FOR_MOPITT_OBS() ) THEN + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'CALC ADJ FORCE MOPITT' + + CALL CALC_MOPITT_FORCE + CF_MOPITT = CF_MOPITT + COST_FUNC - CF_PRIOR + WRITE(122,110) (CF_MOPITT) + ENDIF + + +#endif + +!=================================================================== +!xzhang: CO partial columns from IASI +!=================================================================== + +#if defined ( IASI_CO_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_iasico.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 128, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + CF_PRIOR = COST_FUNC + + CALL CALC_IASI_CO_FORCE( COST_FUNC ) + CF_IASICO = CF_IASICO + COST_FUNC - CF_PRIOR + WRITE(128,110) (CF_IASICO) +#endif +!=================================================================== +!xzhang: O3 columns from MLS +!=================================================================== + +#if defined ( MLS_O3_OBS ) + + ! Read MLS file just before midnight of the day of obs + !if first then read obs file to get hour + IF ( GET_NHMS() .ge. 20000 ) THEN + PRINT*, 'about to read MLS O3 file' + CALL READ_MLS_O3_FILE( GET_NYMD(), GET_NHMS() ) + ENDIF + + CALL CALC_MLS_O3_FORCE + +#endif + +!=================================================================== +!xzhang: HNO3 columns from MLS +!=================================================================== + +#if defined ( MLS_HNO3_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_mlshno3.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 123, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + ! Read MLS file just before midnight of the day of obs + !if first then read obs file to get hour + IF ( GET_NHMS() .ge. 230000 ) THEN + PRINT*, 'about to read MLS HNO3 file' + CALL READ_MLS_HNO3_FILE( GET_NYMD(), GET_NHMS() ) + ENDIF + CF_PRIOR = COST_FUNC + CALL CALC_MLS_HNO3_FORCE + CF_MLSHNO3 = CF_MLSHNO3 + COST_FUNC - CF_PRIOR + WRITE(123,110) (CF_MLSHNO3) +#endif + +!=================================================================== +!mkeller: NO2 columns from OMI +!=================================================================== + +#if defined ( OMI_NO2_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_omino2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 124, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + !IF ( GET_NHMS() .EQ. 0 ) THEN + !PRINT*, 'about to write OMI NO2 file' + !CALL WRITE_OMI_NO2_FILE( GET_NYMD(), GET_NHMS() ) + !ENDIF + CF_PRIOR = COST_FUNC + CALL CALC_OMI_NO2_FORCE + CF_OMINO2 = CF_OMINO2 + COST_FUNC - CF_PRIOR + WRITE(124,110) (CF_OMINO2) +#endif + +!=================================================================== +!xzhang: CH2O columns from OMI +!=================================================================== + +#if defined ( OMI_CH2O_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_omich2o.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 125, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + CF_PRIOR = COST_FUNC + + !IF ( GET_NHMS() .EQ. 0 ) THEN + !PRINT*, 'about to write OMI NO2 file' + !CALL WRITE_OMI_NO2_FILE( GET_NYMD(), GET_NHMS() ) + !ENDIF + CALL CALC_OMI_CH2O_FORCE + CF_OMICH2O = CF_OMICH2O + COST_FUNC - CF_PRIOR + WRITE(125,110) (CF_OMICH2O) +#endif +!=================================================================== +!xzhang: NO2 vertical profile from OSIRIS +!=================================================================== + +#if defined ( OSIRIS_NO2_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_osirisno2.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 126, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + ! Read OSIRIS file just before midnight of the day of obs + + !IF ( GET_NHMS() .EQ. 0 ) THEN + !PRINT*, 'about to write OMI NO2 file' + !CALL WRITE_OMI_NO2_FILE( GET_NYMD(), GET_NHMS() ) + !ENDIF + CF_PRIOR = COST_FUNC + CALL CALC_OSIRIS_NO2_FORCE + CF_OSIRISNO2 = CF_OSIRISNO2 + COST_FUNC - CF_PRIOR + WRITE(126,110) (CF_OSIRISNO2) +#endif + + !================================================================ + ! CO columns from the SCIA instrument using the Bremen retrieval + !================================================================ +#if defined ( SCIA_BRE_CO_OBS ) + + ! Read SCIA file at the first call or when the month changes + IF ( GET_NHMS() .ge. 230000 ) THEN + + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + PRINT*, 'about to read SCIA Bremen CO file' + CALL READ_SCIAbr_CO_FILE( GET_NYMD(), GET_NHMS() ) + + ENDIF + + IF ( ITS_TIME_FOR_SCIAbr_CO_OBS() ) THEN + PRINT*, 'its time for SCIA CO obs' + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'CALC ADJ FORCE SCIA Bremen CO' + + CALL CALC_SCIAbr_CO_FORCE + ENDIF + +#endif + + !================================================================ + ! CO columns from the AIRS instrument + !================================================================ +#if defined ( AIRS_CO_OBS ) + + ! Read AIRS file just before midnight of the day of obs + !if first then read obs file to get hour + IF ( GET_NHMS() .ge. 230000 ) THEN + + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + PRINT*, 'about to read AIRS CO file' + CALL READ_AIRS_CO_FILES( GET_NYMD(), GET_NHMS() ) + + ENDIF + + IF ( ITS_TIME_FOR_AIRS_CO_OBS() ) THEN + + PRINT*, 'its time for AIRS CO obs' + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'CALC ADJ FORCE AIRS CO' + + CALL CALC_AIRS_CO_FORCE + ENDIF + +#endif + + !================================================================ + ! Aerosol retrieval from MODIS (xxu, dkh, 01/09/12, adj32_011) + !================================================================ +#if defined ( MODIS_AOD_OBS ) + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + CALL CALC_MODIS_AOD_FORCE( COST_FUNC ) + + ! Track cost function contributions + CF_MODIS_AOD = CF_MODIS_AOD + COST_FUNC - CF_PRIOR +#endif + + ! Added for OSIRIS obs (tww, 20120223) + !================================================================ + ! O3 obs from OSIRIS + !================================================================ +#if defined ( OSIRIS_OBS ) + IF ( SECOND ) THEN + FILENAME = 'cfn_osi.NN.m' + CALL EXPAND_NAME( FILENAME, N_CALC ) + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + OPEN( 126, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL' ) + ENDIF + + ! Track cost function contributions + CF_PRIOR = COST_FUNC + + ! Read file just before midnight of the day of obs + ! if first then read obs file to get hours of obs + IF ( GET_NHMS() .ge. 230000 ) THEN + + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + PRINT *, 'about to read OSIRIS file' + CALL READ_OSIRIS_FILE( GET_NYMD(), GET_NHMS() ) + + ENDIF + + IF (ITS_TIME_FOR_OSIRIS_OBS() ) THEN + + PRINT *, 'its time for OSIRIS obs' + ! Echo some input to the screen + WRITE ( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE ( 6, '(a,/)' ) 'CALC ADJ FORCE OSIRIS' + + CALL CALC_OSIRIS_FORCE( COST_FUNC ) + + ENDIF + CALL CALC_GC_O3 + ! Track cost function contributions + CF_OSIRIS = CF_OSIRIS + COST_FUNC - CF_PRIOR + WRITE(126,110) (CF_OSIRIS) +#endif + + !================================================================ + ! Psuedo observations generated from GEOS-Chem reference run + !================================================================ + +#if defined ( PSEUDO_OBS ) + + WRITE(6,*) ' READ PSEUDO OBS ' + + ! Read obs file + CALL READ_OBS_FILE ( GET_NYMD(), GET_NHMS() ) + + ! mak debug + PRINT*, 'min/max of OBS_STT:', minval(OBS_STT), maxval(OBS_STT) + PRINT*, 'min/max of CHK_STT:', minval(CHK_STT), maxval(CHK_STT) + + ! Initialize to be safe + NEW_COST = 0d0 + + FACTOR = 0.01d0 / ( IIPAR * JJPAR ) + + DO N = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(N) ) THEN + + DO L = 1, LLPAR + + MIN_MEAN_OBS = SUM( OBS_STT(:,:,L,N) ) * FACTOR + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, OBS_ERR) +!$OMP+PRIVATE( DIFF ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( GET_CF_REGION(I,J,L) > 0d0 ) THEN + + ! from each species + DIFF = ( CHK_STT(I,J,L,N) - OBS_STT(I,J,L,N) ) + + ! Calculate new additions to cost function + ! Now we calculate the error as being proportional to the observation + ! value + OBS_ERR = MAX( OBS_STT(I,J,L,N), MIN_MEAN_OBS )**2 + + ! Trap for dividing by small numbers + IF ( ( IS_SAFE_DIV( 1d0, OBS_ERR ) ) .AND. + & ( OBS_ERR .GT. 1e-19 ) ) THEN + + NEW_COST(I,J,L,N) = 0.5d0 / OBS_ERR + & * GET_CF_REGION(I,J,L) + & * DIFF ** 2 + + ! Force the adjoint variables x with dJ/dx + ADJ_FORCE(I,J,L,N) = GET_CF_REGION(I,J,L) + & * DIFF / OBS_ERR + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + & + ADJ_FORCE(I,J,L,N) + ENDIF + + ELSE + + ADJ_FORCE(I,J,L,N) = 0d0 + + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDDO + ENDIF + ENDDO + + ! + PRINT *,"OBS_COST: ", SUM ( NEW_COST ) + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + +#endif + + ! Error checking: warn of exploding adjoit values, except + ! the first jump up from zero (MAX_ADJ_TMP = 0 first few times) + IF ( MAXVAL(ABS(STT_ADJ)) > (MAX_ADJ_TMP * MAX_ALLOWED_INCREASE) + & .AND. ( MAX_ADJ_TMP > 0d0 ) ) THEN + + WRITE(6,*)' *** - WARNING: EXPLODING adjoints in ADJ_AEROSOL' + WRITE(6,*)' *** - MAX(STT_ADJ) before = ',MAX_ADJ_TMP + WRITE(6,*)' *** - MAX(STT_ADJ) after = ',MAXVAL(ABS(STT_ADJ)) + + ADJ_EXPLD_COUNT = ADJ_EXPLD_COUNT + 1 + + IF (ADJ_EXPLD_COUNT > MAX_ALLOWED_EXPLD ) + & CALL ERROR_STOP('Too many exploding adjoints', + & 'geos_chem_adj_mod.f') + + ENDIF + + + ! mak debug + WRITE(6,*) 'MIN/MAX OF STT_ADJ:', minval(stt_adj), maxval(stt_adj) + WRITE(6,*) 'COST_FUN = ', COST_FUNC + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Return to calling progam + END SUBROUTINE CALC_ADJ_FORCE_FOR_OBS + +!------------------------------------------------------------------------------ + SUBROUTINE CALC_ADJ_FORCE_FOR_SENS( ) +! +!****************************************************************************** +! Subroutine CALC_ADJ_FORCE_FOR_SENS calculates the cost function for +! sensitivity calculations. (dkh, ks, mak, cs 06/08/09) +! +! NOTE: +! (1 ) Split off from CALC_ADJ_FORCE (dkh, ks, mak, cs 06/08/09) +! (2 ) Add UNITS = 'ppm_free_trop'. (dkh, 05/06/10) +! (3 ) BUG FIX: correct units for cspec_ppb (fgap, dkh, 02/03/11) +! (4 ) Now control units via input.gcadj. Add LMAX_OBS and NSPAN. (dkh, 02/09/11) +! (5 ) Delete old code and add LPOP_UGM3 (sev, dkh, 02/13/12, adj32_024) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION, NTR2NOBS + USE ADJ_ARRAYS_MOD, ONLY : OBS_STT + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE ADJ_ARRAYS_MOD, ONLY : CNAME + USE ADJ_ARRAYS_MOD, ONLY : ADJOINT_AREA_M2 + USE ADJ_ARRAYS_MOD, ONLY : DEP_UNIT + USE ADJ_ARRAYS_MOD, ONLY : TRACER_IND + USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE ADJ_ARRAYS_MOD, ONLY : CS_DDEP_CONV + USE ADJ_ARRAYS_MOD, ONLY : DDEP_TRACER + USE ADJ_ARRAYS_MOD, ONLY : DDEP_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : WDEP_CV + USE ADJ_ARRAYS_MOD, ONLY : WDEP_LS + USE CHECKPT_MOD, ONLY : CHK_STT + USE ERROR_MOD, ONLY : DEBUG_MSG, IT_IS_NAN, ERROR_STOP + USE DAO_MOD, ONLY : AIRVOL, AD + USE DIAG_MOD, ONLY : AD44 + USE DIAG_MOD, ONLY : AD38 + USE DIAG_MOD, ONLY : AD39 + USE DRYDEP_MOD, ONLY : NUMDEP + USE DRYDEP_MOD, ONLY : NTRAIND + USE TIME_MOD, ONLY : GET_LOCALTIME + USE TIME_MOD, ONLY : GET_TS_CHEM + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TRACERID_MOD + USE COMODE_MOD, ONLY : JLOP, CSPEC + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : CSPEC_AFTER_CHEM_ADJ + USE COMODE_MOD, ONLY : VOLUME + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : TCVV + USE TRACERID_MOD, ONLY : IDO3 + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM +#if defined ( LIDORT ) + USE LIDORT_MOD, ONLY : CALC_RF_FORCE +#endif + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS + USE LOGICAL_ADJ_MOD, ONLY : LKGBOX + USE LOGICAL_ADJ_MOD, ONLY : LUGM3 + USE LOGICAL_ADJ_MOD, ONLY : LSTT_PPB + USE LOGICAL_ADJ_MOD, ONLY : LSTT_TROP_PPM + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_PPB + USE LOGICAL_ADJ_MOD, ONLY : LPOP_UGM3 + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LKGNHAYR + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_OBS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_MOD, ONLY : LCHEM + USE PBL_MIX_MOD, ONLY : GET_PBL_TOP_L + USE PBL_MIX_MOD, ONLY : GET_PBL_MAX_L + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP + USE POPULATION_MOD, ONLY : POP_WEIGHT_COST + USE TIME_MOD, ONLY : GET_TS_DYN + USE TIME_MOD, ONLY : GET_TS_CHEM + USE WETSCAV_MOD, ONLY : GET_WETDEP_IDWETD + USE WETSCAV_MOD, ONLY : NSOL + ! for flux based cost function (hml,06/13/12) + USE LOGICAL_ADJ_MOD, ONLY : LFLX_UGM2 + USE GRID_MOD, ONLY : GET_AREA_M2 + ! for Antarctica cost function (hml,07/16/12) + USE DAO_MOD, ONLY : IS_ICE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! XNUMOL + ! added (dkh, 10/25/07) +# include "comode.h" ! IGAS, ITLOOP + + + ! Internal variables + REAL*8 :: DIFF + REAL*8 :: NEW_COST(IIPAR,JJPAR,LLPAR,N_TRACERS) + REAL*8 :: ADJ_FORCE(IIPAR,JJPAR,LLPAR,N_TRACERS) + INTEGER :: I, J, L, N + INTEGER :: ADJ_EXPLD_COUNT + INTEGER, PARAMETER :: MAX_ALLOWED_EXPLD = 10 + REAL*8, PARAMETER :: MAX_ALLOWED_INCREASE = 10D10 + REAL*8 :: MAX_ADJ_TMP + REAL*8 :: TARGET_STT + REAL*8 :: FACTOR + !CHARACTER(LEN=40) :: UNITS + REAL*8 :: CF_PRIOR + REAL*8 :: VCD + LOGICAL, SAVE :: FIRST = .TRUE. + REAL*8 :: DTCHEM + REAL*8 :: NTSCHEM + REAL*8 :: PBL_MAX + REAL*8 :: CONV_TIME, CONV_AREA(IIPAR,JJPAR) + REAL*8 :: CONV_C(N_TRACERS) + INTEGER :: NN + + + ! added to support observation (or sensitivity wrt) of CSPEC species + INTEGER :: JLOOP + REAL*8 :: NEW_COST_CSPEC(ITLOOP,NOBS_CSPEC) + REAL*8 :: NEW_COST_AIR(ITLOOP) + REAL*8 :: AIR_SUM + REAL*8 :: NEW_CF + REAL*8, PARAMETER :: CONVERT_FAC = 1d3 / 28.966d0 * 6.023D23 + ! Parameter coverning temporal averaging range (total nmber of chem time steps) + ! Now use NSPAN, set in input.gcadj + !REAL*8, PARAMETER :: NTSCHEM = 24d0 * 30d0 + + ! Parameters covering spatial averaging range for CSPEC-based cost functions. + ! For STT-based cost functions, use CF_REGION to mask spatial regions. + INTEGER, PARAMETER :: LMIN = 1 + INTEGER, PARAMETER :: LMAX = LLTROP + INTEGER, PARAMETER :: JMIN = 1 + INTEGER, PARAMETER :: JMAX = JJPAR + INTEGER, PARAMETER :: IMIN = 1 + INTEGER, PARAMETER :: IMAX = IIPAR + + INTEGER, SAVE :: OBS_COUNT = 0 + + ! Parameters covering chemical range (can't set a PARAMETER to a tracerid) + INTEGER :: NMIN + INTEGER :: NMAX + + ! for flux based cost function (hml, 06/13/12) + REAL*8 :: COST_AREA + + !================================================================ + ! CALC_ADJ_FORCE_FOR_SENSE begins here! + !================================================================ + + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + 1 + IF ( OBS_COUNT > NSPAN ) RETURN + ENDIF + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C A L C A D J F O R C E - S E N S E ' + + ! Some error checking stuff + MAX_ADJ_TMP = MAXVAL( STT_ADJ ) + ADJ_EXPLD_COUNT = 0 + + ! Radiative forcing sensitivities (dkh, 07/30/10) +#if defined( LIDORT ) + CALL CALC_RF_FORCE( COST_FUNC, N_CALC ) + RETURN +#endif + + + NEW_COST = 0d0 + + ! Evaulate J in units of kg/box is default for global FD tests. + ! Deposition adjoint forcing is applied elsewhere for FD tests. + IF ( ( LFD_GLOB .and. ( .not. LADJ_FDEP ) ) .or. LKGBOX ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) + DO NN = 1, NOBS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Get tracer index of current observation + N = TRACER_IND(NN) + + ! Determine the contribution to the cost function in each grid cell + ! from each species + + ! dkh -- I use N_CALC = 1 to do JACOBIAN test + NEW_COST(I,J,L,N) = GET_CF_REGION(I,J,L) * CHK_STT(I,J,L,N) + + ! Force the adjoint variables x with dJ/dx=1 + ADJ_FORCE(I,J,L,N) = GET_CF_REGION(I,J,L) + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + ADJ_FORCE(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + + ! Evaulate J in units of ug/m3 + ELSEIF ( LUGM3 ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) +!$OMP+PRIVATE( DIFF ) + DO NN = 1, NOBS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Get tracer number for current obs + N = TRACER_IND(NN) + + ! Determine the contribution to the cost function in each grid cell + ! from each species + + ! dkh -- I use N_CALC = 1 to do JACOBIAN test + ! Convert to ug/m3 (dkh, 10/13/06) + NEW_COST(I,J,L,N) = GET_CF_REGION(I,J,L) * CHK_STT(I,J,L,N) + & * 1d9 / AIRVOL(I,J,L) + + ! Force the adjoint variables x with dJ/dx=1 + ! Account for unit conversion to ug/m3 (dkh, 10/13/06) + ADJ_FORCE(I,J,L,N) = GET_CF_REGION(I,J,L) + & * 1d9 / AIRVOL(I,J,L) + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + ADJ_FORCE(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + + ! Evaulate J in units of ppb + ELSEIF ( LSTT_PPB ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) +!$OMP+PRIVATE( DIFF ) + DO NN = 1, NOBS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Get tracer number for current obs + N = TRACER_IND(NN) + + ! Determine the contribution to the cost function in each grid cell + ! from each species + + ! dkh -- I use N_CALC = 1 to do JACOBIAN test + NEW_COST(I,J,L,N) = GET_CF_REGION(I,J,L) * CHK_STT(I,J,L,N) + & * TCVV(N) / AD(I,J,L) * 1d9 + + ! Force the adjoint variables x with dJ/dx=1 + ADJ_FORCE(I,J,L,N) = GET_CF_REGION(I,J,L) + & * TCVV(N) / AD(I,J,L) * 1d9 + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + ADJ_FORCE(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + + ! Evaulate J in units of ppm and only in the free trop + ELSEIF ( LSTT_TROP_PPM ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) +!$OMP+PRIVATE( DIFF ) + DO NN = 1, NOBS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Get tracer number for current obs + N = TRACER_IND(NN) + + IF ( L > GET_PBL_TOP_L(I,J) ) THEN + ! Determine the contribution to the cost function in each grid cell + ! from each species + + ! dkh -- I use N_CALC = 1 to do JACOBIAN test + NEW_COST(I,J,L,N) = GET_CF_REGION(I,J,L) + & * CHK_STT(I,J,L,N) + & * TCVV(N) / AD(I,J,L) * 1d6 + + ! Force the adjoint variables x with dJ/dx=1 + ADJ_FORCE(I,J,L,N) = GET_CF_REGION(I,J,L) + & * TCVV(N) / AD(I,J,L) * 1d6 + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + ADJ_FORCE(I,J,L,N) + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + + + ! Evaulate J in units of ppb, but observe a species (CSPEC) rather + ! than a tracer (STT). Consider the temporal / spatial average of O3. (dkh, 10/25/07) + ELSEIF ( LCSPEC_PPB ) THEN + + ! Always initialize this to 0d0 becuase it will always get added to ADCSPEC in + ! chemdr_adj + CSPEC_AFTER_CHEM_ADJ(:,:) = 0D0 + + ! Clear arrays + NEW_COST_CSPEC(:,:) = 0D0 + NEW_COST_AIR(:) = 0D0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, JLOOP ) +!$OMP+PRIVATE( DIFF ) + DO L = LMIN, LMAX + DO J = JMIN, JMAX + DO I = IMIN, IMAX + + ! 1-D SMVGEAR grid box index + JLOOP = JLOP(I,J,L) + IF ( JLOOP == 0 ) CYCLE + + + DO N = 1, NOBS_CSPEC + + ! Save the # of species and air molecules in each cell relevant to our cost function. + ! For O3, convert [#/cm3] --> [#] (note: AIRVOL is in m3) + NEW_COST_CSPEC(JLOOP,N) = CSPEC_AFTER_CHEM(JLOOP,N) + & * AIRVOL(I,J,L) + & * 1d6 + + ENDDO + + ! for AIR, convert [kg] --> [#]: + ! + ! AD [kg air] AVN [# air / mole] 1d3 [g air] + ! = ------------ * --------------------- * ----------- + ! MW Air [g air / mole] [kg air] + ! + ! The non-spatially dependent terms are bundled into CONVERT_FAC and calculated + ! only once ahead of time. The remaining terms are calculated within the loop. + NEW_COST_AIR(JLOOP) = AD(I,J,L) * CONVERT_FAC + + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + AIR_SUM = SUM( NEW_COST_AIR(:) ) + + ! Cost function is the mean concentration of in ppb, averaged + ! over the whole month. Multiply by 1d9 to convert to ppb and + ! divide by the total number of chemistry time steps during + ! the month. + COST_FUNC = COST_FUNC + & + SUM( NEW_COST_CSPEC(:,:) ) / AIR_SUM + & * 1d9 / NSPAN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, JLOOP ) +!$OMP+PRIVATE( DIFF ) + DO L = LMIN, LMAX + DO J = JMIN, JMAX + DO I = IMIN, IMAX + + ! 1-D SMVGEAR grid box index + JLOOP = JLOP(I,J,L) + IF ( JLOOP == 0 ) CYCLE + + ! Store the adjoint forcing in CSPEC_ADJ_FORCE, + ! which will be applied to ADCSPEC directly before the + ! adjoint of chemistry. + !------------------------------------------------------ + ! BUG FIX: + ! OLD code: + ! J = sum(O3 * AIRVOL) / sum( AIR ) / NTSCHEM * 1d9 + ! dJ/dO3 = * AIRVOL / sum( AIR ) / NTSCHEM * 1d9 + !CSPEC_ADJ_FORCE(JLOOP,IDO3) = AIRVOL(I,J,L) + & ! / AIR_SUM / NTSCHEM * 1d9 + ! NEW code: don't forget that O3 is multiplied by 1d6 + ! and now we use CSPEC_AFTER_CHEM_ADJ (fagp, dkh, 02/09/11) + ! J = sum(O3 * AIRVOL * 1d6) / sum( AIR ) / NTSCHEM * 1d9 + ! dJ/dO3 = * AIRVOL * 1d6 / sum( AIR ) / NTSCHEM * 1d9 + DO N = 1, NOBS_CSPEC + + CSPEC_AFTER_CHEM_ADJ(JLOOP,N) = AIRVOL(I,J,L) * 1d6 + & / AIR_SUM / NSPAN * 1d9 + ENDDO + !------------------------------------------------------ + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ! Call population weighted ug/m3 (sev, dkh, 02/13/12, adj32_024) + ELSEIF ( LPOP_UGM3 ) THEN + + CALL POP_WEIGHT_COST + + ! >> Evaluate J in units of ug/m2/hr (hml, 06/12/12) + ELSEIF ( LFLX_UGM2 ) THEN + + ! Clear array + COST_AREA = 0d0 + + DO J = JMIN, 8 !(90S-60S) + DO I = IMIN, IMAX + + ! For Antarctica (hml, 04/10/13) + IF ( IS_ICE(I,J) ) THEN + + ! To get the total area of cost function + COST_AREA = COST_AREA + GET_AREA_M2(J) + + ENDIF + + ENDDO + ENDDO + + WRITE(6,*)' COST_AREA (m2) = ', COST_AREA + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) + DO N = 1, NOBS + DO L = 1, 1 ! This option only valid for one level; Default is surface. + DO J = JMIN, 8 !(90S-60S) + DO I = IMIN, IMAX + + NN = NTR2NOBS(N) + + ! For Antarctica (hml, 04/10/13) + IF ( IS_ICE(I,J) ) THEN + + + ! Determine the contribution to the cost function in each grid cell + ! from each species + + ! Unit conversion from kg/box to ug/m2/hr after the loop + ! for efficiency (hml, 06/13/12) + NEW_COST(I,J,L,NN) = GET_CF_REGION(I,J,L) + & *CHK_STT(I,J,L,NN) + + ! Force the adjoint variables x with dJ/dx=1 + ! Convert to ug/m2 (hml, 06/13/12) + ADJ_FORCE(I,J,L,NN) = GET_CF_REGION(I,J,L) + & / COST_AREA / NSPAN * 1d9 + + STT_ADJ(I,J,L,NN) = STT_ADJ(I,J,L,NN) + & +ADJ_FORCE(I,J,L,NN) + + ENDIF + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Update cost function + COST_FUNC = COST_FUNC + SUM ( NEW_COST ) + & / COST_AREA / NSPAN * 1d9 + ! << + + ! species dry deposition forcing + ELSEIF ( LADJ_FDEP ) THEN + + ! tracer dry dep cost function + IF ( LADJ_DDEP_TRACER ) THEN + + ! Aerosol drydep forcings are applied directly withing sulfate_adj_mod.f + + ! Compute the cost function + IF ( FIRST ) THEN + + ! Update cost function + NEW_CF = SUM( DDEP_TRACER(:,:,:) ) + WRITE(6,*) ' DRY DEP STT COST FUNCTION = ', NEW_CF + COST_FUNC = COST_FUNC + NEW_CF + + ENDIF + + ENDIF + + IF ( LADJ_DDEP_CSPEC .and. LCHEM ) THEN + + ! Always initialize this to 0d0 becuase it will always get added to ADCSPEC in + ! chemdr_adj + CSPEC_AFTER_CHEM_ADJ(:,:) = 0D0 + + DTCHEM = GET_TS_CHEM() * 60d0 + NTSCHEM = NSPAN / ( GET_TS_CHEM() / 60D0 ) + + PBL_MAX = GET_PBL_MAX_L() + + + !default is molec/cm2/s + CONV_TIME = 1D0 / DTCHEM * 1D0 / NTSCHEM + + DO I = 1, IIPAR + DO J = 1, JJPAR + CONV_AREA(I,J) = 1d0 / GET_AREA_CM2(J) + ENDDO + ENDDO + + DO N = 1, NOBS_CSPEC + + WRITE(*,*) ' - FORCE DRY DEPOSITION: ', + & TRIM(CNAME(N)),' (',TRIM(DEP_UNIT),')' + + ENDDO + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, JLOOP, N ) + DO N = 1, NOBS_CSPEC + DO L = 1, PBL_MAX + DO J = 1, JJPAR + DO I = 1, IIPAR + + IF ( GET_FRAC_UNDER_PBLTOP( I, J, L ) > 0d0 ) THEN + + JLOOP = JLOP(I,J,L) + + CSPEC_AFTER_CHEM_ADJ(JLOOP,N) = + & VOLUME(JLOOP) + & * CONV_TIME + & * CONV_AREA(I,J) + & * GET_CF_REGION(I,J,L) + & * CS_DDEP_CONV(J,N) + & + CSPEC_AFTER_CHEM_ADJ(JLOOP,N) + + + ENDIF + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF ( FIRST ) THEN + + ! Update cost function + NEW_CF = SUM( DDEP_CSPEC(:,:,:) ) + WRITE(6,*) ' DRY DEP CSPEC COST FUNCTION = ', NEW_CF + COST_FUNC = COST_FUNC + NEW_CF + + ENDIF + + ENDIF + + ! Wet deposition LS forcing + IF ( LADJ_WDEP_LS ) THEN + + ! Forcings are applied in WETSCAV_ADJ_FORCE, which is called directly from + ! DO_WETDEP_ADJ + + ! Compute the cost function using the AD44 diagnostic + IF ( FIRST ) THEN + + ! Update cost function + NEW_CF = SUM( WDEP_LS(:,:,:) ) + WRITE(6,*) ' WET DEP LS COST FUNCTION = ', NEW_CF + COST_FUNC = COST_FUNC + NEW_CF + + ENDIF + + ENDIF + + ! Wet deposition CV forcing + IF ( LADJ_WDEP_CV ) THEN + + ! Forcings are applied in ADJ_NFCLDMX, which is called directly from + ! DO_CONVECTION_ADJ + + ! Compute the cost function using the AD44 diagnostic + IF ( FIRST ) THEN + + ! Update cost function + NEW_CF = SUM( WDEP_CV(:,:,:) ) + WRITE(6,*) ' WET DEP CV COST FUNCTION = ', NEW_CF + COST_FUNC = COST_FUNC + NEW_CF + + ENDIF + + ENDIF + + ELSE + + CALL ERROR_STOP('COST FUNCTION option not defined ', + & 'geos_chem_adj_mod.f' ) + + + ENDIF ! Units + + + ! Echo output to screen + IF ( LPRINTFD ) THEN + WRITE(6,*) ' ADJ_FORCE(:) = ', ADJ_FORCE(IFD,JFD,LFD,NFD) + WRITE(6,*) ' Using predicted value (CHK_STT) = ' + & , CHK_STT(IFD,JFD,LFD,NFD) + WRITE(6,*) ' Using CF_REGION = ', GET_CF_REGION(IFD,JFD,LFD) + WRITE(6,*) ' STT_ADJ(IFD,JFD,LFD,NFD) = ' + & , STT_ADJ(IFD,JFD,LFD,NFD) + WRITE(6,*) ' MIN/MAX OF STT_ADJ:', + & MINVAL(STT_ADJ), MAXVAL(STT_ADJ) + ENDIF + + ! Error checking: warn of exploding adjoit values, except + ! the first jump up from zero (MAX_ADJ_TMP = 0 first few times) + IF ( MAXVAL(ABS(STT_ADJ)) > (MAX_ADJ_TMP * MAX_ALLOWED_INCREASE) + & .AND. ( MAX_ADJ_TMP > 0d0 ) ) THEN + + WRITE(6,*)' *** - WARNING: EXPLODING adjoints in ADJ_AEROSOL' + WRITE(6,*)' *** - MAX(STT_ADJ) before = ',MAX_ADJ_TMP + WRITE(6,*)' *** - MAX(STT_ADJ) after = ',MAXVAL(ABS(STT_ADJ)) + + ADJ_EXPLD_COUNT = ADJ_EXPLD_COUNT + 1 + + IF (ADJ_EXPLD_COUNT > MAX_ALLOWED_EXPLD ) + & CALL ERROR_STOP('Too many exploding adjoints', + & 'ADJ_AEROSOL, adjoint_mod.f') + + ENDIF + + FIRST = .FALSE. + + WRITE(6,*) 'COST_FUN = ', COST_FUNC + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Return to calling progam + END SUBROUTINE CALC_ADJ_FORCE_FOR_SENS + +!------------------------------------------------------------------------------ + + SUBROUTINE LOAD_CHECKPT_DATA( NYMD, NHMS ) +! +!****************************************************************************** +! Subroutine LOAD_CHECKPT_DATA reads in information stored during the forward +! calculation. Some of the data (CSPEC) needs to be rotated. +! (dkh, 08/10/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NYMD (INTEGER) : NYMD in adjoint integration +! (2 ) NHMS (INTEGER) : NHMS in adjoint integration +! +! NOTES: +! (1 ) Added support for full chemistry. This subroutine is old code that's +! been lumped together, plus now we also rotate CSPEC and load STT. +! (2 ) Now save copy of ozone concentration to O3_AFTER_CHEM. Now reference +! IDO3 in TRACERID_MOD. +! (3 ) Add NO2_AFTER_CHEM. Now reference IDNO2 in TRACERID_MOD. (dkh, 11/07/06) +! (4 ) Updated to v8 adjoint (dkh, ks, mak, cs 06/14/09) +! (5 ) BUG FIX: LVARTROP treated correctly (dkh, 01/26/11) +! (6 ) Now use CSPEC_AFTER_CHEM to replace O3_AFTER_CHEM and NO2_AFTER_CHEM +! (dkh, 02/09/11) +! (7 ) Now check to make sure FD cell is in trop before printing out debug +! info (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! Reference to f90 modules + USE TIME_MOD, ONLY : ITS_TIME_FOR_CHEM + USE CHECKPT_MOD, ONLY : READ_CHECKPT_FILE, CHK_STT, CHK_PSC, + & CHK_STT_BEFCHEM, RP_IN, + & CHK_HSAVE, PART_CASE, + & READ_CHK_CON_FILE ! (dkh, 09/15/08) + USE COMODE_MOD, ONLY : CHK_CSPEC, CSPEC , JLOP, + & CSPEC_AFTER_CHEM + USE COMODE_MOD, ONLY : HSAVE + USE DAO_MOD, ONLY : AIRVOL, AIRDEN, BXHEIGHT, + & DELP, AIRQNT, AD + USE PRESSURE_MOD, ONLY : SET_FLOATING_PRESSURE + USE TRACERID_MOD, ONLY : IDO3, IDNO2 + USE GEOS_CHEM_MOD, ONLY : NSECb + USE GCKPP_ADJ_GLOBAL, ONLY : NVAR !, SMAL2 -- SMAL2 is in comode.h + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_MOD, ONLY : LCHEM + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + + ! add (dkh, 02/02/09) + USE CHECKPT_MOD, ONLY : READ_CHK_DYN_FILE + + ! Now add TMP met fields, which are loaded here + USE DAO_MOD, ONLY : SLP, SLP_TMP + USE DAO_MOD, ONLY : LWI, LWI_TMP + USE DAO_MOD, ONLY : TO3, TO3_TMP + USE DAO_MOD, ONLY : TTO3, TTO3_TMP + + ! LVARTROP support for adj (dkh, 01/26/11) + USE COMODE_MOD, ONLY : CSPEC_FULL + USE COMODE_MOD, ONLY : IXSAVE, IYSAVE, IZSAVE + USE LOGICAL_MOD, ONLY : LVARTROP + USE COMODE_MOD, ONLY : ISAVE_PRIOR + + + +# include "CMN_SIZE" ! Size params +# include "comode.h" ! ITLOOP, IGAS +# include "define.h" ! ITLOOP, IGAS + + + ! Arguments + INTEGER, INTENT(IN) :: NYMD, NHMS + + ! Local variables + INTEGER :: I, J, L, JLOOP, N + INTEGER :: IDCSPEC + LOGICAL, SAVE :: TURNAROUND = .TRUE. + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! LOAD_CHECKPT_DATA begins here! + !================================================================= + + ! Load the TMP met fields so they can rotate in later. + IF ( FIRST ) THEN + SLP_TMP(:,:) = SLP(:,:) +#if defined( GEOS_3 ) || defined( GEOS_4 ) || defined( GEOS_5 ) || defined(GEOS_FP) + LWI_TMP(:,:) = LWI(:,:) +#endif +#if defined( GEOS_5 ) || defined(GEOS_FP) + TO3_TMP(:,:) = TO3(:,:) + TTO3_TMP(:,:) = TTO3(:,:) +#endif + FIRST = .FALSE. + ENDIF + + IF ( ITS_TIME_FOR_CHEM() ) THEN + + ! Rotate arrays for fullchem + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + IF ( TURNAROUND .and. IDO3 /= 0 .and. IDNO2 /=0 ) THEN + + ! Added in v16 (dkh, 08/27/06) + ! Get directly from CSPEC the first time +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP, N, IDCSPEC ) + DO JLOOP = 1, ITLOOP + DO N = 1, NOBS_CSPEC + + IDCSPEC = IDCSPEC_ADJ(N) + ! Now make this more general (dkh, 02/09/11) + !O3_AFTER_CHEM(JLOOP) = CSPEC(JLOOP,IDO3) + !NO2_AFTER_CHEM(JLOOP) = CSPEC(JLOOP,IDNO2) + CSPEC_AFTER_CHEM(JLOOP,N) = CSPEC(JLOOP,IDCSPEC) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ELSEIF ( IDO3 /= 0 .and. IDNO2 /=0 ) THEN + + ! Don't need to do this rotate stuff, (dkh, 08/29/05) + ! Actually, we do need the values of ozone after chem + ! because we need to know O3 concentrations for additional + ! sulfate chemistry. (dkh, 10/12/05) + ! Use the checkpted values from last file read. + ! For using satellite data, we know also need NO2 after chemistry + ! so that we can interpolate NO2 at time of observation (dkh, 11/07/06) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP, N, IDCSPEC ) + DO JLOOP = 1, ITLOOP + DO N = 1, NOBS_CSPEC + + IDCSPEC = IDCSPEC_ADJ(N) + + + ! Replace these with CSPEC_AFTER_CHEM (dkh, 02/09/11) + !O3_AFTER_CHEM(JLOOP) = CHK_CSPEC(JLOOP,IDO3) + !NO2_AFTER_CHEM(JLOOP) = CHK_CSPEC(JLOOP,IDNO2) + CSPEC_AFTER_CHEM(JLOOP,N) = CHK_CSPEC(JLOOP,IDCSPEC) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ! Turnaround will be false after the first time through this routine + TURNAROUND = .FALSE. + + ENDIF ! fullchem + + ! Read data from file + CALL READ_CHECKPT_FILE ( NYMD, NHMS ) + + IF ( ITS_A_FULLCHEM_SIM() .AND. LCHEM ) THEN + + ! Reset STT and CSPEC so that chemical rxn rates can be recalculated +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + STT(I,J,L,N) = CHK_STT_BEFCHEM(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! LVARTROP support for adj (dkh, 01/26/11) + IF ( LVARTROP ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( N, JLOOP, I, J, L ) + DO N = 1, IGAS + DO JLOOP = 1, NTLOOP + + ! 3-D array indices + I = ISAVE_PRIOR(JLOOP,1) + J = ISAVE_PRIOR(JLOOP,2) + L = ISAVE_PRIOR(JLOOP,3) + + ! Copy from 3-D array + CHK_CSPEC(JLOOP,N) = CSPEC_FULL(I,J,L,N) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! Load in the values of CSPEC from the previous (fwd) time step that + ! were saved as CPSEC_PRIOR. +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JLOOP, N ) + DO N = 1, IGAS + DO JLOOP = 1, ITLOOP + + ! Reset small values that have been read in as zero from the checkpt file. + ! These values were set to SMAL2, but in reading and writing to 8bit file + ! they get converted to zero, which lead to NaN in PARTITION. Only a problem + ! for the firt NVAR entries. (dkh, 08/29/05) + IF ( CHK_CSPEC(JLOOP,N) < SMAL2 .AND. N <= NVAR ) + & CHK_CSPEC(JLOOP,N) = SMAL2 + + CSPEC(JLOOP,N) = CHK_CSPEC(JLOOP,N) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ! dkh debug + !IF ( LPRINTFD ) THEN + IF ( LPRINTFD .and. JLOP(IFD,JFD,LFD) > 0 ) THEN + print*, 'CSPEC read = ', CSPEC(JLOP(IFD,JFD,LFD),:) + print*, 'JLOP read = ', JLOP(IFD,JFD,LFD) + ENDIF + + ! Reset HSAVE to the value from previous time step, written to + ! chk file corresponding to this time step. (dkh, 09/06/05) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO I = 1, IIPAR + DO J = 1, JJPAR + DO L = 1, LLTROP + + HSAVE(I,J,L) = CHK_HSAVE(I,J,L) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !IF ( LPRINTFD ) THEN + IF ( LPRINTFD .and. JLOP(IFD,JFD,LFD) > 0 ) THEN + WRITE(6,*) 'CHK_STT(FD) = ', CHK_STT(IFD,JFD,LFD,NFD) + WRITE(6,*) 'CHK_STT_BEFCHEM(FD) =', + & CHK_STT_BEFCHEM(IFD,JFD,LFD,NFD) + WRITE(6,*) 'PART_CASE(FD) = ', + & PART_CASE(JLOP(IFD,JFD,LFD)) + ENDIF + + ENDIF ! fullchem + + + ENDIF ! ITS_TIME_FOR_CHEM + + ! Now read variables checkpointed at the dynamic time step (dkh, 02/02/09) + CALL READ_CHK_DYN_FILE( NYMD, NHMS ) + + ! Set the surface pressure to be consistant with the forward run + ! Note: if, at some point, want to include adjoints of any of the + ! the processes that occur before transport in fwd run, want to use + ! CHK_PSC(:,:,1) (for example lightning NOX emissions?). + CALL SET_FLOATING_PRESSURE( CHK_PSC(:,:,2) ) + + ! Add mak and ks checkpointing files. Make sure they get read every + ! dynamic time step. (dkh, 10/10/08) +#if defined( GEOS_4 ) + CALL READ_CHK_CON_FILE ( NYMD, NHMS ) +#endif + + ! Recompute airmasses + CALL AIRQNT + + IF ( LPRINTFD ) THEN + WRITE(6,*) + & ' AD(FD) = ', AD(IFD,JFD,LFD), + & ' AIRVOL(FD) =', AIRVOL(IFD,JFD,LFD), + & ' AIRDEN(FD) =', AIRDEN(LFD,IFD,JFD), + & ' BXHEIGHT = ', BXHEIGHT(IFD,JFD,LFD), + & ' DELP = ', DELP(LFD,IFD,JFD) + ENDIF + + + ! Return to calling program + END SUBROUTINE LOAD_CHECKPT_DATA + +!------------------------------------------------------------------------------ + SUBROUTINE RESCALE_ADJOINT( ) +! +!****************************************************************************** +! Subroutine RESCALE_ADJOINT multiplies the adjoint sensitivities by the +! initial concentrations read from the restart file. +! dkh, 02/20/05 +! +! NOTES: +! (1 ) Don't use the RESTART array anymore. Need to make a +! STT2ADJ lookup table. (dkh, 03/03/05) +! (2 ) Save original tracer values (in ug/m3) to ORIG_STT. Remultiply by this +! rather than reading in the restart file again. (06/15/05) +! (3 ) Now ORIG_STT in [kg/box] +! (4 ) Add support for EMISSIONS case. (dkh, 07/23/06) +! (5 ) Cosmetic changes and lots of comments. (dkh, 10/04/06) +! (6 ) Add FK to penalize equally for scaling up or down (dkh, 12/07/06). +! (7 ) Update to v8 (mak, 6/18/09) +! (8 ) Potential problem (especially with L3DVAR option: READ_RESTART_FILE +! overwrites the current value of STT, which is ok at the end of +! the adjoint run, but otherwise, STT has the checkpointed STT value. +! So for now, the only option in optimizing LICS is optimizing +! concentrations at the very first time step only. (mak, 6/19/09) +! (9 ) Clean up and simplify to only calculate ICS_SF_ADJ. (dkh, 11/06/09) +!****************************************************************************** +! + ! Reference to f90 modules + USE TRACERID_MOD ! IDTxxx + USE ERROR_MOD, ONLY : ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ, COST_FUNC, + & ICS_SF, ICS_SF0, + & MMSCL, NNEMS, ICS_SF_ADJ, + & OPT_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : STT_ORIG + USE TRACER_MOD, ONLY : N_TRACERS, STT + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST, LICS, L4DVAR, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LSENS + +# include "CMN_SIZE" + + ! Local variables + INTEGER :: I, J, L, N, M + + !====================================================================== + ! RESCALE_ADJOINT begins here! + !====================================================================== + + ! Only rescale, no regularize, for FD or sensitivity TEST + IF ( LICS ) THEN + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + + ! Rescale all gradients by ORIG_STT so that the gradients + ! are dCOST/dscaling factor. + ICS_SF_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) * STT_ORIG(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! mak debug 6/19/09 + PRINT*, 'MIN/MAX OF ICS_SF_ADJ:', minval(ICS_SF_ADJ), + & maxval(ICS_SF_ADJ) + PRINT*, 'MIN/MAX OF STT_ADJ:', minval(STT_ADJ), + & maxval(STT_ADJ) + + + END SUBROUTINE RESCALE_ADJOINT + + +!------------------------------------------------------------------------------ + + SUBROUTINE LOG_RESCALE_ADJOINT +! +!****************************************************************************** +! Subroutine LOG_RESCALE_ADJOINT converts that adjoint scaling factors to be +! those of log based scaling factors. (dkh, 04/25/07) +! +! +! NOTES: +! (1 ) Updated to v8 (mak, 6/19/09) +! (2 ) Clean up and simplify to only to log-rescaling (dkh, 11/06/09) +!****************************************************************************** +! + ! Reference to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ, MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : STT_ORIG + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF0 + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS, LFDTEST + USE TRACER_MOD, ONLY : N_TRACERS, STT + +# include "CMN_SIZE" + + ! Local variables + INTEGER :: I, J, L, N, M + + !====================================================================== + ! LOG_RESCALE_ADJOINT begins here! + !====================================================================== + + + + IF ( LICS ) THEN + + ! Transform back to exponential scaling factors + ICS_SF_ADJ(:,:,:,:) = ICS_SF_ADJ(:,:,:,:) * ICS_SF(:,:,:,:) + ICS_SF(:,:,:,:) = LOG(ICS_SF(:,:,:,:)) + ICS_SF0(:,:,:,:) = LOG(ICS_SF0(:,:,:,:)) + + ENDIF + + IF ( LADJ_EMS ) THEN + + ! Transform back to exponential scaling factors + EMS_SF_ADJ(:,:,:,:) = EMS_SF_ADJ(:,:,:,:) * EMS_SF(:,:,:,:) + EMS_SF(:,:,:,:) = LOG(EMS_SF(:,:,:,:)) + EMS_SF0(:,:,:,:) = LOG(EMS_SF0(:,:,:,:)) + + ENDIF + + + END SUBROUTINE LOG_RESCALE_ADJOINT + +! Obsolete (zhej, dkh, 01/16/12, adj32_016) +!!------------------------------------------------------------------------------ +! +! SUBROUTINE NESTED_RESCALE_ADJOINT +!! +!!****************************************************************************** +!! Subroutine NESTED_RESCALE_ADJOINT set the gradient in the cushion region to +!! ZERO. (zhe 11/28/10) +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ +! USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS, NOR +! +!# include "CMN_SIZE" +! +! ! Local variables +! REAL*8 :: EMS_SF_ADJ_SAVE(IIPAR,JJPAR,MMSCL,NNEMS) +! +! !====================================================================== +! ! NESTED_RESCALE_ADJOINT begins here! +! !====================================================================== +! +! +! EMS_SF_ADJ_SAVE = EMS_SF_ADJ +! EMS_SF_ADJ = 0d0 +! +! ! Nested observation region +! EMS_SF_ADJ(NOR(1):NOR(2),NOR(3):NOR(4),:,:) = +! & EMS_SF_ADJ_SAVE(NOR(1):NOR(2),NOR(3):NOR(4),:,:) +! +! ! Return to calling routine +! END SUBROUTINE NESTED_RESCALE_ADJOINT +! +!!------------------------------------------------------------------------------ + + + SUBROUTINE CALC_APRIORI + +!****************************************************************************** +! Subroutine CALC_APRIORI computes a priori term of the cost function and +! gradient. So that for cost function defined as: +! J(x) = (y-f(x))^T * Se^-1 *(y-f(x)) + (x-xa)^T * Sa^-1 * (x-xa) +! CALC_APRIORI computes (x-xa)^T Sa^-1 (x-xa), where xa are original scaling +! factors and x are currently optimized scaling factors and Sa^-1 is an +! inverse diagonal matrix of a priori source variance +! For gradient defined as: +! grad(J(x)) = 2 * grad(f(x)) * Se^-1 * (y-f(x)) + 2 * Sa^-1 * (x-xa) +! CALC_APRIORI computes 2 * Sa^-1 * (x-xa) +! for a time-independent inversion (MMSCL=1) +! (mak, 4/20/06) +! +! NOTES: +! ( 1) Currently the entire subroutine relies on Streets et al, 2003 inventory +! errors, following the setup in Colette Heald's 2004 inversion paper; +! Here, we specify 11 or so regions (12 splitting Korea and Japan) with +! 3 types of CO source (FF, BF, BB) +! ( 2) APGRAD needs to contain MMSCL dimensions (mak, 12/02/08) +! ( 3) Updated to v8 and new interface, make REG_PARAM come from input (mak, 6/19/09) +! ( 4) Minor compatibility updates (mak, 9/28/09) +! ( 5) Add a priori constraint for fulchem LOG_OPT (dkh, 12/15/09) +! ( 6) Now make ERR_EMS depend on the emissions type / species (dkh, 09/09/10) +! ( 7) Replace REG_PARAM_SPEC with REG_PARAM_ICS (dkh, 02/09/11) +! ( 8) Consolidate and cleanup (zhej, dkh, 01/18/12, adj32_017) +!****************************************************************************** +! + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF0, ICS_SF, ICS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_EMS, REG_PARAM_ICS + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ, ICS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_EMS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : ICS_ERROR + USE LOGICAL_ADJ_MOD, ONLY : L4DVAR, LADJ_EMS, LICS + USE TRACER_MOD, ONLY : N_TRACERS +#if defined ( TES_NH3_OBS ) + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_an1 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_sh + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENOX_so + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENOX_bb +#endif +#if defined ( LBKCOV_ERR ) + USE COVARIANCE_MOD , ONLY : CALC_COV_ERROR +#endif +# include "CMN_SIZE" + + INTEGER :: I, J, L, M, N, AS + + ! Obsolete (zhej, dkh, 01/18/12, adj32_017) + !REAL*8, ALLOCATABLE :: APCOST(:,:,:,:) + !REAL*8, ALLOCATABLE :: APGRAD(:,:,:,:) + !REAL*8, ALLOCATABLE :: ERR_PERCENT(:,:,:) + !REAL*8, ALLOCATABLE :: invSa(:,:,:) + !INTEGER :: count + !LOGICAL, SAVE :: TRACEP = .FALSE. + !LOGICAL, SAVE :: SEASONAL = .FALSE. + + ! for fullchem LOG_OPT runs (dkh, 12/15/09) + REAL*8 :: S2_INV + REAL*8 :: REG + + ! Replace TEMP2 with APCOST (zhej, dkh, 01/18/12, adj32_017) + !REAL*8 :: TEMP2(IIPAR,JJPAR,MMSCL,NNEMS) + REAL*8, ALLOCATABLE :: APCOST(:,:,:,:) + + ! Obsolete (zhej, dkh, 01/18/12, adj32_017) + !count = 0 + !TEMP2 = 0D0 + + ! Implement a priori term as was done in GCv6 adjoint. For now, keep this entirely + ! sep from monika's implementation. Merge these in the near future. (dkh, 12/15/09) + ! Now they are merged (zhej, dkh, 01/18/12, adj32_017) + !IF ( L4DVAR .and. ITS_A_FULLCHEM_SIM() .and. LADJ_EMS ) THEN + IF ( L4DVAR .and. LADJ_EMS ) THEN + + +#if defined ( TES_NH3_OBS ) + ! 100% error for NH3 emissions + EMS_ERROR(IDADJ_ENH3_an:IDADJ_ENH3_bf) = EXP(1d0) + + ! 25% error for SO2 emissions + EMS_ERROR(IDADJ_ESO2_an1:IDADJ_ESO2_sh) = EXP(0.25d0) + + ! 50% error for NOx emissions + EMS_ERROR(IDADJ_ENOX_so:IDADJ_ENOX_bb) = EXP(0.50d0) + + REG_PARAM_EMS(:) = 10d0 +#endif + + ! Replace TEMP2 with APCOST (zhej, dkh, 01/18/12, adj32_017) + ALLOCATE( APCOST( IIPAR,JJPAR,MMSCL,NNEMS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'APCOST' ) + APCOST = 0 + +#if ! defined ( LBKCOV_ERR ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, REG, S2_INV ) + DO N = 1, NNEMS + + ! Now skip emissions that are not included in optimization (dkh, 09/09/10) + IF ( .not. OPT_THIS_EMS(N) ) CYCLE + + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! diagonal of inverse error covariance +#if defined ( LOG_OPT ) + S2_INV = 1d0 / ( EMS_ERROR(N)/EMS_SF0(I,J,M,N) )**2 +#else + S2_INV = 1d0 / ( EMS_ERROR(N) )**2 +#endif + + REG = EMS_SF(I,J,M,N) - EMS_SF0(I,J,M,N) + + ! Calculate the contribution to the cost function, weighted by REG_PARAM + ! Replace TEMP2 with APCOST (zhej, dkh, 01/18/12, adj32_017) + APCOST(I,J,M,N) = 0.5d0 * REG_PARAM_EMS(N) * S2_INV + & * REG ** 2 + + ! Add this to the gradients + EMS_SF_ADJ(I,J,M,N) = EMS_SF_ADJ(I,J,M,N) + & + REG_PARAM_EMS(N) * S2_INV * REG + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO +#else + ! inverse of error covariance with off-diagonal terms + CALL CALC_COV_ERROR ( APCOST ) +#endif + + + ! Updated and merged (zhej, dkh, 01/18/12, adj32_017) + ELSEIF ( L4DVAR .AND. LICS ) THEN + + ALLOCATE( APCOST( IIPAR,JJPAR,LLPAR, N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'APCOST' ) + APCOST = 0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, REG, S2_INV ) + DO N = 1, N_TRACERS + + ! Now skip tracer that are not included in optimization (dkh, 09/09/10) + IF ( .not. OPT_THIS_TRACER(N) ) CYCLE + + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ! diagonal of inverse error covariance +#if defined ( LOG_OPT ) + S2_INV = 1d0 / ( ICS_ERROR(N) / ICS_SF0(I,J,L,N) )**2 +#else + S2_INV = 1d0 / ( ICS_ERROR(N) )**2 +#endif + + REG = ICS_SF(I,J,L,N) - ICS_SF0(I,J,L,N) + + ! Calculate the contribution to the cost function, weighted by REG_PARAM + APCOST(I,J,L,N) = 0.5d0 * REG_PARAM_ICS(N) * S2_INV + & * REG ** 2 + + ! Add this to the gradients + ICS_SF_ADJ(I,J,L,N) = ICS_SF_ADJ(I,J,L,N) + & + REG_PARAM_ICS(N) * S2_INV * REG + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ELSE + + PRINT*, 'OTHER SIMULATION TYPES NOT YET SUPPORTED' + PRINT*, 'ONLY L4DVAR with LICS OR LEMS (not even both)' + CALL ERROR_STOP('bad APRIORI option','geos_chem_adj_mod.f') + + ENDIF + + WRITE(6,*) 'COST_FUNC before apriori = ', COST_FUNC + + ! Add total regularization penalty to cost function + COST_FUNC = COST_FUNC + SUM(APCOST(:,:,:,:)) + + ! Write some output + WRITE(6,*) 'Total cost with penalty ...' + WRITE(6,*) 'COST_FUNC after adding apriori: ', COST_FUNC + WRITE(6,*) ' MAX APCOST = ', MAXVAL(APCOST(:,:,:,:)) + WRITE(6,*) ' SUM APCOST = ', SUM(APCOST(:,:,:,:)) + + + END SUBROUTINE CALC_APRIORI + +!----------------------------------------------------------------------- + + SUBROUTINE CALC_APRIORI_CO2 + +!****************************************************************************** +! Subroutine CALC_APRIORI_CO2 computes a priori term of the cost function and +! gradient for the CO2 simulation. (dkh, 01/09/11) +! +! In this routine, we assume that we have specified the standard deviation +! (error) in the EMS_ERROR array. +! +! For linear scaling factors, EMS_ERROR = p, where p is the pertent +! error in the emissions (as a decimal, ie 1 = 100%) +! +! For log scaling factors, EMS_ERROR = f, where f is a fractional error. f +! must be greater than 1. +! +! There is also a regularization parameter that is specified for each +! emissions inventory, REG_PARAM_EMS, in input.gcadj. +! +! NOTES: +! ( 1) Based on CALC_APRIORI +! +!****************************************************************************** + + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : COST_ARRAY, COST_FUNC, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR,COV_ERROR_LX,COV_ERROR_LY + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_EMS + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ, TEMP2 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ECO2ff, IDADJ_ECO2ocn + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS, LBKCOV + USE GRID_MOD , ONLY : GET_XMID, GET_YMID +#if defined ( LBKCOV_ERR ) + USE COVARIANCE_MOD , ONLY : CALC_COV_ERROR +#endif +# include "CMN_SIZE" + + REAL*8 :: S2_INV_2D(IIPAR,JJPAR) + REAL*8 :: REG_4D(IIPAR, JJPAR,MMSCL, NNEMS) + REAL*8 :: S2_INV + REAL*8 :: REG + REAL*8, ALLOCATABLE :: APCOST(:,:,:,:) + REAL :: TEMP(IIPAR,JJPAR) + INTEGER :: I, J, M, N, STATUS, NCID, VARID + CHARACTER(255) :: SCALEFN + + !================================================================= + ! CALC_APRIORI_CO2 begins here! + !================================================================= + +! ! For the moment, hardcode the emissions errors here. In the +! ! future, we should define these via input files. +!#if defined ( LOG_OPT ) +! ! assume a factor of two error +! EMS_ERROR(:) = 2d0 +!#else +! ! assume a 100% error +! EMS_ERROR(:) = 1d0 +! +! ! Alter a few to test if it's working +! !EMS_ERROR(IDADJ_ECO2ff) = 1d-2 +! !EMS_ERROR(IDADJ_ECO2ocn) = 1d2 +! +!#endif + print*, ' debug: EMS_ERROR = ', EMS_ERROR + + + ! So far have only developed this for emissions constraints + IF ( .not. LADJ_EMS ) THEN + + CALL ERROR_STOP( 'APRIORI_CO2 only for LICS', + & 'geos_chem_adj_mod.f' ) + + ENDIF + +#if ! defined ( LBKCOV_ERR ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, REG, S2_INV ) + DO N = 1, NNEMS + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + +#if defined ( LOG_OPT ) + ! inverse of error covariance (assume diagonal) + S2_INV = 1d0 / ( EMS_ERROR(N)/EMS_SF0(I,J,M,N) )**2 +#else + S2_INV = 1d0 / ( EMS_ERROR(N) ** 2 ) +#endif + + REG = EMS_SF(I,J,M,N) - EMS_SF0(I,J,M,N) + + ! Calculate the contribution to the cost function, weighted by REG_PARAM + TEMP2(I,J,M,N) = 0.5d0 * REG_PARAM_EMS(N) * S2_INV * REG ** 2 + + ! Add this to the gradients + EMS_SF_ADJ(I,J,M,N) = EMS_SF_ADJ(I,J,M,N) + & + REG_PARAM_EMS(N) * S2_INV * REG + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + +#else + ! inverse of error covariance with off-diagonal terms + CALL CALC_COV_ERROR ( APCOST ) +#endif + + WRITE(6,*) 'COST = ', COST_FUNC + + ! Add total regularization penalty to cost function + COST_FUNC = COST_FUNC + SUM(TEMP2(:,:,:,:)) !REG_COST + + ! Write some output + WRITE(6,*) 'Total cost with penalty = ', COST_FUNC + WRITE(6,*) ' MAX REG_COST = ', MAXVAL(TEMP2(:,:,:,:)) + WRITE(6,*) ' SUM REG_COST = ', SUM(TEMP2(:,:,:,:)) + + + END SUBROUTINE CALC_APRIORI_CO2 + +!----------------------------------------------------------------------- + + SUBROUTINE CALC_APRIORI_BCOC + +!****************************************************************************** +! Subroutine CALC_APRIORI_BCOC computes a priori term of the cost function and +! gradient for the BC simulation. (yhmao, dkh, 01/13/12, adj32_013) +! +! In this routine, we assume that we have specified the standard deviation +! (error) in the EMS_ERROR array. +! +! For linear scaling factors, EMS_ERROR = p, where p is the pertent +! error in the emissions (as a decimal, ie 1 = 100%) +! +! For log scaling factors, EMS_ERROR = f, where f is a fractional error. f +! must be greater than 1. +! +! There is also a regularization parameter that is specified for each +! emissions inventory, REG_PARAM_EMS, in input.gcadj. +! +! NOTES: +! ( 1) Based on CALC_APRIORI +! +! +!****************************************************************************** +! + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : COST_ARRAY, COST_FUNC, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_EMS + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS + +# include "CMN_SIZE" + + REAL*8 :: S2_INV + REAL*8 :: REG + REAL*8 :: TEMP2(IIPAR,JJPAR,MMSCL,NNEMS) + INTEGER :: I, J, M, N + + !================================================================= + ! CALC_APRIORI_BCOC begins here! + !================================================================= + + ! Initialize + TEMP2 = 0d0 + + + ! So far have only developed this for emissions constraints + IF ( .not. LADJ_EMS ) THEN + + CALL ERROR_STOP( 'APRIORI_BCPC not for LICS', + & 'geos_chem_adj_mod.f' ) + + ENDIF + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, REG, S2_INV ) + DO N = 1, NNEMS + IF ( .not. OPT_THIS_EMS(N) ) CYCLE + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + +#if defined ( LOG_OPT ) + ! inverse of error covariance (assume diagonal) + S2_INV = 1d0 / ( EMS_ERROR(N)/EMS_SF0(I,J,M,N) )**2 +#else + S2_INV = 1d0 / ( EMS_ERROR(N) ** 2 ) +#endif + + REG = EMS_SF(I,J,M,N) - EMS_SF0(I,J,M,N) + + ! Calculate the contribution to the cost function, weighted by REG_PARAM + TEMP2(I,J,M,N) = 0.5d0 * REG_PARAM_EMS(N) * S2_INV * REG ** 2 + + ! Add this to the gradients + EMS_SF_ADJ(I,J,M,N) = EMS_SF_ADJ(I,J,M,N) + & + REG_PARAM_EMS(N) * S2_INV * REG + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + WRITE(6,*) 'COST = ', COST_FUNC + + ! Add total regularization penalty to cost function + COST_FUNC = COST_FUNC + SUM(TEMP2(:,:,:,:)) !REG_COST + + ! Write some output + WRITE(6,*) 'Total cost with penalty = ', COST_FUNC + WRITE(6,*) ' MAX REG_COST = ', MAXVAL(TEMP2(:,:,:,:)) + WRITE(6,*) ' SUM REG_COST = ', SUM(TEMP2(:,:,:,:)) + + ! Return to calling program + END SUBROUTINE CALC_APRIORI_BCOC + +!----------------------------------------------------------------------- + + SUBROUTINE READ_APERROR( ERR_PERCENT ) +! +!****************************************************************************** +! Subroutine READ_APERROR reads observation error from binary punch files +! (zhe 6/6/11, adj32_018) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE TIME_MOD, ONLY : GET_TAUb + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + REAL*8 :: ERR_PERCENT( IIPAR,JJPAR, 2 ) + REAL*4 :: EMS_ERROR( IIPAR,JJPAR, 2 ) + + !================================================================= + ! READ_ERROR_VARIANCE begins here! + !================================================================= + + ! Filename + FILENAME = TRIM( 'APERROR_' ) // GET_RES_EXT() + + ! Echo some information to the standard output + WRITE( 6, 110 ) TRIM( FILENAME ) + 110 FORMAT( ' - READ_APERROR: Reading ERR_PERCENT + & from: ', a ) + + ! Read data from the binary punch file + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & GET_TAUb(), IGLOB, JGLOB, + & 1, EMS_ERROR, QUIET=.TRUE. ) + + ERR_PERCENT = EMS_ERROR + + ! Return to calling program + END SUBROUTINE READ_APERROR + +!----------------------------------------------------------------------- + + ! End of program + END MODULE GEOS_CHEM_ADJ_MOD diff --git a/code/adjoint/global_ch4_adj_mod.f b/code/adjoint/global_ch4_adj_mod.f new file mode 100644 index 0000000..8a63e76 --- /dev/null +++ b/code/adjoint/global_ch4_adj_mod.f @@ -0,0 +1,1672 @@ +!$Id: global_ch4_adj_mod.f,v 1.3 2012/03/02 06:10:57 daven Exp $ + MODULE GLOBAL_CH4_ADJ_MOD +! +!****************************************************************************** +! Module GLOBAL_CH4_ADJ_MOD contains variables and routines used for the +! adjoint CH4 simulation (adj_group, kjw, 2/22/10, adj32_023) +! +! To perform identical twin tests using TES pseudo-observations, I made some +! rather ugly work-arounds in the standard adjoint code distribution. These +! changes are not incorporated into the standard code because they would +! make the code messy and slower. If you want a copy of the v8 adjoint code +! used to perform identical twin tests, contact Kevin Wecht +! (wecht-at-fas.harvard.edu) (kjw, 7/06/11) +! +! Module Variables: +! ============================================================================ +! (1 ) BOH : Array to hold monthly mean OH concentrations +! (2 ) CH4_EMIS_ADJ : Array to hold methane emissions +! (3 ) COPROD : Array to hold CH4 loss from stratosphere +! (4 ) TAVG_ADJ : Array to hold average daily temperature +! (5 ) BAIRDENS : Array to hold density of air +! (6 ) FMOL_CH4 : Molecular weight of CH4 [kg / mol] +! (7 ) XNUMOL_CH4 : molec CH4 / kg CH4 +! (8 ) IU_A6_CH4_ADJ: file unit number +! +! Module Routines: +! ============================================================================ +! (1 ) EMISSCH4_ADJ : Adjoint of CH4 emissions +! (2 ) CHEMCH4_ADJ : Adjoint of CH4 chemistry +! (3 ) CH4_DECAY_ADJ : Adjoint of decay rate of CH4 by OH. +! (4 ) CH4_STRAT_ADJ : Adjoint of loss of CH4 in the stratosphere +! (5 ) READ_COPROD : Reads prescribed zonal CH4 loss from stratosphere +! (6 ) CH4_AVGTP_AVG : Gets 24h avg temp and pressure for CHEMCH4_ADJ +! (7 ) OPEN_A6_CH4_ADJ : Opens A6 met files for use by CH4_AVGTP_ADJ +! (8 ) READ_A6_CH4_ADJ : Reads A6 met files for use by CH4_AVGTP_ADJ +! (9 ) FIND_CLOSEST_A6 : Finds date and time of nearest A6 met field +! (10) GET_SCALE_GROUP : Determines which temporal/spatial scaling index to use. +! (11) INIT_CH4_ADJ : Allocates and initializes module arrays +! (12) CLEANUP_CH4_ADJ : Deallocates module arrays +! +! GEOS-CHEM modules referenced by global_ch4_mod.f +! ============================================================================ +! (1 ) biofuel_mod.f : Module w/ routines to read biofuel emissions +! (2 ) biomass_mod.f : Module w/ routines to read biomass emissions +! (3 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (4 ) dao_mod.f : Module w/ arrays for DAO met fields +! (5 ) diag_mod.f : Module w/ GEOS-CHEM diagnostic arrays +! (6 ) diag_pl_mod.f : Module w/ routines for prod & loss diag's +! (7 ) directory_mod.f : Module w/ GEOS-CHEM data & met field dirs +! (8 ) error_mod.f : Module w/ I/O error and NaN check routines +! (9 ) geia_mod : Module w/ routines to read anthro emissions +! (10) global_oh_mod.f : Module w/ routines to read 3-D OH field +! (11) global_nox_mod.f : Module w/ routines to read 3-D NOx field +! (12) grid_mod.f : Module w/ horizontal grid information +! (13) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (14) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (15) time_mod.f : Module w/ routines for computing time & date +! (16) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc. +! (17) tropopause_mod.f : Module w/ routines to read ann mean tropopause +! (18) logical_adj_mod.f: Module w/ adj logical flags +! +! NOTES: +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep all variables and routines + ! from being seen outside "global_ch4_adj_mod.f" + ! Exceptions for those listed under "PUBLIC ROUTINES" + !================================================================= + + ! PRIVATE module variables + PRIVATE + + ! PUBLIC ROUTINES + PUBLIC :: CHEMCH4_ADJ + PUBLIC :: EMISSCH4_ADJ + PUBLIC :: CLEANUP_GLOBAL_CH4_ADJ + + !================================================================= + ! MODULE VARIABLES + !================================================================= + REAL*8, ALLOCATABLE :: CH4_EMIS_ADJ(:,:,:) + REAL*8, ALLOCATABLE :: BOH(:,:,:,:) + REAL*8, ALLOCATABLE :: CH4LOSS(:,:,:,:) + REAL*8, ALLOCATABLE :: COPROD(:,:,:) + REAL*8, ALLOCATABLE :: TAVG_ADJ(:,:,:) + REAL*8, ALLOCATABLE :: BAIRDENS(:,:,:) + + ! FMOL_CH4 - kg CH4 / mole CH4 + ! XNUMOL_CH4 - molecules CH4 / kg CH4 + REAL*8, PARAMETER :: FMOL_CH4 = 16d-3 + REAL*8, PARAMETER :: XNUMOL_CH4 = 6.022d+23/FMOL_CH4 + INTEGER :: IU_A6_CH4_ADJ + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + + +!------------------------------------------------------------------------------ + + SUBROUTINE EMISSCH4_ADJ +! +!****************************************************************************** +! Subroutine EMISSCH4_ADJ does adjoint of CH4 emissions +! (adj_group, kjw, 2/22/10) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : ADCH4EMS, EMS_SF_ADJ, STT_ADJ + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TIME_MOD, ONLY : GET_TS_EMIS + USE TIME_MOD, ONLY : GET_MONTH, GET_YEAR + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH, ITS_A_NEW_YEAR + USE GLOBAL_CH4_MOD, ONLY : WETLAND_EMIS, BIOBURN_EMIS + USE GLOBAL_CH4_MOD, ONLY : RICE_EMIS!, BIOFUEL_EMIS + USE GLOBAL_CH4_MOD, ONLY : ASEASONAL_ANTHRO_EMIS + USE GLOBAL_CH4_MOD, ONLY : ASEASONAL_NATURAL_EMIS + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + !LOGICAL, SAVE :: FIRSTEMIS = .TRUE. + LOGICAL, SAVE :: LASTOFMONTH = .TRUE. + LOGICAL, SAVE :: LASTOFYEAR = .TRUE. + INTEGER :: I, J, I0, J0, M, IREF, JREF + + ! Local variables + REAL*8 :: E_CH4, DTSRCE, AREA_CM2 + REAL*8 :: CH4_EMIS_for_SF(IIPAR,JJPAR) + + + !================================================================= + ! EMISSCH4_ADJ begins here! + !================================================================= + + WRITE(6,*) '% --- ENTERING EMISSCH4_ADJ! ---' + + ! Initialize GLOBAL_CH4_ADJ_MOD variables + ! Do here because CHEMCH4 isn't called at first midnight + ! NO. Initialize global_ch4_adj_mod variables in chemch4_adj + ! because chemistry and emissions now have the same time step + ! and chemistry is called first (kjw, 12/2/2011). + !IF ( FIRSTEMIS ) THEN + !CALL INIT_GLOBAL_CH4_ADJ + !FIRSTEMIS=.FALSE. + !ENDIF + + ! Determine group (temporal) + M = GET_SCALE_GROUP() + ! Print out scaling info + WRITE(6,*) ' - READ / RESCALE CHEMISTRY: + & use SCALE_GROUP ', M + + ! Get nested-grid offsets + I0 = GET_XOFFSET() + J0 = GET_YOFFSET() + + + !=================================================================== + ! Emissions are read or calculated at the first of every: + ! 1) Emission time step - Natural Wetlands (from J Kaplan) + ! 2) Month - Biomass Burning and Rice + ! 3) Year - All other sources + ! + ! Emissions are stored in CH4_EMIS_ADJ(IIPAR,JJPAR,N). + ! Where N = 1:12 + ! 1. Total Emissions (including soil absorption, counted neg.) + ! 2. Oil and Gas Processing + ! 3. Coal Mining + ! 4. Livestock + ! 5. Waste + ! 6. Biofuel + ! 7. Rice + ! 8. Other Anthropogenic + ! 9. Biomass Burning + ! 10. Wetlands + ! 11. Soil Absorption + ! 12. Other Natural + ! + ! Emissions are then summed + ! (kjw, 6/4/09) + !=================================================================== + + ! Do Adjoint CH4 emissions! + + !4.1 Wetland Emissions (CH4_WTL, #10) + CALL WETLAND_EMIS( CH4_EMIS_ADJ ) + + + IF ( LASTOFMONTH ) THEN + + !4.2 Biomass Burning emissions (CH4_BBN, #9) + CALL BIOBURN_EMIS( CH4_EMIS_ADJ ) + + !4.3 Rice emissions (CH4_RIC, #7) + CALL RICE_EMIS( CH4_EMIS_ADJ ) + + ENDIF + + + IF ( LASTOFYEAR ) THEN + + !4.4 Biofuel emissions (CH4_BFL, #6) + !kjw replace with EDGARv4 biofuels in ASEASONAL_ANTHRO_EMIS + ! (kjw, 11/17/11) + !CALL BIOFUEL_EMIS( CH4_EMIS_ADJ ) + + !4.5 Aseasonal Anthropogenic emissions + ! (CH4_OAG, #2; CH4_COL, #3; CH4_LIV, #4; CH4_WST, #5; CH4_OTA, #8) + CALL ASEASONAL_ANTHRO_EMIS( CH4_EMIS_ADJ ) + + !4.6 Aseasonal Natural emissions (CH4_SAB, #11; CH4_OTN, #12) + CALL ASEASONAL_NATURAL_EMIS( CH4_EMIS_ADJ ) + + ENDIF + + + ! Total emission: sum of all emissions - (2*soil absorption) + ! We have to substract soil absorption twice because it is added + ! to other emissions in the SUM function. (ccc, 7/23/09) + CH4_EMIS_ADJ(:,:,1) = 0d0 + CH4_EMIS_ADJ(:,:,1) = SUM(CH4_EMIS_ADJ, 3) + & - (2 * CH4_EMIS_ADJ(:,:,11)) + + ! Select emissions to be optimized (all but soil absorption). + ! Exclude soil abs to prevent having negative scaling factors. + ! To do this, add the magnitude of soil absorption back to the total + CH4_EMIS_for_SF(:,:) = CH4_EMIS_ADJ(:,:,1) + & + CH4_EMIS_ADJ(:,:,11) + + ! DTSRCE is the number of seconds per emission timestep + DTSRCE = GET_TS_EMIS() * 60d0 + + ! Accumulate gradients + DO J = 1, JJPAR + JREF = J + J0 + + ! Get area [cm2] of each box for unit conversion + AREA_CM2 = GET_AREA_CM2( J ) + + DO I = 1, IIPAR + IREF = I + I0 + + ! Convert from [molec cm-2 s-1] --> [kg CH4] + E_CH4 = CH4_EMIS_for_SF(I,J) * DTSRCE + & * AREA_CM2 / XNUMOL_CH4 + + ! Calculate Gradients + EMS_SF_ADJ(I,J,M,ADCH4EMS) = EMS_SF_ADJ(I,J,M,ADCH4EMS) + + & STT_ADJ(I,J,1,1) * E_CH4 + + ENDDO + ENDDO + + + ! RESET LASTOF logicals + ! If 12am on Jan1, next time step in adjoint will be last of preceeding year + IF ( ITS_A_NEW_YEAR() ) THEN + LASTOFYEAR = .TRUE. + ELSE + LASTOFYEAR = .FALSE. + ENDIF + + ! If 12am on 1st of month, next time step in adjoint will be last of preceeding month + IF ( ITS_A_NEW_MONTH() ) THEN + LASTOFMONTH = .TRUE. + ELSE + LASTOFMONTH = .FALSE. + ENDIF + + + WRITE(6,'(a)') '% --- EXITING EMISSCH4_ADJ! ---' + + ! Return to calling program + END SUBROUTINE EMISSCH4_ADJ + + + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEMCH4_ADJ +! +!****************************************************************************** +! Subroutine CHEMCH4_ADJ does adjoint of CH4 chemistry +! (adj_group, kjw, 2/22/10) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE DIRECTORY_MOD, ONLY : OH_DIR + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT + USE TIME_MOD, ONLY : GET_MONTH + USE TRANSFER_MOD, ONLY : TRANSFER_2D, TRANSFER_3D + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE GLOBAL_OH_MOD, ONLY : GET_GLOBAL_OH, OH + USE GLOBAL_CH4_MOD, ONLY : CH4LOSS + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! LPAUSE + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + LOGICAL, SAVE :: FIRSTCHEM = .TRUE. + INTEGER :: L, NOHDO, LMN, M, I, J + REAL*4 :: ARRAY(IIPAR,JJPAR,LGLOB) + REAL*8 :: XTAU + + + !================================================================= + ! CHEMCH4_ADJ begins here! + !================================================================= + WRITE( 6, '(a)' ) '% --- ENTERING CHEMCH4_ADJ! ---' + + + ! Initialize GLOBAL_CH4_ADJ_MOD variables + ! Do here because chemistry called before emissions and both + ! have the same time step (kjw, 12/2/2011) + IF ( FIRSTCHEM ) THEN + CALL INIT_GLOBAL_CH4_ADJ + + ! Read Stratospheric loss rates + CH4LOSS(:,:,:,:) = 0d0 + CALL READ_CH4LOSS + + ENDIF + + + ! Get Average temp for the preceeding day + !CALL CH4_AVGTP_ADJ + + !================================================================ + ! (1) get parameterized OH fields or monthly mean fields. + ! + ! Variables of note: + ! --------------------------------------------------------------- + ! (1) BOH = storage array for OH fields. + ! + ! (2) NOHDO = switch + ! ONLY USE CASE 1 as of 5/28/08 (kjw) + ! = 1 : Get GEOS-Chem OH (v5-07-08) (kjw, 5/28/08) + ! + ! (3) TROPP = the vertical level of the tropopause. Above this + ! level, no [OH] is calculated. The user can feed this + ! SR a high value for LPAUSE which effectively turns this + ! option off (i.e., LPAUSE > MVRTBX). If the [OH] = -999 + ! then the [OH] was not calculated. + !================================================================ + + ! 3D OH Field + BOH(:,:,:,:) = 0d0 + + + ! Change value of NOHDO as listed above + NOHDO = 1 + + SELECT CASE ( NOHDO ) + + ! NOHDO = 1: GEOS-Chem OH v5-07-08 + CASE ( 1 ) + + ! If first of month, read monthly mean OH + IF ( FIRSTCHEM ) THEN + + ! Clear 3D OH field + BOH(:,:,:,:) = 0d0 + LMN = GET_MONTH() + + ! Loop over each month, reading OH + DO M=1,12 + + ! Global OH + CALL GET_GLOBAL_OH( M ) + + ! Assign to module variable BOH + BOH(:,:,:,M) = OH(:,:,:) + + ENDDO + + ENDIF + + CASE DEFAULT + WRITE( 6, '(a)' ) 'Invalid selection for NOHDO!' + WRITE( 6, '(a)' ) 'Halting execution in CHEMCH4!' + CALL GEOS_CHEM_STOP + + END SELECT + + + !================================================================= + ! (3) adjoint of CH4 chemistry in layers above tropopause. + !================================================================= + CALL CH4_STRAT_ADJ + + !================================================================= + ! (3) adjoint of rate of decay of CH4 by OH oxidation. + !================================================================= + CALL CH4_DECAY_ADJ + + + + ! Set FIRSTCHEM to FALSE + FIRSTCHEM = .FALSE. + + + ! Return to calling program + END SUBROUTINE CHEMCH4_ADJ + + +!------------------------------------------------------------------------------ + + SUBROUTINE CH4_DECAY_ADJ +! +!****************************************************************************** +! Subroutine CH4_DECAY_ADJ is the adjoint of decay rate of CH4 by OH. OH is the +! only sink for CH4 considered here. (jsw, bnd, bmy, 1/16/01, 7/20/04) +! +! The annual mean tropopause is stored in the LPAUSE array +! (from header file "CMN"). LPAUSE is defined such that: +! +! Levels 1 <= L <= LPAUSE(I,J) - 1 are tropospheric +! LPAUSE(I,J) <= L <= LLPAR are stratospheric +! +! We now use LPAUSE instead of NSKIPL to denote the strat/trop boundary. +! (bmy, 4/18/00) +! +! Monthly loss of CH4 is summed in TCH4(3) +! TCH4(3) = CH4 sink by OH +! +! Module Variables: +! ============================================================================ +! (1) BOH (REAL*8) : Array holding global OH concentrations +! (2) XNUMOL_CH4 (REAL*8) : Molec CH4 / kg CH4 +! +! NOTES: +! (1 ) Created by Bryan Duncan (1/99). Adapted for CH4 chemistry by +! James Wang (7/00). Inserted into module "global_ch4_mod.f" +! by Bob Yantosca. (bmy, 1/16/01) +! (2 ) CH4_DECAY is independent of "CMN_OH", "CMN_CO", and "CMN_CO_BUDGET". +! (bmy, 1/16/01) +! (3 ) Now use function GET_TS_CHEM from "time_mod.f" (bmy, 3/27/03) +! (4 ) Now references STT from "tracer_mod.f" (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : ADCH4EMS, EMS_SF_ADJ, STT_ADJ + USE DAO_MOD, ONLY : AIRVOL, AD, CONVERT_UNITS, T + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_NYMD, GET_NHMS + USE TRACER_MOD, ONLY : TCVV, N_TRACERS + USE TIME_MOD, ONLY : GET_MONTH + + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! LPAUSE + + ! Local variables + INTEGER :: I, J, L, LMN + REAL*8 :: DT, GCH4_ADJ, STT2GCH4, KRATE, TROPCH4 + + + !================================================================= + ! CH4_DECAY_ADJ begins here! + !================================================================= + + ! Chemistry timestep in seconds + DT = GET_TS_CHEM() * 60d0 + + ! Current month + LMN = GET_MONTH() + + !================================================================= + ! Compute decay of CH4 by OH in the troposphere + ! + ! The decay for CH4 is calculated by: + ! OH + CH4 -> CH3 + H2O + ! k = 2.45E-12 exp(-1775/T) + ! + ! This is from JPL '97. + ! JPL '00 & '06 do not revise '97 value. (jsw, kjw) + !================================================================= + + ! Convert STT_ADJ from [v/v] --> [kg] + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) + + + TROPCH4 = 0d0 + + DO L = 1, MAXVAL( LPAUSE ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Only consider tropospheric boxes + IF ( L < LPAUSE(I,J) ) THEN + + ! Use 24-hr avg temperature to calc. rate coeff. + ! citation needed + KRATE = 2.45d-12 * EXP( -1775d0 / T(I,J,L) ) + + ! Conversion from [kg/box] --> [molec/cm3] + ! [kg CH4/box] * [box/cm3] * XNUMOL_CH4 [molec CH4/kg CH4] + STT2GCH4 = 1d0 / AIRVOL(I,J,L) / 1d6 * XNUMOL_CH4 + + ! CH4 in [molec/cm3] + GCH4_ADJ = STT_ADJ(I,J,L,1) * STT2GCH4 + + ! Calculate new CH4 value: [CH4]=[CH4](1-k*[OH]*delta) + GCH4_ADJ = GCH4_ADJ * ( 1d0 - KRATE * BOH(I,J,L,LMN) * DT ) + + ! Convert back from [molec/cm3] --> [kg/box] + STT_ADJ(I,J,L,1) = GCH4_ADJ / STT2GCH4 + + ENDIF + ENDDO + ENDDO + ENDDO + + ! Convert STT_ADJ back from [kg] --> [v/v] + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) + + + ! Return to calling program + END SUBROUTINE CH4_DECAY_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_CH4LOSS +! +!***************************************************************************** +! Subroutine READ_CH4LOSS reads CH4 loss frequencies in the stratosphere. +! These values constitute a linearized stratospheric CH4 chemistry scheme. +! Loss frequencies from 4x5 degree output from the GMI model. Thanks to Lee +! Murray for the ch4 loss frequencies. (kjw, 11/19/2011) +! +! Module Variables: +! =========================================================================== +! (1) CH4LOSS (REAL*8) : Array containing ch4 loss frequencies for all 12 months [1/s] +! +! NOTES: +! (1 ) Created by Bryan Duncan (1/99). Adapted for CH4 chemistry by +! James Wang (6/8/00). Inserted into module "global_ch4_mod.f" +! by Bob Yantosca. (bmy, 1/16/01) +! (2 ) READ_CH4LOSS is independent of "F77_CMN_OH", "F77_CMN_CO", and "F77_CMN_CO_BUDGET". +! (bmy, 1/16/01) +! (3 ) ARRAY needs to be dimensioned (1,JJPAR,LGLOB) (bmy, 9/26/01) +! (4 ) Remove obsolete code from 9/01 (bmy, 10/24/01) +! (5 ) Now reference DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +! (6 ) Now reads data for both GEOS and GCAP grids (bmy, 8/16/05) +! (7 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (8 ) Treat MERRA in the same way as for GEOS-5 (bmy, 8/13/10) +!***************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_MODELNAME + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE TRANSFER_MOD, ONLY : TRANSFER_3D + + IMPLICIT NONE +# include "define.h" +# include "CMN_SIZE" + + ! Local variables + INTEGER :: I, J, L, M + REAL*4 :: ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: XTAU + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_CH4LOSS begins here! + ! + ! Read P(CO) for all 12 months + !================================================================= + ! Construct filename + FILENAME = TRIM( DATA_DIR ) // 'CH4/gmi.ch4loss.' // + & 'geos5_47L.' // get_res_ext() // '.bpch' +#if defined( GRID05x0666 ) && defined( NESTED_NA ) + FILENAME = '/met/gc/CH4/gmi.ch4loss.' // + & 'geos5_47L.05x0666_NA.bpch' +#endif + + WRITE( 6, 93 ) TRIM ( FILENAME ) + 93 FORMAT( ' - READ_CH4LOSS: Reading Ch4loss: ', a ) + CALL FLUSH( 6 ) + + ! Read data for each month + DO M = 1, 12 + + ! TAU value at the start of month M -- Use "generic" year 1985 + XTAU = GET_TAU0( M, 1, 1985 ) + + ! Read Loss frequencies in units of [1/s]. drevet. + CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, + & XTAU, IIPAR, JJPAR, + & LLPAR, ARRAY, QUIET=.TRUE. ) + + ! Place array into CH4LOSS module variable + CH4LOSS(:,:,:,M) = ARRAY(:,:,:) + + ENDDO + + ! Return to calling program + END SUBROUTINE READ_CH4LOSS + +!------------------------------------------------------------------------------ + + SUBROUTINE CH4_STRAT_ADJ +! +!***************************************************************************** +! Subroutine CH4_STRAT_ADJ is adjonit of loss of CH4 above tropopause. +! +! Production (mixing ratio/sec) rate provided by Dylan Jones. +! Only production by CH4 + OH is considered. +! +! The annual mean tropopause is stored in the LPAUSE array +! (from header file "CMN"). LPAUSE is defined such that: +! +! Levels 1 <= L <= LPAUSE(I,J) - 1 are tropospheric +! LPAUSE(I,J) <= L <= LLPAR are stratospheric (bmy, 4/18/00) +! +! NOTES: +! (1 ) Created by Bryan Duncan (1/99). Adapted for CH4 chemistry by +! James Wang (7/00). Inserted into module "global_ch4_mod.f" +! by Bob Yantosca. (bmy, 1/16/01) +! (2 ) CH4_STRAT is independent of "CMN_OH", "CMN_CO", and "CMN_CO_BUDGET". +! (bmy, 1/16/01) +! (3 ) Removed LMN from the arg list and made it a local variable. Now use +! functions GET_MONTH and GET_TS_CHEM from "time_mod.f" (bmy, 3/27/03) +! (4 ) Now references STT from "tracer_mod.f" (bmy, 7/20/04) +!***************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : AIRVOL + USE TIME_MOD, ONLY : GET_MONTH, GET_TS_CHEM + USE TRACER_MOD, ONLY : STT + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! STT, LPAUSE + + ! Local variables + INTEGER :: I, J, L, LMN + REAL*8 :: DT, GCH4, STT2GCH4, LRATE + CHARACTER*20 :: STT_TEST + CHARACTER*20 :: STT2GCH4_CHAR + + ! External functions + REAL*8, EXTERNAL :: BOXVL + + !================================================================= + ! CH4_STRAT_ADJ begins here! + !================================================================= + + ! Chemistry timestep [s] + DT = GET_TS_CHEM() * 60d0 + + ! Current month + LMN = GET_MONTH() + + !================================================================= + ! Loop over stratospheric boxes only + !================================================================= + DO L = MINVAL( LPAUSE ), LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + IF ( L >= LPAUSE(I,J) ) THEN + + ! Conversion factor [kg/box] --> [molec/cm3] + ! [kg/box] / [AIRVOL * 1e6 cm3] * [XNUMOL_CH4 molec/mole] + STT2GCH4 = 1d0 / AIRVOL(I,J,L) / 1d6 * XNUMOL_CH4 + + ! CH4 in [molec/cm3] + GCH4 = STT_ADJ(I,J,L,1) * STT2GCH4 + + ! Loss rate [molec/cm3/s] + LRATE = GCH4 * CH4LOSS( I,J,L,LMN ) + + ! CH4 in [molec/cm3] + GCH4 = GCH4 - ( LRATE * DT ) + +!kjw. Update stratospheric chem to use linearized CH4 loss frequencies +! (kjw, 11/19/11) +! ! Sum loss in TCH4(3) [molec CH4/box] in the stratosphere +! ! [molec/cm3] * [v/v/s] * [s] * [cm3/box] = [molec CH4/box] +! TCH4(I,J,L,3) = TCH4(I,J,L,3) + +! & ( BAIRDENS(I,J,L) * COPROD(J,L,LMN) * +! & DT * BOXVL(I,J,L) ) +! +! ! Calculate new CH4 value [molec CH4/cm3] in the stratosphere +! ! [v/v/s] * [s] * [molec/cm3] = [molec CH4/cm3] +! GCH4 = GCH4 - ( COPROD(J,L,LMN) * DT * BAIRDENS(I,J,L) ) +!kjw + + ! Convert back from [molec CH4/cm3] --> [kg/box] + STT_ADJ(I,J,L,1) = GCH4 / STT2GCH4 + + +!kjw. With new linearized chemistry, STT should never be negative +! (kjw, 11/19/11) +! IF ( STT(I,J,L,1) < 0 ) THEN +! STT(I,J,L,1)=0 +! ENDIF +!kjw + + ENDIF + ENDDO + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE CH4_STRAT_ADJ + +!------------------------------------------------------------------------------ + +! SUBROUTINE CH4_STRAT +!! +!!***************************************************************************** +!! Subroutine CH4_STRAT calculates uses production rates for CH4 to +!! calculate loss of CH4 in above the tropopause. +!! (jsw, bnd, bmy, 1/16/01, 7/20/04) +!! DO NOT CALL IN ADJOINT SIMULATION (kjw, 7/6/11) +!! +!! Production (mixing ratio/sec) rate provided by Dylan Jones. +!! Only production by CH4 + OH is considered. +!! +!! The annual mean tropopause is stored in the LPAUSE array +!! (from header file "CMN"). LPAUSE is defined such that: +!! +!! Levels 1 <= L < LPAUSE(I,J) - 1 are tropospheric +!! LPAUSE(I,J) <= L <= LLPAR are stratospheric (bmy, 4/18/00) +!! +!! NOTES: +!! (1 ) Created by Bryan Duncan (1/99). Adapted for CH4 chemistry by +!! James Wang (7/00). Inserted into module "global_ch4_mod.f" +!! by Bob Yantosca. (bmy, 1/16/01) +!! (2 ) CH4_STRAT is independent of "CMN_OH", "CMN_CO", and "CMN_CO_BUDGET". +!! (bmy, 1/16/01) +!! (3 ) Removed LMN from the arg list and made it a local variable. Now use +!! functions GET_MONTH and GET_TS_CHEM from "time_mod.f" (bmy, 3/27/03) +!! (4 ) Now references STT from "tracer_mod.f" (bmy, 7/20/04) +!!***************************************************************************** +!! +! ! References to F90 modules +! USE ADJ_ARRAYS_MOD, ONLY : ADCH4EMS, EMS_SF_ADJ, STT_ADJ +! USE DAO_MOD, ONLY : AIRVOL, AD +! USE TIME_MOD, ONLY : GET_MONTH, GET_TS_CHEM +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN" ! LPAUSE +! +! ! Local variables +! LOGICAL, SAVE :: FIRSTCHEM +! INTEGER :: I, J, L, LMN +! REAL*8 :: DT, GCH4_ADJ, STT2GCH4 +! REAL*8, PARAMETER :: WTAIR = 28.966d0 +! +! ! External functions +! REAL*8, EXTERNAL :: BOXVL +! +! !================================================================= +! ! CH4_STRAT begins here! +! !================================================================= +! +! !================================================================= +! ! (1) If first time step, read LCO data +! !================================================================= +! IF ( FIRSTCHEM ) THEN +! +! ! Zero CO Production array +! COPROD(:,:,:) = 0d0 +! +! ! Read zonally-averaged CO production [v/v/s] +! CALL READ_COPROD +! +! ENDIF +! +! ! Chemistry timestep [s] +! DT = GET_TS_CHEM() * 60d0 +! +! ! Current month +! LMN = GET_MONTH() +! +! +! !================================================================= +! ! (2) Calculate each box's air density [molec/cm3] +! !================================================================= +! +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! BAIRDENS(I,J,L) = AD(I,J,L) * 1000d0 / BOXVL(I,J,L) * +! & 6.023D23 / WTAIR +! ENDDO +! ENDDO +! ENDDO +! +! +! !================================================================= +! ! (3) Calculate stratospheric CH4 loss from COPRODuction +! ! Loop over stratospheric boxes only +! !================================================================= +! DO L = MINVAL( LPAUSE ), LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! IF ( L >= LPAUSE(I,J) ) THEN +! +! ! Conversion factor [kg/box] --> [molec/cm3] +! ! [kg/box] / [AIRVOL * 1e6 cm3] * [XNUMOL_CH4 molec/mole] +! STT2GCH4 = 1d0 / AIRVOL(I,J,L) / 1d6 * XNUMOL_CH4 +! +! ! CH4 in [molec/cm3] +! GCH4_ADJ = STT_ADJ(I,J,L,1) * STT2GCH4 +! +! ! Calculate new CH4 value [molec CH4/cm3] in the stratosphere +! ! [v/v/s] * [s] * [molec/cm3] = [molec CH4/cm3] +! GCH4_ADJ = GCH4_ADJ - +! & ( COPROD(J,L,LMN) * DT * BAIRDENS(I,J,L) ) +! +! ! Convert back from [molec CH4/cm3] --> [kg/box] +! STT_ADJ(I,J,L,1) = GCH4_ADJ / STT2GCH4 +! +! ENDIF +! ENDDO +! ENDDO +! ENDDO +! +! ! Set FIRSTCHEM to FALSE +! FIRSTCHEM = .FALSE. +! +! ! Return to calling program +! END SUBROUTINE CH4_STRAT +! +! +! +!------------------------------------------------------------------------------ + + SUBROUTINE READ_COPROD +! +!***************************************************************************** +! Subroutine READ_COPROD reads production and destruction rates for CO in +! the stratosphere. (bnd, bmy, 1/17/01, 10/3/05) +! +! Module Variables: +! =========================================================================== +! (1) COPROD (REAL*8) : Array containing P(CO) for all 12 months [v/v/s] +! +! NOTES: +! (1 ) Created by Bryan Duncan (1/99). Adapted for CH4 chemistry by +! James Wang (6/8/00). Inserted into module "global_ch4_mod.f" +! by Bob Yantosca. (bmy, 1/16/01) +! (2 ) READ_COPROD is independent of "CMN_OH", "CMN_CO", and "CMN_CO_BUDGET". +! (bmy, 1/16/01) +! (3 ) ARRAY needs to be dimensioned (1,JGLOB,LGLOB) (bmy, 9/26/01) +! (4 ) Remove obsolete code from 9/01 (bmy, 10/24/01) +! (5 ) Now reference DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +! (6 ) Now reads data for both GEOS and GCAP grids (bmy, 8/16/05) +! (7 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!***************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_MODELNAME + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE TRANSFER_MOD, ONLY : TRANSFER_ZONAL + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + INTEGER :: M + REAL*4 :: ARRAY(1,JGLOB,LGLOB) + REAL*4 :: DUMMY_IN(JGLOB,LGLOB) + REAL*8 :: XTAU + REAL*8 :: DUMMY_OUT(JGLOB,LGLOB) + + + !================================================================= + ! READ_COPROD begins here! + ! + ! Read P(CO) for all 12 months + !================================================================= + DO M = 1, 12 + + ! TAU value at the start of month M -- Use "generic" year 1985 + XTAU = GET_TAU0( M, 1, 1985 ) + + ! Construct filename + FILENAME = TRIM( DATA_DIR ) // 'pco_lco_200203/' // + & 'COprod.' // GET_NAME_EXT() // '.' // GET_RES_EXT() + + + WRITE( 6, 93 ) TRIM ( FILENAME ) + 93 FORMAT( ' - READ_COPROD: Reading COprod: ', a ) + CALL FLUSH( 6 ) + + +cdrevet + ! Read P(CO) in units of [v/v/s] + CALL READ_BPCH2( FILENAME, 'PORL-L=$', 9, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) +cdrevet + + ! use 2D arrays for TRANSFER ZONAL + DUMMY_IN(:,:) = ARRAY(1,:,:) + + ! Copy REAL*4 to REAL*8 data, and resize from (JGLOB,LGLOB) + ! to (JJPAR,LLPAR) -- vertically regrid if necessary + CALL TRANSFER_ZONAL( DUMMY_IN, DUMMY_OUT ) + + COPROD(:,:,M) = DUMMY_OUT(:,:) + + ENDDO + + + ! Return to calling program + END SUBROUTINE READ_COPROD + + +!------------------------------------------------------------------------------ + + SUBROUTINE CH4_AVGTP_ADJ +! +!****************************************************************************** +! Subroutine CH4_AVGTP gets the 24-h average surface pressure and temperature +! needed for the CH4 simulation. (jsw, bnd, bmy, 1/16/01, 7/20/04) +! +! NOTES: +! (1 ) Created by Bryan Duncan (1/99). Adapted for CH4 chemistry and +! placed into module "global_ch4_mod.f" by Bob Yantosca. (bmy, 1/16/01) +! (2 ) CH4_AVGTP is independent of "CMN_OH", "CMN_CO", and "CMN_CO_BUDGET". +! (bmy, 1/16/01) +! (3 ) Removed duplicate definition for NTDT, NMIN (bmy, 11/15/01) +! (4 ) Removed PS from argument list. Now use P(I,J)+PTOP instead of +! PS, this ensures that we have consistency between P and AD. +! (bmy, 4/11/02) +! (5 ) Removed obsolete code (bmy, 6/27/02) +! (6 ) Now uses GET_PCENTER from "pressure_mod.f" to return the pressure +! at the midpoint of the box (I,J,L). Also added parallel DO-loops. +! Updated comments. (dsa, bdf, bmy, 8/21/02) +! (7 ) Now reference T from "dao_mod.f". Now reference GEOS_CHEM_STOP from +! "error_mod.f" (bmy, 10/15/02) +! (8 ) Removed NTDT, NMIN from the arg list. Now uses functions GET_TS_DYN, +! GET_TS_CHEM, and GET_ELAPSED_MIN from "time_mod.f" (bmy, 3/27/03) +! (9 ) Remove reference to CMN, it's not needed (bmy, 7/20/04) +! (10) Modify from CH4_AVGTP_ADJ for compatability with the adjoint (kjw, 2/22/10) +!****************************************************************************** +! + ! References to F90 modules + USE TIME_MOD, ONLY : GET_TS_DYN, GET_TS_CHEM + USE TIME_MOD, ONLY : GET_NYMD, GET_NYMDe, GET_NYMDb + USE TIME_MOD, ONLY : GET_NHMS, GET_TIME_BEHIND_ADJ + USE DAO_MOD, ONLY : T + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + CHARACTER(LEN=255) :: PATH + INTEGER :: I, NYMD, NHMS, NDYN, TAG, INFO(3) + INTEGER :: NYMDp, NHMSp, countit + REAL*8 :: Temp(IIPAR, JJPAR, LLPAR) + REAL*8 :: result(2) + + !================================================================= + ! CH4_AVGTP_ADJ begins here! + !================================================================= + + WRITE(6,'(a)') ' % CH4_AVGTP_ADJ begins' + + ! Initialize Tavg_adj for the current time step + Tavg_adj(:,:,:) = 0d0 + + ! NDYN = # of dynamics time steps in each chemical time step + NDYN = GET_TS_CHEM() / GET_TS_DYN() + + ! If 1 day from beginning of the simulation + IF ( GET_NYMD() .EQ. GET_NYMDb()+1 ) NDYN = NDYN + 1 + + countit=0 + + DO I = 1,NDYN + + ! Initialize T + !T(:,:,:) = 0d0 + + ! Get time stamps at current and every dyn time step during the day + result = GET_TIME_BEHIND_ADJ( GET_TS_DYN()*(I-1) ) + + ! NYMD, NHMS, TAG + NYMD = result(1) + NHMS = result(2) + + ! Get file unit number for A6 file to be opened + ! Such that 20 <= IU_NUM <= 64 .OR. IU_NUM => 100 (kjw, 2/23/10) + ! Check available unit numbers in file_mod.f + ! IU_NUM = 52 + + ! Find date of closest A-6 file to open and which occurence of Temp to use + INFO = FIND_CLOSEST_A6( NYMD, NHMS ) + NYMDp = INFO(1) + NHMSp = INFO(2) + TAG = INFO(3) + + + ! Open A6 file to read Temperature data + CALL OPEN_A6_CH4_ADJ( NYMDp, NHMSp ) + + + ! If the desired A-6 file is already in use, use DAO_MOD, ONLY : T + IF ( IU_A6_CH4_ADJ == 72 ) THEN + + Tavg_adj(:,:,:) = Tavg_adj(:,:,:) + T(:,:,:) + countit=countit+1 + + ELSE IF ( IU_A6_CH4_ADJ == 52 ) THEN + + ! READ A6 fields with temp data + CALL READ_A6_CH4_ADJ( NYMDp, NHMSp, TAG, Temp ) + + ! Collect temperature data + Tavg_adj(:,:,:) = Tavg_adj(:,:,:) + Temp(:,:,:) + countit=countit+1 + + ! Close file we just opened + CLOSE( IU_A6_CH4_ADJ ) + + ENDIF + + ENDDO + + ! Average Temperature information + Tavg_adj(:,:,:) = Tavg_adj(:,:,:) / NDYN + + + WRITE(6,'(a)') ' % CH4_AVGTP_ADJ ends' + + ! Return to calling program + END SUBROUTINE CH4_AVGTP_ADJ + + + +!------------------------------------------------------------------------------ + +! SUBROUTINE UPDATE_LASTOF +! +!******************************************************************************** + +! Subroutine UPDATE_LASTOF determines whether the next time step will be the last +! of a month (kjw, 2/22/10) +! +! NOTES +! +!******************************************************************************** + + + ! If 12am on Jan1, next time step in adjoint will be last of preceeding year +! IF ( ITS_A_NEW_YEAR() ) THEN +! LASTOFYEAR = .TRUE. +! ELSE +! LASTOFYEAR = .FALSE. +! ENDIF + + ! If 12am on 1st of month, next time step in adjoint will be last of preceeding month +! IF ( TIS_A_NEW_MONTH() ) THEN +! LASTOFMONTH = .TRUE. +! ELSE +! LASTOFMONTH = .TRUE. +! ENDIF + + + + ! Return to calling program +! END SUBROUTINE UPDATE_LASTOF + + + + +!------------------------------------------------------------------------------ + + SUBROUTINE OPEN_A6_CH4_ADJ( NYMDp, NHMSp ) +! +!****************************************************************************** +! Subroutine OPEN_A6_CH4_ADJ opens the A-6 met fields file for date NYMD and +! time NHMS for use by CH4 adjoint simulation. Based on GET_A6_FIELDS. +! (bmy, bdf, 6/15/98, 2/12/09), (kjw, 2/23/10) +! +! Difference with OPEN_A6_FIELDS is that this uses a different file unit +! number than IU_A6. File unit # is a parameter, IU_A6_CH4_ADJ +! +! Arguments as input: +! =========================================================================== +! (1 ) NYMD (INTEGER) : Current value of YYYYMMDD +! (2 ) NHMS (INTEGER) : Current value of HHMMSS +! +! NOTES: +! (1 ) Adapted from OPEN_MET_FIELDS of "dao_read_mod.f" (bmy, 6/19/03) +! (2 ) Now opens either zipped or unzipped files (bmy, 12/11/03) +! (3 ) Now skips past the GEOS-4 ident string (bmy, 12/12/03) +! (4 ) Now references "directory_mod.f" instead of CMN_SETUP. Also now +! references LUNZIP from "logical_mod.f". Also now prevents EXPAND_DATE +! from overwriting Y/M/D tokens in directory paths. (bmy, 7/20/04) +! (5 ) Now use FILE_EXISTS from "file_mod.f" to determine if file unit IU_A6 +! refers to a valid file on disk (bmy, 3/23/05) +! (6 ) Now modified for GEOS-5 and GCAP met fields (swu, bmy, 5/25/05) +! (7 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (8 ) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +! (9 ) Now get the # of A-3 fields from the file ident string (bmy, 10/7/08) +! (10) Set N_A6_FIELDS=21 for GEOS-5 and IN_CLOUD_OD (jmao, bmy, 2/12/09) +!****************************************************************************** + + + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE DIRECTORY_MOD, ONLY : GEOS_4_DIR, GEOS_5_DIR, TEMP_DIR + USE DIRECTORY_MOD, ONLY : GEOS_FP_DIR !! (lzh, 07/10/2014) geos-fp + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LUNZIP + USE FILE_MOD, ONLY : IOERROR, FILE_EXISTS + USE TIME_MOD, ONLY : EXPAND_DATE, GET_NYMD, GET_NHMS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: NYMDp, NHMSp + + ! Local variables + INTEGER :: IOS + CHARACTER(LEN=8) :: IDENT + CHARACTER(LEN=255) :: A6_FILE + CHARACTER(LEN=255) :: A6_NOW + CHARACTER(LEN=255) :: GEOS_DIR + CHARACTER(LEN=255) :: PATH + + !================================================================= + ! OPEN_A6_FIELDS begins here! + !================================================================= + + + ! Get Filename + ! ---------------------------------------------------------------- +#if defined( GEOS_4 ) + + ! Strings for directory & filename + GEOS_DIR = TRIM( GEOS_4_DIR ) + A6_FILE = 'YYYYMMDD.a6.' // GET_RES_EXT() + A6_NOW = 'YYYYMMDD.a6.' // GET_RES_EXT() + +#elif defined( GEOS_5 ) + + ! Strings for directory & filename + GEOS_DIR = TRIM( GEOS_5_DIR ) + A6_FILE = 'YYYYMMDD.a6.' // GET_RES_EXT() + A6_NOW = 'YYYYMMDD.a6.' // GET_RES_EXT() + +#endif + + ! Replace date tokens + CALL EXPAND_DATE( GEOS_DIR, NYMDp, NHMSp ) + CALL EXPAND_DATE( A6_FILE, NYMDp, NHMSp ) + CALL EXPAND_DATE( A6_NOW, GET_NYMD(), GET_NHMS() ) + + print*,'NYMD and NHMS right now ',GET_NYMD(),GET_NHMS() + print*,'NYMDp and NHMSp of file to open ', NYMDp,NHMSp + + ! If the A-6 file is already open, return to calling program + IF ( TRIM( A6_FILE ) == TRIM( A6_NOW ) ) THEN + print*,'This file is already open',TRIM(A6_NOW) + print*,'Using previously opened A-6 file...' + IU_A6_CH4_ADJ = 72 + RETURN + ELSE + print*,'We have to open a new A-6 file: ',TRIM(A6_NOW) + IU_A6_CH4_ADJ = 52 + ENDIF + + ! If unzipping, open GEOS-1 file in TEMP dir + ! If not unzipping, open GEOS-1 file in DATA dir + IF ( LUNZIP ) THEN + PATH = TRIM( TEMP_DIR ) // TRIM( A6_FILE ) + ELSE + PATH = TRIM( DATA_DIR ) // + & TRIM( GEOS_DIR ) // TRIM( A6_FILE ) + ENDIF + + ! Make sure the file unit is valid before we open the file + IF ( .not. FILE_EXISTS( IU_A6_CH4_ADJ ) ) THEN + CALL ERROR_STOP( 'Could not find file!', + & 'OPEN_A6_FIELDS (a6_read_mod.f)' ) + ENDIF + + ! Open the file + ! ---------------------------------------------------------------- + ! Hardwire unit number to not conflict with current IU_A6 (kjw, 2/23/10) + OPEN( UNIT = IU_A6_CH4_ADJ, FILE = TRIM( PATH ), + & STATUS = 'OLD', ACCESS = 'SEQUENTIAL', + & FORM = 'UNFORMATTED', IOSTAT = IOS ) + + IF ( IOS /= 0 ) THEN + CALL IOERROR( IOS, IU_A6_CH4_ADJ, 'open_a6_fields:1' ) + ENDIF + + ! Skip past the ident string + READ( IU_A6_CH4_ADJ, IOSTAT=IOS ) IDENT + + ! Echo info + WRITE( 6, 100 ) TRIM( PATH ) + 100 FORMAT( ' - Opening: ', a ) + + + ! Return to calling program + END SUBROUTINE OPEN_A6_CH4_ADJ + + +!----------------------------------------------------------------------------- + + SUBROUTINE READ_A6_CH4_ADJ( NYMDp, NHMSp, TAG, Temp ) +! +!****************************************************************************** +! Subroutine READ_A6_CH4_ADJ reads A-6 (avg 6-hr) met fields from disk. +! (bmy, 6/5/98, 3/28/08) +! +! For CH4 adjoint simulation, hardwire file unit # as a parameter +! +! Arguments as input: +! =========================================================================== +! (1 ) NYMD : YYYYMMDD +! (2 ) NHMS : and HHMMSS of A-6 met fields to be accessed +! +! A-6 Met Fields as Output (Optional Arguments): +! ============================================================================ +! (1) T : (3-D) Temperature [K] +! +! NOTES: +! (1 ) Adapted from READ_A6 of "dao_read_mod.f" (bmy, 6/19/03) +! (2 ) Now use function TIMESTAMP_STRING from "time_mod.f" for formatted +! date/time output. (bmy, 10/28/03) +! (3 ) Now compute CLDTOPS using ZMMU for GEOS-4 (bmy, 3/4/04) +! (4 ) Now modified for GEOS-5 and GCAP fields. Added DETRAINE, +! DETRAINN, DNDE, DNDN, ENTRAIN, UPDE, UPDN as optional arguments. +! Now references "CMN_DIAG". (swu, bmy, 5/25/05) +! (5 ) Bug fix in ND66 diagnostic for GEOS-4 (bmy, 2/1/06) +! (6 ) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +! (7 ) Now set negative SPHU to a small positive # (1d-32) instead of zero, +! so as not to blow up logarithms (bmy, 9/8/06) +! (8 ) Add CMFMC, DQIDTMST, DQLDTMST, DQRCON, DQRLSC, DQVDTMST, MFXC, MFYC, +! MFZ, PLE, PV, RH, TAUCLI, and TAUCLW as optional arguments. Also +! update the CASE statement accordingly for GEOS-5 met fields. +! Now reference TRANSFER_3D_Lp1 from "transfer_mod.f". Now convert +! GEOS-5 specific humidity from [kg/kg] to [g/kg] for compatibility +! with existing routines. Also recognize EPV, which is an alternate +! name for PV. Bug fix: convert GEOS-5 RH from unitless to %. +! (phs, bmy, 3/28/08) +! (8 ) Now get the # of A-6 fields from the file ident string (bmy, 10/7/08) +!****************************************************************************** +! + ! References to F90 modules + USE DIAG_MOD, ONLY : AD66, AD67 + USE FILE_MOD, ONLY : IOERROR + USE TIME_MOD, ONLY : SET_CT_A6, TIMESTAMP_STRING + USE TRANSFER_MOD, ONLY : TRANSFER_A6, TRANSFER_3D_Lp1 + USE TRANSFER_MOD, ONLY : TRANSFER_3D, TRANSFER_G5_PLE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND66, ND67 +# include "CMN_GCTM" ! g0 + + ! Arguments + INTEGER, INTENT(IN) :: NYMDp, NHMSp, TAG + REAL*8, INTENT(OUT) :: Temp(IIPAR,JJPAR,LLPAR) + + ! Local variables + INTEGER :: IOS + REAL*4 :: D(IGLOB,JGLOB,LGLOB) + CHARACTER(LEN=8) :: NAME + INTEGER :: XYMD, XHMS, NFOUND + + !================================================================= + ! READ_A6 begins here! + !================================================================= + + ! Number of A-6 fields. + ! We only want 1: temperature + !N_A6 = 1 DON'T NEED + + ! Zero number of fields that we have found + !NFOUND = 0 DON'T NEED + + !================================================================= + ! Read the A-6 fields from disk + !================================================================= + + ! Count # of times we find temperature + NFOUND = 0 + + ! Read each available data set in the file, but only save Temperature + DO + + ! Read A-6 field name + READ( IU_A6_CH4_ADJ, IOSTAT=IOS ) NAME + !print*, 'A6 NAME : ', NAME + + ! IOS < 0: End-of-file; make sure we've found + ! all the A-6 fields before exiting this loop + IF ( IOS < 0 ) EXIT + + ! IOS > 0: True I/O Error, stop w/ error msg + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_A6_CH4_ADJ, + & 'read_a6_ch4_adj:1' ) + + ! Examine the name of field + SELECT CASE ( TRIM( NAME ) ) + + ! If we've found temperature + CASE( 'T' ) + + ! Increase count + NFOUND = NFOUND + 1 + + IF ( NFOUND == TAG ) THEN + + print*,'% --- READ_A6_CH4_ADJ : Found T field desired' + + ! Read into array + READ( IU_A6_CH4_ADJ, IOSTAT=IOS ) XYMD, XHMS, D + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_A6_CH4_ADJ, + & 'read_a6_ch4_adj:29' ) + + !IF ( CHECK_TIME( XYMD, XHMS, NYMD, NHMS ) ) THEN + ! IF ( PRESENT( T ) ) CALL TRANSFER_3D( D, T ) + CALL TRANSFER_3D( D, Temp ) + !ENDIF + + ! Return to Calling Program + RETURN + + ELSE + + print*,' % --- READ_A6_CH4_ADJ : Not Correct T field' + + ! Read into array + READ( IU_A6_CH4_ADJ, IOSTAT=IOS ) XYMD, XHMS, D + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_A6_CH4_ADJ, + & 'read_a6_ch4_adj:29' ) + + ENDIF + + ! If field is not temperature -- skip over + CASE DEFAULT + !WRITE( 6, '(a)' ) 'Searching for next A-6 field!' + !WRITE( 6, '(2a)' ) 'THIS name = ',TRIM(NAME) + !print*,'LLPAR = ',LLPAR + !print*,'LGLOB = ',LGLOB + READ( IU_A6_CH4_ADJ, IOSTAT=IOS ) XYMD, XHMS, D + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_A6_CH4_ADJ, + & 'read_a6_ch4_adj:41' ) + + END SELECT + + ENDDO + + ! Return to calling program + END SUBROUTINE READ_A6_CH4_ADJ + + + +!------------------------------------------------------------------------------ + + FUNCTION FIND_CLOSEST_A6( NYMD, NHMS ) RESULT( INFO ) +! +!******************************************************************************** +! Subroutine FIND_CLOSEST_A6 finds the date and time of the nearest A-6 met field +! (kjw, 2/24/10) +! +! NOTES +! time tag, A6_TIME(3), tells us which occurence of A-6 Temperature we want (1st-4th) +! +!******************************************************************************** + + ! Reference to f90 modules + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + + +# include "CMN_SIZE" ! Size + + ! Arguments + INTEGER, INTENT(IN) :: NYMD, NHMS + + ! Output + INTEGER :: INFO(3) + + ! Local Variables + CHARACTER(LEN=6) :: CNHMS +! CHARACTER(LEN=2) :: CHH +! CHARACTER(LEN=2) :: CMM +! INTEGER :: HH,MM,NMIN + + + !============================================================ + ! FIND_CLOSEST_A6 begins here! + !============================================================ + + ! If 12-2:59am + IF ( ( NHMS >= 000000 ) .AND. ( NHMS <= 025959 ) ) THEN + + ! NYMD remains the same + INFO(1) = NYMD + + ! NHMS = 6am + INFO(2) = 000000 + + ! Set time tag + INFO(3) = 1 + + ! If 3-8:59am + ELSE IF ( ( NHMS >= 030000 ) .AND. ( NHMS <= 085959 ) ) THEN + + ! NYMD remains the same + INFO(1) = NYMD + + ! NHMS = 6am + INFO(2) = 060000 + + ! Set time tag + INFO(3) = 2 + + ! If 9am-2:59pm + ELSE IF ( ( NHMS >= 090000 ) .AND. ( NHMS <= 145959 ) ) THEN + + ! NYMD remains the same + INFO(1) = NYMD + + ! NHMS = 12pm + INFO(2) = 120000 + + ! Set time tag + INFO(3) = 3 + + ! If 3pm-8:59pm + ELSE IF ( ( NHMS >= 150000 ) .AND. ( NHMS <= 205959 ) ) THEN + + ! NYMD remains the same + INFO(1) = NYMD + + ! NHMS = 12pm + INFO(2) = 180000 + + ! Set time tag + INFO(3) = 4 + + ! If 9pm-11:59pm + ELSE IF ( ( NHMS >= 210000 ) .AND. ( NHMS <= 235959 ) ) THEN + + ! Since calling at midnight, these values should be current time + INFO(1) = GET_NYMD() + INFO(2) = GET_NHMS() + + ! Set time tag + INFO(3) = 1 + + ! We should find how many minutes behind current time is NYMD and NHMS + ! Turn NHMS into a string + !WRITE( CNHMS, '(i6)' ) NHMS + + ! Get Hour and Minute values from this + !CHH = CNHMS(1:2) + !CMM = CNHMS(3:4) + !READ( CHH, * ) HH + !READ( CMM, * ) MM + + ! Get number of minutes from midnight + !NMIN = 60 * (24 - HH) + (60 - MM) - 60 + + ! Get proper date stamp for midnight on the next day + !INFO = GET_TIME_AHEAD( NMIN ) + + ENDIF + RETURN + + + ! Return to calling program + END FUNCTION FIND_CLOSEST_A6 + + +!------------------------------------------------------------------------------ + + FUNCTION GET_SCALE_GROUP( ) RESULT( CURRENT_GROUP ) +! +!******************************************************************************** +! Subroutine GET_SCALE_GROUP determines which predifined scaling index corresponds +! to the current time and location (dkh, 12/02/04) +! +! NOTES +! (1 ) CURRENT_GROUP is currently only a function of TAU +! (2 ) Get rid of I,J as argument. (dkh, 03/28/05) +! +!******************************************************************************** + + ! Reference to f90 modules + USE TIME_MOD, ONLY : GET_TAU, GET_TAUe, GET_TAUb, GET_MONTH + USE ADJ_ARRAYS_MOD, ONLY: MMSCL + +# include "CMN_SIZE" ! Size stuff + + ! Arguments + INTEGER :: I, J + + ! Local Variables + REAL*8 :: TOTAL_HR, CURRENT_HR, GROUP_LENGTH + REAL*8 :: TAU, TAUe, TAUb + + ! Function variable + INTEGER :: CURRENT_GROUP + LOGICAL, SAVE :: MONTHLY = .TRUE. + INTEGER, SAVE :: MONTH_SAVE + INTEGER, SAVE :: GROUP_SAVE + LOGICAL, SAVE :: FIRST = .TRUE. + + !============================================================ + ! GET_SCALE_GROUP begins here! + !============================================================ + + ! Currently there is no spatial grouping + + ! Determine temporal grouping + IF ( MMSCL == 1 ) THEN + CURRENT_GROUP = 1 + RETURN + ENDIF + + IF ( MONTHLY ) THEN + IF (FIRST) THEN + MONTH_SAVE = GET_MONTH() + CURRENT_GROUP = MMSCL + GROUP_SAVE = MMSCL + FIRST = .FALSE. + ENDIF + IF ( MONTH_SAVE /= GET_MONTH() ) THEN + MONTH_SAVE = GET_MONTH() + GROUP_SAVE = GROUP_SAVE - 1 + CURRENT_GROUP = GROUP_SAVE + ELSE + CURRENT_GROUP = GROUP_SAVE + ENDIF + + ELSE + ! Retrieve time parameters + TAUe = GET_TAUe() + TAUb = GET_TAUb() + TAU = GET_TAU() + TOTAL_HR = TAUe - TAUb + CURRENT_HR = TAU - TAUb + + + ! The last time step always belongs to the last group + IF ( TAU == TAUe ) THEN + CURRENT_GROUP = MMSCL + RETURN + ELSE + + ! Determine the length of each group + GROUP_LENGTH = REAL( TOTAL_HR / MMSCL ) + + ! Index is the current time divided by the group length, plus one + CURRENT_GROUP = SNGL( CURRENT_HR / GROUP_LENGTH ) + 1 + + ENDIF + + ENDIF + + END FUNCTION GET_SCALE_GROUP + + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_GLOBAL_CH4_ADJ +! +!****************************************************************************** +! Subroutine INIT_GLOBAL_CH4 allocates and zeroes module arrays. +! (bmy, 1/16/01, 10/15/02) +! +! NOTES: +! (1 ) Now references ALLOC_ERR from "error_mod.f" (bmy, 10/15/02) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" +# include "CMN_DIAG" + + ! Local variables + INTEGER :: AS + LOGICAL, SAVE :: FIRST = .TRUE. + + + ! If NOT first, return + IF ( FIRST==.FALSE. ) RETURN + + + ALLOCATE( BAIRDENS( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BAIRDENS' ) + BAIRDENS = 0d0 + + ALLOCATE( BOH( IIPAR, JJPAR, LLPAR, 12 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BOH' ) + BOH = 0d0 + + ALLOCATE( CH4LOSS( IIPAR, JJPAR, LLPAR, 12 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH4LOSS' ) + CH4LOSS = 0d0 + + ALLOCATE( COPROD( JJPAR, LLPAR, 12 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COPROD' ) + COPROD = 0d0 + + ALLOCATE( TAVG_ADJ( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TAVG_ADJ' ) + TAVG_ADJ = 0d0 + + ALLOCATE( CH4_EMIS_ADJ( IIPAR, JJPAR, PD58), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH4_EMIS_ADJ' ) + CH4_EMIS_ADJ = 0d0 + + + ! We've now initialized, do not attempt again! + FIRST = .FALSE. + + ! Return to calling program + END SUBROUTINE INIT_GLOBAL_CH4_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_GLOBAL_CH4_ADJ +! +!****************************************************************************** +! Subroutine CLEANUP_GLOBAL_CH4 deallocates module arrays. (bmy, 1/16/01) +!****************************************************************************** + + + IF ( ALLOCATED( BAIRDENS ) ) DEALLOCATE( BAIRDENS ) + IF ( ALLOCATED( BOH ) ) DEALLOCATE( BOH ) + IF ( ALLOCATED( CH4LOSS ) ) DEALLOCATE( CH4LOSS ) + IF ( ALLOCATED( COPROD ) ) DEALLOCATE( COPROD ) + IF ( ALLOCATED( Tavg_adj ) ) DEALLOCATE( Tavg_adj ) + IF ( ALLOCATED( CH4_EMIS_ADJ ) ) DEALLOCATE( CH4_EMIS_ADJ ) + + + END SUBROUTINE CLEANUP_GLOBAL_CH4_ADJ + +!------------------------------------------------------------------------------ + + + ! End of module + END MODULE GLOBAL_CH4_ADJ_MOD diff --git a/code/adjoint/input_adj_mod.f b/code/adjoint/input_adj_mod.f new file mode 100644 index 0000000..404e11e --- /dev/null +++ b/code/adjoint/input_adj_mod.f @@ -0,0 +1,4147 @@ +!$Id: input_adj_mod.f,v 1.21 2012/08/10 22:08:22 nicolas Exp $ + MODULE INPUT_ADJ_MOD +! +!****************************************************************************** +! Module INPUT_ADJ_MOD reads the GEOS-Chem ADJOINT input file (input.gcadj) +! at the start of the inverse run and passes the information to several other +! GEOS-Chem F90 modules. It complements input.geos with adjoint specific flags +! and settings. Most of the code follows the convention from input_mod.f +! (adj_group, 6/6/09) +! +! Module Variables: +! ============================================================================ +! (1 ) VERBOSE (LOGICAL ) : Turns on echo-back of lines read from disk. +! (2 ) FIRSTCOL (INTEGER ) : First column of the input file (default=26) +! (3 ) MAXDIM (INTEGER ) : Maximum number of substrings to read in +! (9 ) FILENAME (CHAR*255) : GEOS-CHEM adjoint input file name +! (10) TOPTITLE (CHAR*255) : Top line of input file +! +! Module Routines: +! ============================================================================ +! (1 ) READ_INPUT_ADJ_FILE : Driver routine for reading GEOS-CHEM input file +! (2 ) READ_ONE_LINE : Reads one line at a time +! (3 ) SPLIT_ONE_LINE : Splits one line into substrings (by spaces) +! (4 ) READ_ADJ_SIMULATION_MENU : Reads the GEOS-Chem adjoint simulation menu +! (5 ) READ_FWD_MODEL_MENU : Reads forward model options +! (6 ) READ_ADJ_OPTIONS_MENU : Reads adjoint model options +! (7 ) READ_ADJ_DIRECTORIES_MENU : Reads the GEOS-Chem adj. directories +! (8 ) READ_CONTROL_VARS_MENU: Reads what are control variables +! (9 ) READ_OBSERVATION_MENU : Reads vars related to observations +! (10) READ_FD_ MENU : Reads finite difference test variables +! (11) READ_ADJ_DIAGNOSTICS_MENU : Reads the GEOS-Chem adj. diagnostic menu +! (12) VALIDATE_DIRECTORIES : Makes sure all given directories are valid +! (13) ARE_FLAGS_VALID : Makes sure all flags are valid/not conflicting +! (14) CHECK_DIRECTORY : Checks a single directory for errors +! (15) CLEAN_FILE_DIRS : Clean out directories +! (16) INIT_DEP_MAPS : Make mapping arrays for dep adjoint forcing +! (17) INIT_INPUT_ADJ : Initializes directory & logical variables +! +! GEOS-CHEM modules referenced by "input_adj_mod.f" +! ============================================================================ +! (1 ) directory_adj_mod.f : Module w/ GC adjoint directories +! (2 ) error_mod.f : Module w/ I/O error and NaN check routines +! (3 ) file_mod.f : Module w/ file unit numbers and error checks +! (4 ) grid_mod.f : Module w/ horizontal grid information +! (5 ) logical_adj_mod.f : Module w/ GC adjoint logical switches +! (6 ) adj_arrays_mod.f : Module w/ adj. arrays. +! NOTES: +! (1 ) Add LPOP_UGM3 (sev, dkh, 02/13/12, adj32_024) +! (2 ) Add LINVH_BFGS (nab, 25/03/12 ) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "input_adj_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: READ_INPUT_ADJ_FILE + PUBLIC :: INIT_DEP_MAPS + + !================================================================= + ! MODULE VARIABLES + !================================================================= + LOGICAL :: VERBOSE = .FALSE. + INTEGER, PARAMETER :: FIRSTCOL = 33 + INTEGER, PARAMETER :: MAXDIM = 255 + INTEGER :: CT1, CT2, CT3 + CHARACTER(LEN=255) :: FILENAME = 'input.gcadj' + CHARACTER(LEN=255) :: TOPTITLE + + ! For RRATE list + LOGICAL :: READ_STR_ID = .FALSE. + LOGICAL :: READ_RXN_ID = .FALSE. + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_INPUT_ADJ_FILE +! +!****************************************************************************** +! Subroutine READ_INPUT_ADJ_FILE is the driver program for reading the +! GEOS_CHEM adjoint input file "input.gcadj" from disk. (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Now call DO_GAMAP (dkh, 02/09/10) +! (2 ) Now call INIT_TRACERID_ADJ (dkh, 03/30/10) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : INIT_TRACERID_ADJ + USE CHARPAK_MOD, ONLY : STRREPL + USE FILE_MOD, ONLY : IU_GEOS, IOERROR + USE INPUT_MOD, ONLY : TRACERINFO, DIAGINFO + USE GAMAP_MOD, ONLY : DO_GAMAP + + ! Local variables + LOGICAL :: EOF + INTEGER :: IOS + CHARACTER(LEN=1) :: TAB = ACHAR(9) + CHARACTER(LEN=1) :: SPACE = ' ' + CHARACTER(LEN=255) :: LINE + + !================================================================= + ! READ_INPUT_ADJ_FILE begins here! + !================================================================= + + ! Echo output + WRITE( 6, '(a )' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' )'G E O S - C H E M A D J O I N T I N P U T' + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_INPUT_ADJ_FILE: Reading ', a ) + + ! Initialize directory & logical variables + CALL INIT_INPUT_ADJ + + ! Initialize adjoint tracer ID's to zero + CALL INIT_TRACERID_ADJ + + ! Open file + OPEN( IU_GEOS, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_GEOS,'read_input_adj_file:1') + + ! Read TOPTITLE for binary punch file + TOPTITLE = READ_ONE_LINE( EOF ) + IF ( EOF ) RETURN + + ! Loop until EOF + DO + + ! Read a line from the file, exit if EOF + LINE = READ_ONE_LINE( EOF ) + IF ( EOF ) EXIT + + ! Replace tab characters in LINE (if any) w/ spaces + CALL STRREPL( LINE, TAB, SPACE ) + + !============================================================= + ! Call individual subroutines to read sections of the file + !============================================================= + IF ( INDEX( LINE, 'ADJOINT SIMULATION MENU' ) > 0 ) THEN + CALL READ_ADJ_SIMULATION_MENU + + ELSE IF ( INDEX( LINE, 'FORWARD MODEL OPTIONS' ) > 0 ) THEN + CALL READ_FWD_MODEL_MENU + + ELSE IF ( INDEX( LINE, 'ADJOINT MODEL OPTIONS' ) > 0 ) THEN + CALL READ_ADJ_OPTIONS_MENU + + ELSE IF ( INDEX( LINE, 'DIRECTORIES' ) > 0 ) THEN + CALL READ_ADJ_DIRECTORIES_MENU + + ELSE IF ( INDEX( LINE, 'CONTROL VARIABLE MENU' ) > 0 ) THEN + CALL READ_CONTROL_VARS_MENU + + !mkeller: weak constraint menu + ELSE IF ( INDEX( LINE, 'WEAK CONSTRAINT MENU' ) > 0 ) THEN + CALL READ_WEAK_CONSTRAINT_MENU + + ELSE IF ( INDEX( LINE, 'OBSERVATION MENU' ) > 0 ) THEN + CALL READ_OBSERVATION_MENU + + ELSE IF ( INDEX( LINE, 'FINITE DIFFERENCE MENU' ) > 0 ) THEN + CALL READ_FD_MENU + + ELSE IF ( INDEX( LINE, 'DIAGNOSTICS MENU' ) > 0 ) THEN + CALL READ_ADJ_DIAGNOSTICS_MENU + + ELSE IF ( INDEX( LINE, 'CRITICAL LOAD MENU' ) > 0 ) THEN + CALL READ_ADJ_CRITICAL_LOAD_MENU + + ELSE IF ( INDEX( LINE, 'END OF FILE' ) > 0 ) THEN + EXIT + + ENDIF + ENDDO + + ! Close input file + CLOSE( IU_GEOS ) + + !================================================================= + ! Further error-checking and initialization + !================================================================= + + ! Make sure all directories are valid + CALL VALIDATE_DIRECTORIES + + ! Clean out file directories (rm *.chk.* , *.adj.* , *.sf.* and + ! *.gdt.* files ) + CALL CLEAN_FILE_DIRS + + ! Are all the flags a valid combination? + CALL ARE_FLAGS_VALID + + ! Echo output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Now call this routine here so that adjoint names have been + ! defined. (dkh, 02/09/10) + CALL DO_GAMAP( DIAGINFO, TRACERINFO ) + + ! Return to calling program + END SUBROUTINE READ_INPUT_ADJ_FILE + +!------------------------------------------------------------------------------ + + FUNCTION READ_ONE_LINE( EOF, LOCATION ) RESULT( LINE ) +! +!****************************************************************************** +! Subroutine READ_ONE_LINE reads a line from the input file. If the global +! variable VERBOSE is set, the line will be printed to stdout. READ_ONE_LINE +! can trap an unexpected EOF if LOCATION is passed. Otherwise, it will pass +! a logical flag back to the calling routine, where the error trapping will +! be done. (bmy, 7/20/04) +! +! Arguments as Output: +! =========================================================================== +! (1 ) EOF (CHARACTER) : Logical flag denoting EOF condition +! (2 ) LOCATION (CHARACTER) : Name of calling routine; traps premature EOF +! +! Function value: +! =========================================================================== +! (1 ) LINE (CHARACTER) : A line of text as read from the file +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE FILE_MOD, ONLY : IU_GEOS, IOERROR + USE FILE_MOD, ONLY : IU_RXN !(hml, 04/03/13) + USE FILE_MOD, ONLY : IU_STR !(hml, 05/22/13) + + ! Arguments + LOGICAL, INTENT(OUT) :: EOF + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: LOCATION + + ! Local variables + INTEGER :: IOS + CHARACTER(LEN=255) :: LINE, MSG + + !================================================================= + ! READ_ONE_LINE begins here! + !================================================================= + + ! Initialize + EOF = .FALSE. + + ! Read a line from the file (hml, 05/22/13) + IF ( READ_STR_ID ) READ ( IU_STR, '(a)', IOSTAT=IOS ) LINE + IF ( READ_RXN_ID ) READ ( IU_RXN, '(a)', IOSTAT=IOS ) LINE + IF ( .NOT. READ_STR_ID .AND. .NOT. READ_RXN_ID ) THEN + READ ( IU_GEOS,'(a)', IOSTAT=IOS ) LINE + ENDIF + + ! IO Status < 0: EOF condition + IF ( IOS < 0 ) THEN + EOF = .TRUE. + + ! Trap unexpected EOF -- stop w/ error msg if LOCATION is passed + ! Otherwise, return EOF to the calling program + IF ( PRESENT( LOCATION ) ) THEN + MSG = 'READ_ONE_LINE: error at: ' // TRIM( LOCATION ) + WRITE( 6, '(a)' ) MSG + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_ONE_LINE (input_mod.f)' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + STOP + ELSE + RETURN + ENDIF + ENDIF + + ! IO Status > 0: true I/O error condition (hml, 05/22/13) + IF ( READ_STR_ID ) THEN + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_STR, 'read_one_line:1-a' ) + ENDIF + IF ( READ_RXN_ID ) THEN + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_RXN, 'read_one_line:1-b' ) + ENDIF + IF ( .NOT. READ_STR_ID .AND. .NOT. READ_RXN_ID ) THEN + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_GEOS,'read_one_line:1-c' ) + ENDIF + + ! Print the line (if necessary) + IF ( VERBOSE ) WRITE( 6, '(a)' ) TRIM( LINE ) + + ! Return to calling program + END FUNCTION READ_ONE_LINE + +!------------------------------------------------------------------------------ + + SUBROUTINE SPLIT_ONE_LINE( SUBSTRS, N_SUBSTRS, N_EXP, LOCATION ) +! +!****************************************************************************** +! Subroutine SPLIT_ONE_LINE reads a line from the input file (via routine +! READ_ONE_LINE), and separates it into substrings. (bmy, 7/20/04) +! +! SPLIT_ONE_LINE also checks to see if the number of substrings found is +! equal to the number of substrings that we expected to find. However, if +! you don't know a-priori how many substrings to expect a-priori, +! you can skip the error check. +! +! Arguments as Input: +! =========================================================================== +! (3 ) N_EXP (INTEGER ) : Number of substrings we expect to find +! (N_EXP < 0 will skip the error check!) +! (4 ) LOCATION (CHARACTER) : Name of routine that called SPLIT_ONE_LINE +! +! Arguments as Output: +! =========================================================================== +! (1 ) SUBSTRS (CHARACTER) : Array of substrings (separated by " ") +! (2 ) N_SUBSTRS (INTEGER ) : Number of substrings actually found +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE CHARPAK_MOD, ONLY: STRSPLIT + + ! Arguments + CHARACTER(LEN=255), INTENT(OUT) :: SUBSTRS(MAXDIM) + INTEGER, INTENT(OUT) :: N_SUBSTRS + INTEGER, INTENT(IN) :: N_EXP + CHARACTER(LEN=*), INTENT(IN) :: LOCATION + + ! Local varaibles + LOGICAL :: EOF + CHARACTER(LEN=255) :: LINE, MSG + + !================================================================= + ! SPLIT_ONE_LINE begins here! + !================================================================= + + ! Create error msg + MSG = 'SPLIT_ONE_LINE: error at ' // TRIM( LOCATION ) + + !================================================================= + ! Read a line from disk + !================================================================= + LINE = READ_ONE_LINE( EOF ) + + ! STOP on End-of-File w/ error msg + IF ( EOF ) THEN + WRITE( 6, '(a)' ) TRIM( MSG ) + WRITE( 6, '(a)' ) 'End of file encountered!' + WRITE( 6, '(a)' ) 'STOP in SPLIT_ONE_LINE (input_mod.f)!' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + STOP + ENDIF + + !================================================================= + ! Split the lines between spaces -- start at column FIRSTCOL + !================================================================= + CALL STRSPLIT( LINE(FIRSTCOL:), ' ', SUBSTRS, N_SUBSTRS ) + + ! Sometimes we don't know how many substrings to expect, + ! if N_EXP is greater than MAXDIM, then skip the error check + IF ( N_EXP < 0 ) RETURN + + ! Stop if we found the wrong + IF ( N_EXP /= N_SUBSTRS ) THEN + WRITE( 6, '(a)' ) TRIM( MSG ) + WRITE( 6, 100 ) N_EXP, N_SUBSTRS + WRITE( 6, '(a)' ) 'STOP in SPLIT_ONE_LINE (input_mod.f)!' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + STOP + 100 FORMAT( 'Expected ',i2, ' substrs but found ',i3 ) + ENDIF + + ! Return to calling program + END SUBROUTINE SPLIT_ONE_LINE + +!------------------------------------------------------------------------------ + +!MK-WEAK_CONSTRAINT: + SUBROUTINE READ_WEAK_CONSTRAINT_MENU +! +!****************************************************************************** +! Subroutine READ_WEAK_CONSTRAINT_MENU reads the WEAK CONSTRAINT MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! (1 ) first attempt at subroutine (mkeller) +!****************************************************************************** +! + ! References to F90 modules + USE WEAK_CONSTRAINT_MOD, ONLY : DO_WEAK_CONSTRAINT + USE WEAK_CONSTRAINT_MOD, ONLY : MIN_LON_U + USE WEAK_CONSTRAINT_MOD, ONLY : MAX_LON_U + USE WEAK_CONSTRAINT_MOD, ONLY : MIN_LAT_U + USE WEAK_CONSTRAINT_MOD, ONLY : MAX_LAT_U + USE WEAK_CONSTRAINT_MOD, ONLY : MIN_LEV_U_INDEX + USE WEAK_CONSTRAINT_MOD, ONLY : MAX_LEV_U_INDEX + USE WEAK_CONSTRAINT_MOD, ONLY : LEN_SUBWINDOW_U + USE WEAK_CONSTRAINT_MOD, ONLY : N_TRACER_U + USE TRACER_MOD, ONLY : N_TRACERS + USE ERROR_MOD, ONLY : ERROR_STOP + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + !================================================================= + ! READ_WEAK_CONSTRAINT_MENU begins here! + !================================================================= + + ! Check if we are running the weak constraint module at all + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:1') + READ( SUBSTRS(1:N), * ) DO_WEAK_CONSTRAINT + IF (.NOT. DO_WEAK_CONSTRAINT) THEN + PRINT*, 'NOT RUNNING WEAK CONSTRAINT MODEL!' + RETURN + ENDIF + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:2') + READ( SUBSTRS(1:N), * ) N_TRACER_U + + IF ( N_TRACER_U > N_TRACERS ) THEN + CALL ERROR_STOP( 'WC-Index bigger than total number of tracers', + & 'read_weak_constraint_menu, input_adj_mod.f') + ENDIF + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:3') + READ( SUBSTRS(1:N), * ) MIN_LON_U + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:4') + READ( SUBSTRS(1:N), * ) MAX_LON_U + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:5') + READ( SUBSTRS(1:N), * ) MIN_LAT_U + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:6') + READ( SUBSTRS(1:N), * ) MAX_LAT_U + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:7') + READ( SUBSTRS(1:N), * ) MIN_LEV_U_INDEX + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:8') + READ( SUBSTRS(1:N), * ) MAX_LEV_U_INDEX + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:9') + READ( SUBSTRS(1:N), * ) LEN_SUBWINDOW_U + + END SUBROUTINE READ_WEAK_CONSTRAINT_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ADJ_SIMULATION_MENU + +! +!****************************************************************************** +! Subroutine READ_ADJ_SIMULATION_MENU reads the SIMULATION MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Reordering and updates (dkh, 02/09/11) +!****************************************************************************** +! + ! References to F90 modules + USE LOGICAL_MOD, ONLY : LTRAN + USE LOGICAL_ADJ_MOD, ONLY : LADJ + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST + USE LOGICAL_ADJ_MOD, ONLY : LSENS + USE LOGICAL_ADJ_MOD, ONLY : L4DVAR + USE LOGICAL_ADJ_MOD, ONLY : L3DVAR + + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + !================================================================= + ! READ_ADJ_SIMULATION_MENU begins here! + !================================================================= + + ! Check if we are running the adjoint at all + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:1' ) + READ( SUBSTRS(1:N), * ) LADJ + IF (.NOT. LADJ) THEN + PRINT*, 'NOT RUNNING THE ADJOINT!' + RETURN + ENDIF + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_adj_sim_menu:2' ) + + !! Doing transport adjoint + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:2' ) + !READ( SUBSTRS(1:N), * ) LADJ_TRAN + + ! Doing 4DVAR + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:3' ) + READ( SUBSTRS(1:N), * ) L4DVAR + + ! Doing 3DVAR + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:4' ) + READ( SUBSTRS(1:N), * ) L3DVAR + + ! Doing sensitivity run (no differences in cost function, just tracer conc) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:5' ) + READ( SUBSTRS(1:N), * ) LSENS + + ! Move to FORWARD MODEL menu (dkh, 02/09/11) + !! Doing chemistry + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:3' ) + !READ( SUBSTRS(1:N), * ) LADJ_CHEM + ! + !! Doing aerosol thermodynamics + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:4' ) + !READ( SUBSTRS(1:N), * ) LAERO_THERM + + IF ( .NOT. ( LSENS .OR. L4DVAR .OR. L3DVAR ) ) THEN + PRINT*, '******************************************' + PRINT*, 'HAVE TO PICK A SIMULATION, READ THE MANUAL!' + PRINT*, '******************************************' + RETURN + ENDIF + + ! Check to see if its a finite difference calculation + IF ( LSENS ) THEN + + ! Doing finite difference test in 1 gridbox + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_menu:6' ) + READ( SUBSTRS(1:N), * ) LFD_SPOT + + ! Doing finite difference test in all grid boxes, turn transport off + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_menu:7' ) + READ( SUBSTRS(1:N), * ) LFD_GLOB + + ! turn of transport for global FD test + IF ( LFD_GLOB ) LTRAN = .FALSE. + + ! define a more generic LFDTEST flag if either method is true + IF ( LFD_GLOB .OR. LFD_SPOT ) LFDTEST = .TRUE. + + ENDIF + + ! Move these to other menus (dkh, 02/09/11) + !!================================================================= + !! Include a priori term of the cost function (the one without the data) + !! aka source term + !! aka background term + !! aka penalty term + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:10' ) + !READ( SUBSTRS(1:N), * ) LAPSRC + ! + !! Compute background error covariance + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:11' ) + !READ( SUBSTRS(1:N), * ) LBKCOV + ! + !! Compute approximation of inverse Hessian + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:12' ) + !READ( SUBSTRS(1:N), * ) LINVH + ! + !! include LINOZ + !! NOTE: This flag controls both forward and adjoint execution + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:13' ) + !READ( SUBSTRS(1:N), * ) LLINOZ + ! + !! Check if we are running the adjoint at all + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim _menu:14' ) + !READ( SUBSTRS(1:N), * ) LRXNR + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'ADJOINT SIMULATION MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Doing adjoint run : ', LADJ + !WRITE( 6, 100 ) 'Doing adjoint transport : ', LADJ_TRAN + !WRITE( 6, 100 ) 'Doing adjoint chemistry : ', LADJ_CHEM + !WRITE( 6, 100 ) 'Doing aerosol thermodynamics : ',LAERO_THERM + WRITE( 6, 100 ) 'Doing 4DVAR (inversion) : ', L4DVAR + WRITE( 6, 100 ) 'Doing 3DVAR : ', L3DVAR + WRITE( 6, 100 ) 'Doing sensitivity run : ', LSENS + !WRITE( 6, 100 ) 'Include source term in J : ', LAPSRC + !WRITE( 6, 100 ) 'Compute background error cov : ', LBKCOV + !WRITE( 6, 100 ) 'Compute inverse Hessian : ', LINVH + !WRITE( 6, 100 ) 'Use LINOZ (fwd and adj) : ', LLINOZ + !WRITE( 6, 100 ) 'Include reaction rates LRXNR : ', LRXNR + WRITE( 6, 100 ) 'Doing finite diff check (1box): ', LFD_SPOT + WRITE( 6, 100 ) 'Doing finite diff check (glob): ', LFD_GLOB + + + ! Format statements + 100 FORMAT( A, L5 ) + 110 FORMAT( A, I5 ) + + !================================================================= + ! Call setup routines from other GEOS-CHEM modules + !================================================================= + + ! Set counter + CT1 = CT1 + 1 + + ! Return to calling program + END SUBROUTINE READ_ADJ_SIMULATION_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_FWD_MODEL_MENU +! +!****************************************************************************** +! Subroutine READ_FWD_MODEL_MENU reads the FORWARD MODEL OPTIONS section of +! the GEOS-CHEM adjoint input file (dkh, 02/09/11) +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE LOGICAL_MOD, ONLY : LTRAN + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CHEM + !USE LOGICAL_ADJ_MOD, ONLY : LLINOZ + USE LOGICAL_ADJ_MOD, ONLY : LAERO_THERM + USE LOGICAL_ADJ_MOD, ONLY : LISO + + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + !================================================================= + ! READ_FWD_MODEL_MENU begins here! + !================================================================= + + ! Doing chemistry + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fwd_menu:1' ) + READ( SUBSTRS(1:N), * ) LADJ_CHEM + + ! Doing aerosol thermodynamics + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fwd_menu:2' ) + READ( SUBSTRS(1:N), * ) LAERO_THERM + + ! Use ISORROPIAII + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fwd_menu:3' ) + READ( SUBSTRS(1:N), * ) LISO + + ! Now use new strat_chem_mod (hml, dkh, 02/14/12, adj32_025) + !! include LINOZ + !! NOTE: This flag controls both forward and adjoint execution + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fwd_menu:3' ) + !READ( SUBSTRS(1:N), * ) LLINOZ + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'FORWARD MODEL OPTIONS' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Doing adjoint chemistry : ', LADJ_CHEM + WRITE( 6, 100 ) 'Doing aerosol thermodynamics : ',LAERO_THERM + WRITE( 6, 100 ) ' => ISORROPIAII : ', LISO + !WRITE( 6, 100 ) 'Use LINOZ (fwd and adj) : ', LLINOZ + + ! Format statements + 100 FORMAT( A, L5 ) + 110 FORMAT( A, I5 ) + + !================================================================= + ! Call setup routines from other GEOS-CHEM modules + !================================================================= + + ! Set counter + CT1 = CT1 + 1 + + ! Return to calling program + END SUBROUTINE READ_FWD_MODEL_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ADJ_OPTIONS_MENU +! +!****************************************************************************** +! Subroutine READ_ADJ_OPTIONS_MENU reads the ADJOINT MODEL OPTIONS section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Reordering and updates (dkh, 02/09/11) +! (2 ) Add LINVH_BFGS (nab, 25/03/12 ) +!****************************************************************************** +! + ! References to F90 modules + USE LOGICAL_MOD, ONLY : LTRAN + USE LOGICAL_ADJ_MOD, ONLY : LAPSRC + USE LOGICAL_ADJ_MOD, ONLY : LBKCOV + USE LOGICAL_ADJ_MOD, ONLY : LINVH, LINVH_BFGS + USE LOGICAL_ADJ_MOD, ONLY : LRXNR + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE LOGICAL_ADJ_MOD, ONLY : LFILL_ADJ + + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + !================================================================= + ! READ_ADJ_OPTIONS_MENU begins here! + !================================================================= + + ! Move these to other menus (dkh, 02/09/11) + !================================================================= + ! Include a priori term of the cost function (the one without the data) + ! aka source term + ! aka background term + ! aka penalty term + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:10' ) + READ( SUBSTRS(1:N), * ) LAPSRC + + ! Compute background error covariance + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:11' ) + READ( SUBSTRS(1:N), * ) LBKCOV + + ! Compute approximation of inverse Hessian + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:12' ) + READ( SUBSTRS(1:N), * ) LINVH + + ! Compute approximation of L-BFGS inverse Hessian + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:13' ) + READ( SUBSTRS(1:N), * ) LINVH_BFGS + + ! Compute reaction rate constant sensitivities + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:14' ) + READ( SUBSTRS(1:N), * ) LRXNR + + ! Delete checkpt files + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:15' ) + READ( SUBSTRS(1:N), * ) LDEL_CHKPT + + ! Scale up and FILL adj transport + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:15' ) + READ( SUBSTRS(1:N), * ) LFILL_ADJ + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'ADJOINT MODEL OPTIONS' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Include source term in J : ', LAPSRC + WRITE( 6, 100 ) 'Compute background error cov : ', LBKCOV + WRITE( 6, 100 ) 'Compute inverse Hessian : ', LINVH + WRITE( 6, 100 ) 'Compute L-BFGS inverse Hessian : ' + & , LINVH_BFGS + WRITE( 6, 100 ) 'Include reaction rates LRXNR : ', LRXNR + WRITE( 6, 100 ) 'Delete chkpt files LDEL_CHKPT : ', + & LDEL_CHKPT + WRITE( 6, 100 ) 'Scale up and FILL adj transport: ', LFILL_ADJ + + + ! Format statements + 100 FORMAT( A, L5 ) + 110 FORMAT( A, I5 ) + + !================================================================= + ! Call setup routines from other GEOS-CHEM modules + !================================================================= + + ! Set counter + CT1 = CT1 + 1 + + ! Return to calling program + END SUBROUTINE READ_ADJ_OPTIONS_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ADJ_DIRECTORIES_MENU +! +!****************************************************************************** +! Subroutine READ_ADJ_DIRECTORIES_MENU reads the DIRECTORIES MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR, ADJTMP_DIR, DIAGADJ_DIR + + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + !================================================================= + ! READ_ADJ_DIRECTORIES_MENU begins here! + !================================================================= + + ! Optimization output data dir + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_directories_menu:1' ) + READ( SUBSTRS(1:N), '(a)' ) OPTDATA_DIR + + ! Optimization temporary directory + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_directories_menu:2' ) + READ( SUBSTRS(1:N), '(a)' ) ADJTMP_DIR + + ! Optimization diagnostic file directory + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_directories_menu:2' ) + READ( SUBSTRS(1:N), '(a)' ) DIAGADJ_DIR + + WRITE( 6, '(/,a)' ) 'DIRECTORIES MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 110 ) 'Optimization output directory : ', + & TRIM( OPTDATA_DIR ) + WRITE( 6, 110 ) 'Temporary adjoint directory : ', + & TRIM( ADJTMP_DIR ) + WRITE( 6, 110 ) 'Diagnostic adjoint directory : ', + & TRIM( DIAGADJ_DIR ) + + 110 FORMAT( A, A ) + + ! Set counter + CT1 = CT1 + 1 + + + END SUBROUTINE READ_ADJ_DIRECTORIES_MENU +!--------------------------------------------------------------------------------------- +! +! SUBROUTINE READ_CONTROL_PARAMS_MENU +!! +!!****************************************************************************** +!! Subroutine READ_CONTROL_PARAMS_MENU reads the CONTROL PARAMETERS MENU section of +!! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +!! +!! NOTES: +!! (1 ) Add ICS_SF_tmp, EMS_SF_tmp (mak, dkh, 10/01/09) +!! (2 ) Merge this with CONTROL_VARS_MENU +!!****************************************************************************** +!! +! ! References to F90 modules +! USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS +! USE LOGICAL_ADJ_MOD, ONLY : LICS +! USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_tmp +! USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_tmp +! +! +! ! Local variables +! INTEGER :: N +! CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) +! +! !================================================================= +! ! READ_ADJ_SIMULATION_MENU begins here! +! !================================================================= +! +! ! Optimizing emissions +! CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_params_menu:1' ) +! READ( SUBSTRS(1:N), * ) LADJ_EMS +! +! ! Optimizing initial conditions +! CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_params_menu:3' ) +! READ( SUBSTRS(1:N), * ) LICS +! +! ! Optimizing initial conditions +! CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_params_menu:4' ) +! READ( SUBSTRS(1:N), * ) ICS_SF_tmp +! +! ! Optimizing initial conditions +! CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_params_menu:5' ) +! READ( SUBSTRS(1:N), * ) EMS_SF_tmp +! +! +! !================================================================= +! ! Print to screen +! !================================================================= +! WRITE( 6, '(/,a)' ) 'CONTROL PARAMETERS MENU' +! WRITE( 6, '( a)' ) '---------------' +! WRITE( 6, 100 ) 'Optimizing emissions : ', LADJ_EMS +! WRITE( 6, 100 ) 'Optimizing initial conditions : ', LICS +! WRITE( 6, 110 ) 'First guess for ICS_SF is : ', ICS_SF_tmp +! WRITE( 6, 110 ) 'First guess for EMS_SF is : ', EMS_SF_tmp +! +! +! ! Format statements +! 100 FORMAT( A, L5 ) +! 110 FORMAT( A, f7.2 ) +! +! +! !================================================================= +! ! Call setup routines from other GEOS-CHEM modules +! !================================================================= +! +! ! Set counter +! CT1 = CT1 + 1 +! +! ! Return to calling program +! END SUBROUTINE READ_CONTROL_PARAMS_MENU +! +!!------------------------------------------------------------------------------ + SUBROUTINE READ_CONTROL_VARS_MENU +! +!****************************************************************************** +! Subroutine READ_CONTROL_VARS_MENU reads the CONTROL VARIABLES MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Reorder and update (dkh, 02/09/11) +! (2 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LICS + USE ADJ_ARRAYS_MOD, ONLY : NNEMS + USE ADJ_ARRAYS_MOD, ONLY : ID_ADEMS + USE ADJ_ARRAYS_MOD, ONLY : ADEMS_NAME + USE ADJ_ARRAYS_MOD, ONLY : TRACERID_ADJ + USE ADJ_ARRAYS_MOD, ONLY : INIT_ADJ_EMS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_EMS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_ICS + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_EMS + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : COV_ERROR_LX, COV_ERROR_LY + USE ADJ_ARRAYS_MOD, ONLY : ICS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_DEFAULT + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : TRACER_NAME + + ! for strat prod and loss SF (hml, 08/14/11) + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE ADJ_ARRAYS_MOD, ONLY : ID_PROD + USE ADJ_ARRAYS_MOD, ONLY : ID_LOSS + USE ADJ_ARRAYS_MOD, ONLY : PROD_NAME + USE ADJ_ARRAYS_MOD, ONLY : LOSS_NAME + USE ADJ_ARRAYS_MOD, ONLY : STRPID_ADJ + USE ADJ_ARRAYS_MOD, ONLY : STRLID_ADJ + USE ADJ_ARRAYS_MOD, ONLY : INIT_ADJ_STRAT + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_PROD + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_LOSS + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_PROD + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_LOSS + USE ADJ_ARRAYS_MOD, ONLY : PROD_ERROR + USE ADJ_ARRAYS_MOD, ONLY : LOSS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_DEFAULT + + ! for reaction rates (tww, 05/08/12) + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + USE ADJ_ARRAYS_MOD, ONLY : NRRATES + USE ADJ_ARRAYS_MOD, ONLY : ID_RRATES + USE ADJ_ARRAYS_MOD, ONLY : RRATES_NAME + USE ADJ_ARRAYS_MOD, ONLY : INIT_ADJ_RRATES + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_RATE + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_RATE + USE ADJ_ARRAYS_MOD, ONLY : RATE_ERROR + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_DEFAULT + USE GCKPP_ADJ_GLOBAL, ONLY : NCOEFF_RATE + ! (hml, 05/22/13) + USE LOGICAL_ADJ_MOD, ONLY : FI_STRID + USE LOGICAL_ADJ_MOD, ONLY : FI_RXNID + USE FILE_MOD, ONLY : IOERROR + USE FILE_MOD, ONLY : IU_STR + USE FILE_MOD, ONLY : IU_RXN + +# include "define_adj.h" + + ! Local variables + INTEGER :: N, T, NSOPT, TMP, AS + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + ! For RRATE list (hml, 04/03/13) + INTEGER :: IOS + + !================================================================= + ! READ_CONTROL_VARS_MENU begins here! + !================================================================= + + !================================================================= + ! Allocate arrays + !================================================================= + ! First allocate OPT_THIS_TRACER to be max species + ALLOCATE( OPT_THIS_TRACER( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OPT_THIS_TRACER' ) + OPT_THIS_TRACER = .FALSE. + + ALLOCATE( REG_PARAM_ICS( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REG_PARAM_ICS' ) + REG_PARAM_ICS = 1d0 + + ALLOCATE( ICS_ERROR( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_ERROR' ) + ICS_ERROR = 1d0 +#if defined ( LOG_OPT ) + ICS_ERROR = EXP(1d0) +#endif + + ALLOCATE( ICS_SF_DEFAULT( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_SF_DEFAULT' ) + ICS_SF_DEFAULT = 1d0 + + !================================================================= + ! Read menu + !================================================================= + + ! Optimizing initial conditions + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:1' ) + READ( SUBSTRS(1:N), * ) LICS + + ! Optimizing emissions + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:2' ) + READ( SUBSTRS(1:N), * ) LADJ_EMS + + ! Optimizing strat prod & loss (hml, 08/11/11, adj32_025) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:3a' ) + READ( SUBSTRS(1:N), * ) LADJ_STRAT + + ! Specifying reaction rates (tww, 05/08/12) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:3d' ) + READ( SUBSTRS(1:N), * ) LADJ_RRATE + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:3b' ) + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:3c') + + ! Number of species to optimize + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:4' ) + READ( SUBSTRS(1:N), * ) NSOPT + + IF ( LICS .AND. NSOPT .EQ. 0) THEN + CALL ERROR_STOP( ' LICS is T but NSOPT is 0 ', + & ' READ_CONTROL_VARS_MENU, geos_chem_mod.f ' ) + ENDIF + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:5' ) + + DO T = 1, NSOPT + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1,'read_control_vars_menu:6') + + ! set OPT_THIS_TRACER to true for species we're optimizing + READ( SUBSTRS(1), * ) TMP + OPT_THIS_TRACER(TMP) = .TRUE. + + ! now move this to observation menu (dkh, 02/09/11) + !! observe this species? + !READ( SUBSTRS(3), *) OBS_THIS_SPECIES(TMP) + + ! Defualt scaling factor for this initial condition + READ( SUBSTRS(3), *) ICS_SF_DEFAULT(TMP) + + ! REG_PARAM for this species + READ( SUBSTRS(4), *) REG_PARAM_ICS(TMP) + + ! ICS_ERROR for this emission + READ( SUBSTRS(5), *) ICS_ERROR(TMP) + + ENDDO + + ! Obsolete -- now we only list tracer that are observed + ! compute number of observed species + !NOBS = 0 + !DO T = 1, N_TRACERS + ! IF ( OBS_THIS_SPECIES(T) ) THEN + ! NOBS = NOBS + 1 + ! ENDIF + !ENDDO + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:7' ) + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:7b') + + ! Optimizing emissions + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:8' ) + READ( SUBSTRS(1:N), * ) NNEMS + + IF ( .NOT. LADJ_EMS ) NNEMS = 0 + + ! If we're optimizing initial conditions, number of tracers is + !N_TRACERS + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:9' ) + + IF ( LADJ_EMS .AND. NNEMS .GT. 0) THEN + + CALL INIT_ADJ_EMS + + ELSEIF ( LADJ_EMS .AND. NNEMS .EQ. 0) THEN + CALL ERROR_STOP( ' LADJ_EMS is T but NNEMS is 0 ', + & ' READ_CONTROL_VARS_MENU, geos_chem_mod.f ' ) + ENDIF + + !================================================================= + ! Read emission ID + !================================================================= + IF ( LADJ_EMS ) THEN + DO T = 1, NNEMS + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:10') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_ADEMS(T) + + ! Save tracer name + ADEMS_NAME(T) = TRIM( SUBSTRS(2) ) + + ! optimize this emission?Q + READ( SUBSTRS(3), *) OPT_THIS_EMS(T) + + ! Defualt scaling factor for this emission + READ( SUBSTRS(4), *) EMS_SF_DEFAULT(T) + + ! REG_PARAM for this emission + READ( SUBSTRS(5), *) REG_PARAM_EMS(T) + + ! EMS_ERROR for this emission + READ( SUBSTRS(6), *) EMS_ERROR(T) + + ! CORR_LX for this emission + READ( SUBSTRS(7), *) COV_ERROR_LX(T) + + ! CORR_LY for this emission + READ( SUBSTRS(8), *) COV_ERROR_LY(T) + + ENDDO + + ! Number of temporal groups of the control vector, + ! e.g. monthly optimization in a year-long simulation would have + ! 12. If in doubt, set to 1 + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_control_vars_menu:11' ) + READ( SUBSTRS(1:N), * ) MMSCL + + ! Strat prod and loss (hml, adj32_025) + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:12b') + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:12c') + + ! Optimizing strat prod & loss + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_control_vars_menu:13' ) + READ( SUBSTRS(1:N), * ) NSTPL + IF ( .NOT. LADJ_STRAT ) NSTPL = 0 + + ! Read the list from file? (hml, 05/21/13) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_control_vars_menu:14' ) + READ( SUBSTRS(1:N), * ) FI_STRID + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:15' ) + + IF ( LADJ_STRAT .AND. NSTPL .GT. 0) THEN + + CALL INIT_ADJ_STRAT + + ELSEIF ( LADJ_STRAT .AND. NSTPL .EQ. 0) THEN + CALL ERROR_STOP( ' LADJ_STRAT is T but NSTPL is 0 ', + & ' READ_CONTROL_VARS_MENU, geos_chem_mod.f ' ) + ENDIF + + !PRINT *, ' NSTPL = ' , NSTPL + + !================================================================= + ! Read Stratospheric Tracers ID + !================================================================= + IF ( LADJ_STRAT .AND. .NOT. FI_STRID ) THEN ! (hml, 05/21/13) + + DO T = 1, NSTPL + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:16') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_PROD(T) + + ! Save tracer name + PROD_NAME(T) = TRIM( SUBSTRS(2) ) + + ! optimize this strat prod & loss? + READ( SUBSTRS(3), *) OPT_THIS_PROD(T) + + ! Defualt prod scaling factor for this strat tracer + READ( SUBSTRS(4), *) PROD_SF_DEFAULT(T) + + ! REG_PARAM for this strat tracer + READ( SUBSTRS(5), *) REG_PARAM_PROD(T) + + ! STR_ERROR for this strat tracer + READ( SUBSTRS(6), *) PROD_ERROR(T) + + ENDDO + + DO T = 1, NSTPL + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:16-b') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_LOSS(T) + + ! Save tracer name + LOSS_NAME(T) = TRIM( SUBSTRS(2) ) + + ! optimize this strat prod & loss? + READ( SUBSTRS(3), *) OPT_THIS_LOSS(T) + + ! Defualt loss scaling factor for this strat tracer + READ( SUBSTRS(4), *) LOSS_SF_DEFAULT(T) + + ! REG_PARAM for this strat tracer + READ( SUBSTRS(5), *) REG_PARAM_LOSS(T) + + ! STR_ERROR for this strat tracer + READ( SUBSTRS(6), *) LOSS_ERROR(T) + + ENDDO + + ELSE IF ( LADJ_STRAT .AND. FI_STRID ) THEN + + CALL READ_STRID_FILE + + ENDIF + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:15' ) + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:16' ) + + ! Specifying reaction rates + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_control_vars_menu:16b' ) + READ( SUBSTRS(1:N), * ) NRRATES + + IF ( .NOT. LADJ_RRATE ) NRRATES = 0 + + ! Read the list from file? + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_control_vars_menu:16c' ) + READ( SUBSTRS(1:N), * ) FI_RXNID + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:16d' ) + + IF ( LADJ_RRATE .AND. NRRATES .GT. 0) THEN + + CALL INIT_ADJ_RRATES + + ELSEIF ( LADJ_RRATE .AND. NRRATES .EQ. 0) THEN + + CALL ERROR_STOP( ' LADJ_RRATE is T but NRRATES is 0 ', + & ' READ_CONTROL_VARS_MENU, geos_chem_mod.f ' ) + + ENDIF + + IF ( LADJ_RRATE .AND. ( NRRATES .NE. NCOEFF_RATE ) ) THEN + + print*, 'NRRATES =', NRRATES + print*, 'NCOEFF_RATE =', NCOEFF_RATE + CALL ERROR_STOP( 'NRRATES not equal NCOEFF_RATE + & Check gckpp_adj_Global.f90 ', + & ' READ_CONTROL_VARS_MENU, geos_chem_mod.f ' ) + + ENDIF + + + + !================================================================= + ! Read Reaction Rates ID + !================================================================= + IF ( LADJ_RRATE .AND. .NOT. FI_RXNID ) THEN + + ! Added block to read reaction rate entries (tww, 05/08/12) + + DO T = 1, NRRATES + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:17') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_RRATES(T) + + ! Save tracer name + RRATES_NAME(T) = TRIM( SUBSTRS(2) ) + + ! Optimize this rate? + READ( SUBSTRS(3), *) OPT_THIS_RATE(T) + + ! Default scaling factor for this rate + READ( SUBSTRS(4), *) RATE_SF_DEFAULT(T) + + ! REG_PARAM for this rate + READ( SUBSTRS(5), *) REG_PARAM_RATE(T) + + ! RATE_ERROR for this rate + READ( SUBSTRS(6), *) RATE_ERROR(T) + + ENDDO + + ELSEIF ( LADJ_RRATE .AND. FI_RXNID ) THEN + + CALL READ_RXNID_FILE + + ENDIF + + ENDIF + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) + & 'CONTROL VARIABLE MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 130 ) 'Optimizing initial conditions : ', LICS + WRITE( 6, 130 ) 'Optimizing emissions : ', LADJ_EMS + WRITE( 6, 130 ) 'Optimizing strat prod & loss : ', LADJ_STRAT + WRITE( 6, 130 ) 'Optimizing rxn rates : ', LADJ_RRATE + WRITE( 6, '( a)' ) '>------------------------------<' + + IF ( LICS ) THEN + WRITE( 6, '( a)' ) + & ' Tracers optimizing SF_DEFAULT REG_PARAM ERROR' + ! Print info about each tracer + DO T = 1, N_TRACERS + + IF( OPT_THIS_TRACER(T) ) THEN + ! Write tracer number, name and it's default scaling factor + WRITE( 6, 140 ) T, TRACER_NAME(T), ICS_SF_DEFAULT(T), + & REG_PARAM_ICS(T), ICS_ERROR(T) + ENDIF + + ENDDO + !mkeller + !ELSEIF ( LADJ_EMS ) THEN + ENDIF + IF ( LADJ_EMS ) THEN + WRITE( 6, '( a)' ) + & ' # Emission Opt SF REG ERR' + + ! Print info about each tracer + DO T = 1, NNEMS + + ! Write tracer number, name, optimize, default SF, reg param + ! and error + WRITE( 6, 120 ) ID_ADEMS(T), ADEMS_NAME(T), OPT_THIS_EMS(T), + & EMS_SF_DEFAULT(T), REG_PARAM_EMS(T), EMS_ERROR(T) + + ENDDO + + WRITE( 6, 110 ) 'Number of time contrl groups : ', MMSCL + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + WRITE( 6, '( a)' ) + & ' # Strat trc Opt SF REG ERR' + + ! Print info about each prod tracer + DO T = 1, NSTPL + + ! Write tracer number, name, default SF of prod, + ! reg param, and error + WRITE( 6, 150 ) ID_PROD(T), PROD_NAME(T), + & OPT_THIS_PROD(T), PROD_SF_DEFAULT(T), + & REG_PARAM_PROD(T), PROD_ERROR(T) + + ENDDO + + CALL STRPID_ADJ + + ! Print info about each tracer loss + DO T = 1, NSTPL + + ! Write tracer number, name, default SF of loss, + ! reg param, and error + WRITE( 6, 150 ) ID_LOSS(T), LOSS_NAME(T), + & OPT_THIS_LOSS(T), LOSS_SF_DEFAULT(T), + & REG_PARAM_LOSS(T), LOSS_ERROR(T) + + ENDDO + + CALL STRLID_ADJ + + ENDIF + + ! Print info about rxn rates (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN + + WRITE( 6, '(a)' ) + & ' RXN ID NAME OPT DEF_SF REG ERR' + + ! Print info about each tracer + DO T = 1, NRRATES + + ! Write tracer number, name + WRITE( 6, 150 ) ID_RRATES(T), RRATES_NAME(T), + & OPT_THIS_RATE(T), RATE_SF_DEFAULT(T), + & REG_PARAM_RATE(T), RATE_ERROR(T) + + ENDDO + + ENDIF + + !================================================================= + ! Call setup routines from other F90 modules + !================================================================= + + CALL TRACERID_ADJ + + ENDIF + + ! Set counter + CT1 = CT1 + 1 + + ! Format statements + 100 FORMAT( I3, 1x, A10, 6x, f5.2, 6x, f5.2 ) + 110 FORMAT( A, I5 ) +! 120 FORMAT( I3, 1x, A14, 6x, L5, 1x, f5.2, 1x, f5.2, 1x, f5.2 ) + 120 FORMAT( I3, 1x, A14, 6x, L5, 1x, f5.2, 1x, f6.2, 1x, f5.2 ) + 130 FORMAT( A, L5 ) + 140 FORMAT( I3, 1x, A10, 6x, f5.2, 6x, f5.2, 6x f5.2 ) + 150 FORMAT( I3, 1x, A14, 5x, L5, 1x, f5.2, 1x, f5.2, 1x, f5.2 ) + + ! Return to calling program + END SUBROUTINE READ_CONTROL_VARS_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_OBSERVATION_MENU +! +!****************************************************************************** +! Subroutine READ_OBSERVATION_MENU reads the OBSERVATION OPTIONS MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! a) calculate NSPAN using NYMDf, NHMSf (fp) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : OBS_FREQ + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_SPECIES + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE ADJ_ARRAYS_MOD, ONLY : GET_SPEC + USE ADJ_ARRAYS_MOD, ONLY : CNAME + USE ADJ_ARRAYS_MOD, ONLY : FORCING_MASK_FILE + USE ADJ_ARRAYS_MOD, ONLY : FORCING_MASK_VARIABLE + USE ADJ_ARRAYS_MOD, ONLY : FORCING_MASK_FILE_NC + USE ADJ_ARRAYS_MOD, ONLY : NB_MASK_VAR + USE ADJ_ARRAYS_MOD, ONLY : DEP_UNIT + USE ADJ_ARRAYS_MOD, ONLY : TRACER_IND + USE ADJ_ARRAYS_MOD, ONLY : NFD + USE ERROR_MOD, ONLY : ALLOC_ERR + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS + USE LOGICAL_ADJ_MOD, ONLY : LKGBOX + USE LOGICAL_ADJ_MOD, ONLY : LUGM3 + USE LOGICAL_ADJ_MOD, ONLY : LPOP_UGM3 + USE LOGICAL_ADJ_MOD, ONLY : LSTT_PPB + USE LOGICAL_ADJ_MOD, ONLY : LSTT_TROP_PPM + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_PPB + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_OBS + USE LOGICAL_ADJ_MOD, ONLY : LSENS + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE LOGICAL_ADJ_MOD, ONLY : LKGNHAYR + USE LOGICAL_ADJ_MOD, ONLY : LEQHAYR + USE LOGICAL_ADJ_MOD, ONLY : LMOLECCM2S + USE LOGICAL_ADJ_MOD, ONLY : LKGS + USE LOGICAL_ADJ_MOD, ONLY : LFORCE_MASK + USE LOGICAL_ADJ_MOD, ONLY : LFORCE_MASK_NC, LFORCE_MASK_BPCH + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE TRACER_MOD, ONLY : N_TRACERS, ITS_A_FULLCHEM_SIM + USE TIME_MOD, ONLY : GET_JD, NYMDe, NHMSe, NYMDb, NHMSb + ! for flux based cost function (hml,06/13/12) + USE LOGICAL_ADJ_MOD, ONLY : LFLX_UGM2 + +# include "CMN_SIZE" +# include "comode.h" ! IGAS, NAMEGAS + + ! Local variables + INTEGER :: N,T,J + INTEGER :: TMP + INTEGER :: NUNIT_COUNT + INTEGER :: AS + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + LOGICAL :: EOF + CHARACTER(LEN=255) :: LINE + CHARACTER(LEN=15) :: TNAME(N_TRACERS) + REAL*8 :: MASK_AREA + INTEGER :: NHMSf, NYMDf !fp + REAL*8 :: JDF, JDE, JDB !fp + + !================================================================= + ! READ_OBSERVATION_MENU begins here! + !================================================================= + + ! First allocate OBS_THIS_TRACER to be max species + ALLOCATE( OBS_THIS_TRACER( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS_THIS_TRACER' ) + OBS_THIS_TRACER = 0 + + ! Also allocation the mapping between observed and all tracers + ALLOCATE( TRACER_IND( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TRACER_IND' ) + TRACER_IND = 0 + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_obs_menu:1' ) + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_obs_menu:2' ) + + ! Optimization output data dir + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_obs_menu:3' ) + READ( SUBSTRS(1:N), * ) OBS_FREQ + + ! Maximum number of obs? + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_obs_menu:4' ) + READ( SUBSTRS(1:N), * ) LMAX_OBS + + ! Number of obs evaluations + CALL SPLIT_ONE_LINE( SUBSTRS, N, 2, 'read_observation_menu:5' ) + READ( SUBSTRS(1:N), * ) NYMDf, NHMSf + + !calculate nspan (fp) + JDE = GET_JD(NYMDe, NHMSe) + JDB = GET_JD(NYMDb, NHMSb) + +! Need to review this with fp, not sure it gives desired behavior +! !fp to avoid error with new definition of nspan when LMAX_OBS is false but LFD_GLOB is true +! IF ( LFD_GLOB ) THEN +! IF ( .not. LMAX_OBS ) THEN +! LMAX_OBS = .TRUE. +! NYMDF = NYMDB +! NHMSF = NHMSB +! ENDIF +! ENDIF + + JDF = GET_JD(NYMDf, NHMSf) + + ! add error catch (fp) + IF ( JDB .GT. JDF .and. LMAX_OBS) THEN + CALL ERROR_STOP( + & ' You cannot force adjoint beyond simulation start time ', + & ' input_adj_mod.f ') + ENDIF + + ! add error catch (yd) + IF ( JDF .GT. JDE .and. LMAX_OBS ) THEN + CALL ERROR_STOP( + & ' The forcing time period is outside of the run period', + & ' input_adj_mod.f ') + ENDIF + + NSPAN = NINT( ( JDE - JDF ) * 24D0 * 60D0 / OBS_FREQ ) + + ! Want to only evalute CF once for FD_GLOB test + IF ( LFD_GLOB ) THEN + LMAX_OBS = .TRUE. + NSPAN = 1 + ENDIF + + !================================================================= + ! Cost function options + !================================================================= + NUNIT_COUNT = 0 + + ! Separator line: COST FUNCTION options for LSENS:--- + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_observation_menu:6' ) + + ! Cost function STT in kg / box + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:7' ) + READ( SUBSTRS(1:N), * ) LKGBOX + IF ( LKGBOX ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function STT in ug / m3 + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:8' ) + READ( SUBSTRS(1:N), * ) LUGM3 + IF ( LUGM3 ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function STT in ppb + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:9' ) + READ( SUBSTRS(1:N), * ) LSTT_PPB + IF ( LSTT_PPB ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function STT in free trop in ppm + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:10' ) + READ( SUBSTRS(1:N), * ) LSTT_TROP_PPM + IF ( LSTT_TROP_PPM ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function CSPEC in ppb + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:11' ) + READ( SUBSTRS(1:N), * ) LCSPEC_PPB + IF ( LCSPEC_PPB ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function STT in population weighted ug / m3 (adj32_024) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:12' ) + READ( SUBSTRS(1:N), * ) LPOP_UGM3 + IF ( LPOP_UGM3 ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function STT in flux ug / m2 / hr (hml,06/13/12) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13' ) + READ( SUBSTRS(1:N), * ) LFLX_UGM2 + IF ( LFLX_UGM2 ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! deposition based cost function? + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.a' ) + READ( SUBSTRS(1:N), * ) LADJ_FDEP + + ! tracer dry deposition + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.b' ) + READ( SUBSTRS(1:N), * ) LADJ_DDEP_TRACER + + ! species dry deposition + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.b2') + READ( SUBSTRS(1:N), * ) LADJ_DDEP_CSPEC + + ! wet deposition LS + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.c' ) + READ( SUBSTRS(1:N), * ) LADJ_WDEP_LS + + ! wet deposition CV + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.d' ) + READ( SUBSTRS(1:N), * ) LADJ_WDEP_CV + + ! wet deposition units + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.e1') + READ( SUBSTRS(1:N), * ) LMOLECCM2S + IF ( LMOLECCM2S .and. LADJ_FDEP ) NUNIT_COUNT = NUNIT_COUNT + 1 + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.e2') + READ( SUBSTRS(1:N), * ) LKGNHAYR + IF ( LKGNHAYR .and. LADJ_FDEP ) NUNIT_COUNT = NUNIT_COUNT + 1 + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.e3') + READ( SUBSTRS(1:N), * ) LEQHAYR + IF ( LEQHAYR .and. LADJ_FDEP ) NUNIT_COUNT = NUNIT_COUNT + 1 + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.e4') + READ( SUBSTRS(1:N), * ) LKGS + IF ( LKGS .and. LADJ_FDEP ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! now we can define units of the deposition cost function + ! fp 3/10/2013 + IF ( LADJ_FDEP ) THEN + IF ( LKGNHAYR ) THEN + DEP_UNIT = TRIM( 'kgN/ha/yr' ) + ELSEIF ( LEQHAYR ) THEN + DEP_UNIT = TRIM( 'eq/ha/yr' ) + ELSEIF ( LMOLECCM2S ) THEN + DEP_UNIT = TRIM( 'molec/cm2/s' ) + ELSEIF ( LKGS ) THEN + DEP_UNIT = TRIM( 'kg/s' ) + ELSE + CALL ERROR_STOP(' No unit selected for deposition ', + & ' input_adj_mod.f ') + ENDIF + ELSE + !set all deposition switches to false to avoid unwanted behavior with fd tests (fp) + LKGS = .FALSE. + LEQHAYR = .FALSE. + LKGNHAYR = .FALSE. + LMOLECCM2S = .FALSE. + + LADJ_DDEP_TRACER = .FALSE. + LADJ_DDEP_CSPEC = .FALSE. + LADJ_WDEP_CV = .FALSE. + LADJ_WDEP_LS = .FALSE. + + ENDIF + + ! Make sure that we haven't defined too many + IF ( NUNIT_COUNT > 1 ) THEN + CALL ERROR_STOP(' More than one choice for cost function ', + & ' input_adj_mod.f ') + + + ! Make sure that we have picked at least one. For + ! FD tests, the default is forced to be kg/box. + ELSEIF ( NUNIT_COUNT == 0 .and. LSENS .and. ( .not. LFDTEST ) ) + & THEN + CALL ERROR_STOP(' Need to choose one option for units ', + & ' input_adj_mod.f ') + ENDIF + ! Make sure that if deposition is selected that at least one option + ! is turned on. + IF ( LADJ_FDEP .and. ( .not. LADJ_FDEP ) + & .and. ( .not. LADJ_WDEP_LS ) + & .and. ( .not. LADJ_WDEP_CV ) ) THEN + CALL ERROR_STOP(' No deposition option selected ', + & ' input_adj_mod.f ') + ENDIF + + ! Regional mask? + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.f' ) + READ( SUBSTRS(1:N), * ) LFORCE_MASK + + IF ( LFORCE_MASK ) THEN + + !fp add option for nc file + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_observation_menu:13.b1') + + READ( SUBSTRS(1:N), * ) LFORCE_MASK_BPCH + + IF ( LFORCE_MASK_BPCH ) THEN + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_observation_menu:13.b2' ) + + READ( SUBSTRS(1:N), '(a)' ) FORCING_MASK_FILE + CALL CHECK_FILE( FORCING_MASK_FILE ) + + ELSE + + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_observation_menu:13.b2' ) + + ENDIF + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_observation_menu:13.b3') + + READ( SUBSTRS(1:N), * ) LFORCE_MASK_NC + + IF ( LFORCE_MASK_NC ) THEN + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_observation_menu:13.b4' ) + + READ( SUBSTRS(1:N), '(a)' ) FORCING_MASK_FILE_NC + + CALL CHECK_FILE( FORCING_MASK_FILE_NC ) + + CALL SPLIT_ONE_LINE( SUBSTRS, NB_MASK_VAR, -1, + & 'read_observation_menu:13.b5' ) + + ALLOCATE( FORCING_MASK_VARIABLE( NB_MASK_VAR ), STAT = AS ) + + DO N = 1, NB_MASK_VAR + FORCING_MASK_VARIABLE( N ) = TRIM( SUBSTRS(N) ) + ENDDO + + ELSE + + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_observation_menu:13.b5' ) + + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_observation_menu:13.b5' ) + + ENDIF + + ELSE + + ! skip lines + ! bpch switch + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:13.a1') + + ! bpch file + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:13.a2') + + ! nc switch + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:13.a3') + + ! nc file + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:13.a4') + + ! nc variable + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:13.a5') + + ENDIF + + IF ( LFORCE_MASK ) THEN + IF ( LFORCE_MASK_BPCH .and. LFORCE_MASK_NC ) THEN + CALL ERROR_STOP(' Two mask files are defined', + & ' input_adj_mod.f ') + ENDIF + + IF ( .not. LFORCE_MASK_BPCH .and. .not. LFORCE_MASK_NC ) THEN + CALL ERROR_STOP(' No mask file is defined', + & ' input_adj_mod.f ') + ENDIF + + ENDIF + + !================================================================= + ! Tracer observations + !================================================================= + + ! Separator line: >------------------------------< + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:11b') + + + ! Number of tracers to observe + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:12' ) + READ( SUBSTRS(1:N), * ) NOBS + + ! Separator line: => obs these tracers------> : TRC# tracer_name + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:13' ) + + IF ( NOBS > 0 ) THEN + DO T = 1, NOBS + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:14') + + ! tracer id number + READ( SUBSTRS(1), *) TMP + + ! tracer name + READ( SUBSTRS(2), *) TNAME(TMP) + + ! observe this species? + OBS_THIS_TRACER(TMP) = .TRUE. + + ! track tracer index + TRACER_IND(T) = TMP + + ENDDO + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:14b') + + ELSE + + ! Loop until at the next section + DO + + ! Read a line from the file + LINE = READ_ONE_LINE( EOF ) + + ! Stop reading lines when we've passed the Tracer section + IF ( .not. (INDEX( LINE, 'Tracer' ) > 0 ) ) EXIT + + ENDDO + + ENDIF + + !================================================================= + ! Species observations + !================================================================= + + ! Number of species to observe + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:15' ) + READ( SUBSTRS(1:N), * ) NOBS_CSPEC + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:15b') + + IF ( NOBS_CSPEC > 0 ) LCSPEC_OBS = .TRUE. + + IF ( ITS_A_FULLCHEM_SIM() .and. LCSPEC_OBS ) THEN + + ! First allocate OBS_THIS_SPECIES to be max species + ALLOCATE( OBS_THIS_SPECIES( NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS_THIS_SPECIES' ) + OBS_THIS_SPECIES = 0 + + ! + ALLOCATE( CNAME( NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CNAME' ) + CNAME = '' + + + DO T = 1, NOBS_CSPEC + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_observation_menu:17') + + ! Save species name + CNAME(T) = TRIM( SUBSTRS(1) ) + + ! observe this species? + OBS_THIS_SPECIES(T) = .TRUE. + + ENDDO + + ENDIF + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'OBSERVATION MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 110 ) 'Observation frequency : ', OBS_FREQ + IF ( LFD_GLOB ) THEN + !print*,' *** FD_GLOB: enforce values on LMAX_OBS and NSPAN ***' + print*,' *** FD_GLOB: enforce values on LMAX_OBS ***' + ENDIF + WRITE( 6, 100 ) 'Limit number of observations : ', LMAX_OBS + WRITE( 6, 150 ) 'Forcing time till : ', + & NYMDf, NHMSf + WRITE( 6, 110 ) ' NSPAN => ', NSPAN + WRITE( 6, '( a)' ) 'Cost function options :--- ' + WRITE( 6, 100 ) ' tracer kg/box : ', LKGBOX + WRITE( 6, 100 ) ' tracer ug/m3 : ', LUGM3 + WRITE( 6, 100 ) ' tracer ppb : ', LSTT_PPB + WRITE( 6, 100 ) ' tracer ppm free trop : ', + & LSTT_TROP_PPM + WRITE( 6, 100 ) ' species ppb w/averaging : ', LCSPEC_PPB + WRITE( 6, 100 ) ' tracer ug/m3 pop weighted : ', LPOP_UGM3 + WRITE( 6, 100 ) ' deposition based? : ', LADJ_FDEP + WRITE( 6, 100 ) ' => tracer dry dep : ', + & LADJ_DDEP_TRACER + WRITE( 6, 100 ) ' => species dry dep : ', + & LADJ_DDEP_CSPEC + WRITE( 6, 100 ) ' => wet LS deposition : ', + & LADJ_WDEP_LS + WRITE( 6, 100 ) ' => wet CV deposition : ', + & LADJ_WDEP_CV + IF (LADJ_FDEP) THEN + WRITE( 6, 140 ) ' Deposition : ', DEP_UNIT + ELSE + WRITE( 6, 140 ) ' Deposition : NONE ' + ENDIF + WRITE( 6, 100 ) ' Regional forcing mask? : ', + & LFORCE_MASK + IF ( LFORCE_MASK ) THEN + IF ( LFORCE_MASK_BPCH ) THEN + WRITE( 6, 140 ) ' => mask name : ', + & TRIM(FORCING_MASK_FILE) + ELSEIF ( LFORCE_MASK_NC ) THEN + WRITE( 6, 140 ) ' => mask name : ', + & TRIM(FORCING_MASK_FILE_NC) + DO N = 1,NB_MASK_VAR + WRITE( 6, 140 ) ' => varname : ', + & TRIM(FORCING_MASK_VARIABLE(N)) + ENDDO + ENDIF + ELSE + WRITE( 6, 140 ) ' => mask name : ', + & 'NOT USED' + ENDIF + WRITE( 6, '( a)' ) '>------------------------------<' + WRITE( 6, 110 ) 'Number of tracers to observe : ', NOBS + + IF ( NOBS > 0 ) THEN + WRITE( 6, '( a)' ) ' Tracers to observe ' + + ! Print info about each tracer + DO T = 1, N_TRACERS + + IF( OBS_THIS_TRACER(T) ) THEN + ! Write tracer number, name and if it's observed + WRITE( 6, 130 ) T, TNAME(T) + ENDIF + + ENDDO + + ENDIF + + IF ( LCSPEC_OBS ) THEN + WRITE( 6, '( a)' ) REPEAT( '-', 48 ) + WRITE( 6, 110 ) 'Number of species to observe : ', + & NOBS_CSPEC + WRITE( 6, '( a)' ) ' Species to observe ' + + ! Print info about each tracer + DO T = 1, NOBS_CSPEC + + ! Write tracer number, name and if it's observed + WRITE( 6, 120 ) T, CNAME(T) + + ENDDO + + ENDIF + + + + 100 FORMAT( A, L5 ) + 110 FORMAT( A, I5 ) + 120 FORMAT( I3, 1x, A10 ) + 130 FORMAT( I3, 1x, A10, 6x, I5 ) + 140 FORMAT( A, A ) + 150 FORMAT( A, I8, 1x, I6 ) + + ! Set counter + CT1 = CT1 + 1 + + + END SUBROUTINE READ_OBSERVATION_MENU + +!--------------------------------------------------------------------------------------- + + SUBROUTINE READ_FD_MENU +! +!****************************************************************************** +! Subroutine READ_FD_MENU reads the FINITE DIFFERENCE MENU section of +! the GEOS-CHEM adj input file (adj_group, 6/08/09) +! +! NOTES: +! (1 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : FD_DIFF + USE ADJ_ARRAYS_MOD, ONLY : LONFD + USE ADJ_ARRAYS_MOD, ONLY : LATFD + USE ADJ_ARRAYS_MOD, ONLY : IFD + USE ADJ_ARRAYS_MOD, ONLY : JFD + USE ADJ_ARRAYS_MOD, ONLY : LFD + USE ADJ_ARRAYS_MOD, ONLY : NFD + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + USE ADJ_ARRAYS_MOD, ONLY : EMSFD + USE ADJ_ARRAYS_MOD, ONLY : MFD + USE ADJ_ARRAYS_MOD, ONLY : STRFD + USE DRYDEP_MOD, ONLY : NTRAIND + USE DRYDEP_MOD, ONLY : NUMDEP + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_BOUNDING_BOX + USE GRID_MOD, ONLY : GET_XMID + USE GRID_MOD, ONLY : GET_YMID + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE LOGICAL_MOD, ONLY : LTRAN + USE WETSCAV_MOD, ONLY : GET_WETDEP_IDWETD + USE WETSCAV_MOD, ONLY : NSOL + USE ADJ_ARRAYS_MOD, ONLY : RATFD + + ! Local variables + INTEGER :: N + REAL*8 :: tmpbox(4) + INTEGER :: tmpbox1(4) + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + LOGICAL :: USEINDEX = .FALSE. + INTEGER :: IFDTMP, JFDTMP + + !================================================================= + ! READ_FD_MENU begins here! + !================================================================= + + ! FD difference size + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:1' ) + READ( SUBSTRS(1:N), * ) FD_DIFF + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_fd_menu:1.5' ) + + ! if we're doing global check, then exit + ! But it is still nice to define IFD, JFD, LFD, etc, if LPRINTFD + ! is on. Returning here makes these ind undefined, + ! which lead to seg faults (dkh, 06/11/09) + !IF ( LFD_GLOB ) THEN + ! PRINT*, 'All gridboxes are used in the global FD test' + ! RETURN + !ENDIF + + ! longitude of the FD gridbox + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:5' ) + READ( SUBSTRS(1:N), * ) LONFD + + ! latitude of the FD gridbox + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:6' ) + READ( SUBSTRS(1:N), * ) LATFD + + ! check if we're specifying indecies (as opposed to lat/lon) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:2' ) + READ( SUBSTRS(1:N), * ) USEINDEX + + ! IFD gridbox + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:3' ) + READ( SUBSTRS(1:N), * ) IFDTMP + + ! JFD gridbox + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:4' ) + READ( SUBSTRS(1:N), * ) JFDTMP + + ! get corresponding box indecies for the LONFD and LATFD + tmpbox(1) = LONFD + tmpbox(2) = LATFD + tmpbox(3) = LONFD + tmpbox(4) = LATFD + + ! Move this below, as it doesn't work with nested domain (dkh, 01/19/12, adj32_015 ) + !CALL GET_BOUNDING_BOX(tmpbox,tmpbox1) + + IF ( USEINDEX ) THEN + IFD = IFDTMP + JFD = JFDTMP + + ! now also adjust LONFD and LATFD (dkh, 02/11/11) + LONFD = GET_XMID( IFD ) + LATFD = GET_YMID( JFD ) + + ELSE + + ! Moved here (dkh, 01/19/12, adj32_015) + CALL GET_BOUNDING_BOX(tmpbox,tmpbox1) + + IFD = tmpbox1(1) + JFD = tmpbox1(2) + ENDIF + + ! FD perturbation box level + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:7' ) + READ( SUBSTRS(1:N), * ) LFD + + ! FD perturbation species + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:8' ) + READ( SUBSTRS(1:N), * ) NFD + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_fd_menu:8.5' ) + + + ! FD perturbation box temporal element + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:9' ) + READ( SUBSTRS(1:N), * ) MFD + + ! FD perturbation species + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:10' ) + READ( SUBSTRS(1:N), * ) EMSFD + + ! FD perturbation species + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:11' ) + READ( SUBSTRS(1:N), * ) ICSFD + + ! FD perturbation species (hml, 08/11/11, adj32_025) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:12' ) + READ( SUBSTRS(1:N), * ) STRFD + + ! FD perturbation rate (tww, 05/15/12) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:13' ) + READ( SUBSTRS(1:N), * ) RATFD + + ! Move these to adjoint menu (dkh, 02/09/11) + !! Doing finite difference test in 1 gridbox + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:12' ) + !READ( SUBSTRS(1:N), * ) LFD_SPOT + ! + !! Doing finite difference test in all grid boxes, turn transport off + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:13' ) + !READ( SUBSTRS(1:N), * ) LFD_GLOB + ! + !! turn of transport for global FD test + !IF ( LFD_GLOB ) LTRAN = .FALSE. + ! + !! define a more generic LFDTEST flag if either method is true + !IF ( LFD_GLOB .OR. LFD_SPOT ) LFDTEST = .TRUE. + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'FINITE DIFFERENCE MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Finite diff. increment FD_DIFF: ', FD_DIFF + WRITE( 6, 120 ) 'Finite diff longitude LONFD : ', LONFD + WRITE( 6, 110 ) 'Finite diff long. index IFD : ', IFD + WRITE( 6, 120 ) 'Finite diff latitude LATFD : ', LATFD + WRITE( 6, 110 ) 'Finite diff lat. index JFD : ', JFD + WRITE( 6, 110 ) 'Finite diff vert index LFD : ', LFD + WRITE( 6, 110 ) 'FD species NFD : ', NFD + WRITE( 6, 110 ) 'FD time.group index MFD : ', MFD + WRITE( 6, 110 ) 'FD emiss EMSFD : ', EMSFD + WRITE( 6, 110 ) 'FD initial cond ICSFD : ', ICSFD + WRITE( 6, 110 ) 'FD strat prod & loss STRFD : ', STRFD + WRITE( 6, 110 ) 'FD reaction rate RATFD : ', RATFD + !WRITE( 6, 130 ) 'Doing finite diff check (1box): ', LFD_SPOT + !WRITE( 6, 130 ) 'Doing finite diff check (glob): ', LFD_GLOB + + ! Format statements + 100 FORMAT( A, f11.6 ) + 110 FORMAT( A, I4 ) + 120 FORMAT( A, f7.2 ) + 130 FORMAT( A, L5 ) + + !================================================================= + ! Call setup routines from other GEOS-CHEM modules + !================================================================= + + ! Set counter + CT1 = CT1 + 1 + + ! Return to calling program + END SUBROUTINE READ_FD_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ADJ_DIAGNOSTICS_MENU +! +!****************************************************************************** +! Subroutine READ_ADJ_DIAGNOSTICS_MENU reads the DIAGNOSTICS MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Add LITR (zhe, dkh, 02/04/11) +! (2 ) Add LTRAJ_SCALE (dkh, 02/09/11) +! (3 ) Add LEMS_ABS, LTES_BLVMR (dkh, 02/17/11) +! (4 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE CHARPAK_MOD, ONLY : STRREPL + USE LOGICAL_ADJ_MOD, ONLY : LADJDIAG + USE LOGICAL_ADJ_MOD, ONLY : LJSAVE + USE LOGICAL_ADJ_MOD, ONLY : LADJ_TRAJ + USE LOGICAL_ADJ_MOD, ONLY : LDCOSAT + USE LOGICAL_ADJ_MOD, ONLY : LHMOD + USE LOGICAL_ADJ_MOD, ONLY : LhOBS + USE LOGICAL_ADJ_MOD, ONLY : LHMODIFF + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FORCE + USE LOGICAL_ADJ_MOD, ONLY : LMODBIAS + USE LOGICAL_ADJ_MOD, ONLY : LOBS_COUNT + USE LOGICAL_ADJ_MOD, ONLY : LDOFS + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE LOGICAL_ADJ_MOD, ONLY : LITR + USE LOGICAL_ADJ_MOD, ONLY : LTRAJ_SCALE + USE LOGICAL_ADJ_MOD, ONLY : LTES_BLVMR + USE LOGICAL_ADJ_MOD, ONLY : LEMS_ABS + USE LOGICAL_ADJ_MOD, ONLY : LSAT_HDF_L2, LSAT_HDF_L3 + + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + ! (dkh, 01/09/12, adj32_010) + LOGICAL :: EOF + INTEGER :: IOS + CHARACTER(LEN=1) :: TAB = ACHAR(9) + CHARACTER(LEN=1) :: SPACE = ' ' + CHARACTER(LEN=255) :: LINE + + !================================================================= + ! READ_ADJ_SIMULATION_MENU begins here! + !================================================================= + + LJSAVE = .FALSE. + LADJ_TRAJ = .FALSE. + LHMOD = .FALSE. + LhOBS = .FALSE. + LHMODIFF = .FALSE. + LADJ_FORCE = .FALSE. + LMODBIAS = .FALSE. + LOBS_COUNT = .FALSE. + LDOFS = .FALSE. + LITR = .FALSE. + LTRAJ_SCALE= .FALSE. + LTES_BLVMR = .FALSE. + LEMS_ABS = .FALSE. + LSAT_HDF_L2= .FALSE. + LSAT_HDF_L3= .FALSE. + + + ! Save any diagnostics? If not, exit subroutine with all flags FALSE + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:1' ) + READ( SUBSTRS(1:N), * ) LADJDIAG + + IF ( .NOT. LADJDIAG ) THEN + WRITE( 6, '(/,a)' ) 'SKIPPING DIAGNOSTICS MENU' + RETURN + ENDIF + + ! PRINT debug messages in FD cell files + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:2' ) + READ( SUBSTRS(1:N), * ) LPRINTFD + + ! Move to other menu (dkh, 02/09/11) + !! Delete checkpt files + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:2.1' ) + !READ( SUBSTRS(1:N), * ) LDEL_CHKPT + + ! SAVE .save and .sav2 files + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:3' ) + READ( SUBSTRS(1:N), * ) LJSAVE + + ! Save adjoint trajectory files + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:4' ) + READ( SUBSTRS(1:N), * ) LADJ_TRAJ + + ! save STT adjoints as scaling factor sensitivities? + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:4.0' ) + READ( SUBSTRS(1:N), * ) LTRAJ_SCALE + + ! Save iteration information + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:4.1' ) + READ( SUBSTRS(1:N), * ) LITR + + ! Save sense w.r.t absolute emis + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:4.2' ) + READ( SUBSTRS(1:N), * ) LEMS_ABS + + ! CO satellite diagnostics? if not, don't read the next 7 lines + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:5' ) + READ( SUBSTRS(1:N), * ) LDCOSAT + + IF ( LDCOSAT ) THEN + + ! Save H(model), model *ak + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:6' ) + READ( SUBSTRS(1:N), * ) LHMOD + + ! Save h(obs), gridded and filtered observations + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:7' ) + READ( SUBSTRS(1:N), * ) LhOBS + + ! Save H(mod) - h(obs) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:8' ) + READ( SUBSTRS(1:N), * ) LHMODIFF + + ! Save adjoint forcing + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:9' ) + READ( SUBSTRS(1:N), * ) LADJ_FORCE + + ! Save model bias (H(model)-h(obs))/h(obs) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:10' ) + READ( SUBSTRS(1:N), * ) LMODBIAS + + ! Save observation count (array with count/box) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:11' ) + READ( SUBSTRS(1:N), * ) LOBS_COUNT + + ! Save gridded DOFs + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:12' ) + READ( SUBSTRS(1:N), * ) LDOFs + + !---------------------------------------------------------------- + ! BUG FIX: Allow for proper reading of menu below the CO sub menu + ! (dkh, 01/08/12, adj32_010) + ! OLD CODE: + !ENDIF + ! + !! Separator line: TES NH3 diagnostics + !CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_fd_menu:8.5' ) + ! NEW CODE: + ELSE + + DO WHILE ( INDEX( LINE, 'TES NH3 diagnostics' ) .le. 0 ) + + ! still need to advance through the file + LINE = READ_ONE_LINE( EOF ) + IF ( EOF ) EXIT + + ! Replace tab characters in LINE (if any) w/ spaces + CALL STRREPL( LINE, TAB, SPACE ) + + ENDDO + + ENDIF + !---------------------------------------------------------------- + + ! Save BLVMR + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:12' ) + READ( SUBSTRS(1:N), * ) LTES_BLVMR + + ! Separator line: >------------------------------< + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:13') + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:14' ) + READ( SUBSTRS(1:N), * ) LSAT_HDF_L2 + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:15' ) + READ( SUBSTRS(1:N), * ) LSAT_HDF_L3 + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'DIAGNOSTICS MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Print adj debug LPRINTFD : ', LPRINTFD + !WRITE( 6, 100 ) 'Delete chkpt files LDEL_CHKPT : ', LDEL_CHKPT + WRITE( 6, 100 ) 'Save .jsave and .jsave2 files : ', LJSAVE + WRITE( 6, 100 ) 'Adjoint trajectory files : ', LADJ_TRAJ + WRITE( 6, 100 ) ' w.r.t. scaling factors : ', + & LTRAJ_SCALE + WRITE( 6, 100 ) 'Save iteration diagnostics : ', LITR + WRITE( 6, 100 ) 'Save sense w.r.t absolute emis: ', LEMS_ABS + IF ( LEMS_ABS ) PRINT*, ' ### WARNING: LEMS_ABS only for SO2, BC' + WRITE( 6, 100 ) 'Save CO sat. diagnostics : ', LDCOSAT + + IF ( LDCOSAT) THEN + WRITE( 6, 100 ) 'Save H(model) : ', LHMOD + WRITE( 6, 100 ) 'Save h(obs) : ', LhOBS + WRITE( 6, 100 ) 'Save H(model)-h(obs) : ', LHMODIFF + WRITE( 6, 100 ) 'Save adjoint forcing : ', LADJ_FORCE + WRITE( 6, 100 ) 'Save model bias : ', LMODBIAS + WRITE( 6, 100 ) 'Save number of obs/gridbox : ', LOBS_COUNT + WRITE( 6, 100 ) 'Save gridded DOFs : ', LDOFS + ENDIF + + WRITE( 6, 100 ) 'TES NH3 BLVMR : ', LTES_BLVMR + WRITE( 6, 100 ) 'HDF Level 2 : ',LSAT_HDF_L2 + WRITE( 6, 100 ) 'HDF Level 3 : ',LSAT_HDF_L3 + + ! Format statements + 100 FORMAT( A, L5 ) + + !================================================================= + ! Call setup routines from other GEOS-CHEM modules + !================================================================= + + ! Set counter + CT1 = CT1 + 1 + + ! Return to calling program + END SUBROUTINE READ_ADJ_DIAGNOSTICS_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ADJ_CRITICAL_LOAD_MENU +!fp +!add new menu to streamline the inputs for critical load sensitivity simulations + + USE CRITICAL_LOAD_MOD, ONLY : CL_FILENAME + USE CRITICAL_LOAD_MOD, ONLY : GC_FILENAME + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CL + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CL_NDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CL_ACID + +# include "CMN_SIZE" + + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + REAL*8 :: MASK(IIPAR,JJPAR) + + + !================================================================= + ! READ_ADJ_CRITICAL_LOAD begins here! + !================================================================= + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_critical_load_menu:1' ) + READ( SUBSTRS(1:N), * ) LADJ_CL + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_critical_load_menu:2' ) + READ( SUBSTRS(1:N), * ) LADJ_CL_NDEP + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_critical_load_menu:3' ) + READ( SUBSTRS(1:N), * ) LADJ_CL_ACID + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_critical_load_menu:2' ) + READ( SUBSTRS(1:N), '(a)' ) CL_FILENAME + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_critical_load_menu:3' ) + READ( SUBSTRS(1:N), '(a)' ) GC_FILENAME + + + WRITE( 6, '(/,a)' ) 'CRITICAL LOAD MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Doing critical load run : ', + & LADJ_CL + WRITE( 6, 100 ) ' => based on N deposition : ', + & LADJ_CL_NDEP + WRITE( 6, 100 ) ' => based on acid deposition : ', + & LADJ_CL_ACID + WRITE( 6, '( a)' ) ' Critical Load base file : ', + & TRIM(CL_FILENAME) + WRITE( 6, '( a)' ) ' GC Load file : ', + & TRIM(GC_FILENAME) + + 100 FORMAT( A, L5 ) + + ! Return to calling program + END SUBROUTINE READ_ADJ_CRITICAL_LOAD_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE ARE_FLAGS_VALID( ) +! +!****************************************************************************** +! Subroutine ARE_FLAGS_VALID checks to make sure that flags for the forward +! calculation (set in input.geos) do not confict with flags for the adjoint +! calculation (set in input.gcadj ). (dkh, 11/02/05, adj_group 6/07/09) +! +! NOTES: +! (1 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (2 ) Add LINVH_BFGS (nab, 25/03/12) +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : OBS_FREQ + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, EMSFD + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EBCPI_an, IDADJ_EBCPO_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EOCPI_an, IDADJ_EOCPO_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EBCPI_bb, IDADJ_EBCPO_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EOCPI_bb, IDADJ_EOCPO_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EBCPI_bf, IDADJ_EBCPO_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EOCPI_bf, IDADJ_EOCPO_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_na + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_sh + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_an1 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_an2 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EDST1, IDADJ_EDST2 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EDST3, IDADJ_EDST4 + USE ADJ_ARRAYS_MOD, ONLY : N_CARB_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_SULF_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_DUST_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IS_CARB_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IS_SULF_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IS_DUST_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_SPECIES + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_EMS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : ICS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, STRFD + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_PROD + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_LOSS + USE ADJ_ARRAYS_MOD, ONLY : PROD_ERROR + USE ADJ_ARRAYS_MOD, ONLY : LOSS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : NRRATES, RATFD + USE ADJ_ARRAYS_MOD, ONLY : OBS_FREQ + USE ADJ_ARRAYS_MOD, ONLY : CNAME + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LDRYD, LCHEM, LTURB, + & LCHEM, LWETD, LTRAN, + & LCONV, LSOILNOX, LSCHEM + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CHEM, LAERO_THERM, LADJ_TRAN, + & LSENS, LFDTEST, L4DVAR, + & LICS, LADJ_EMS, LFD_GLOB, + & LBKCOV, LADJ, LLINOZ, + & L3DVAR, LCSPEC_PPB, LCSPEC_OBS, + & LEMS_ABS, LAPSRC, LINVH, + & LINVH_BFGS, + & LADJ_STRAT, LADJ_RRATE, + & LADJ_FDEP, + & LADJ_DDEP_TRACER, + & LADJ_DDEP_CSPEC, + & LADJ_WDEP_LS, + & LADJ_WDEP_CV, + & LMAX_OBS + USE ADJ_ARRAYS_MOD, ONLY : OBS_FREQ + USE LOGICAL_ADJ_MOD, ONLY : LKGNHAYR + USE LOGICAL_ADJ_MOD, ONLY : LEQHAYR + USE LOGICAL_ADJ_MOD, ONLY : LMOLECCM2S + USE LOGICAL_ADJ_MOD, ONLY : LKGS + USE TIME_MOD, ONLY : GET_TIME_AHEAD + USE TIME_MOD, ONLY : GET_NYMDe + USE TIME_MOD, ONLY : GET_NHMSe + USE TRACER_MOD, ONLY : N_TRACERS, ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGOX_SIM + USE TRACER_MOD, ONLY : SIM_TYPE + USE TRACERID_MOD, ONLY : IDTSO4, IDTDST1, IDTSOA1 + USE TRACERID_MOD, ONLY : IDTSALA + USE TRACERID_MOD, ONLY : IDTNIT, IDTNH4, IDTNH3 + USE TRACERID_MOD, ONLY : IDTHNO3, IDTSO2 + USE LOGICAL_ADJ_MOD, ONLY : LSAT_HDF_L2, LSAT_HDF_L3 + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CL, LADJ_CL_NDEP, LADJ_CL_ACID + USE TRACER_MOD, ONLY : TRACER_NAME + USE GCKPP_ADJ_GLOBAL, ONLY: NCOEFF_RATE + +# include "CMN_SIZE" ! Size params +# include "comode.h" ! NAMEGAS, SMAL2 +# include "define_adj.h" +# include "CMN_DIAG" ! ND44 + + + + ! local variables + INTEGER :: N,T + CHARACTER(LEN=255) :: MSG + INTEGER :: COUNT_ON + + INTEGER, PARAMETER :: N_NDEP = 4 !number of tracers for N deposition + INTEGER, PARAMETER :: N_ACID = 2 !number of tracers for acid deposition (on top of N_NDEP tracers) + INTEGER, PARAMETER :: N_NDEP_CSPEC = 7 + INTEGER :: NDEP(N_NDEP), ACID(N_ACID) + INTEGER :: DATE(2) + CHARACTER*255 :: NDEP_CSPEC(N_NDEP_CSPEC) + LOGICAL :: FOUND + + !NITS and SO4S are not supported at the moment for wet/dry deposition (fp 1/5/2013) + + NDEP(1) = IDTHNO3 + NDEP(2) = IDTNIT + NDEP(3) = IDTNH3 + NDEP(4) = IDTNH4 + ACID(1) = IDTSO2 + ACID(2) = IDTSO4 + + NDEP_CSPEC(1) = 'DRYHNO3' + NDEP_CSPEC(2) = 'DRYNO2' + NDEP_CSPEC(3) = 'DRYPAN' + NDEP_CSPEC(4) = 'DRYPPN' + NDEP_CSPEC(5) = 'DRYPMN' + NDEP_CSPEC(6) = 'DRYN2O5' + NDEP_CSPEC(7) = 'DRYR4N2' + + !================================================================= + ! ARE_FLAGS_VALID begins here! + !================================================================= + + ! check if we are even doing an adjoint run + IF ( .not. LADJ ) RETURN + + !================================================================= + ! Check forward model options + !================================================================= + ! first check if "input.geos" is set to a supported simulation: + IF ( SIM_TYPE .NE. 7 .AND. ! FULL CHEM + & SIM_TYPE .NE. 3 .AND. ! TAGGED CO + & SIM_TYPE .NE. 9 .AND. ! CH4 (kjw, adj32_023) + & SIM_TYPE .NE. 6 .and. ! TAGGED OX (lzh, 12/12/2009) + & SIM_TYPE .NE.10 .and. ! Offline aerosol (adj32_013) + & SIM_TYPE .NE. 12) THEN ! TAGGED CO2 + CALL ERROR_STOP( ' This simulation is not supported ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! So far only BC and OC will work with the offline aerosol sim, + ! but not the other aerosols (well, dust might, but untested). + ! (yhmao, dkh, 01/13/12, adj32_013) + IF ( SIM_TYPE == 10 ) THEN + IF ( IDTSO4 .or. IDTSALA .or. IDTSOA1 ) THEN + CALL ERROR_STOP('offline aero adj only for dust and BC/OC', + & ' ARE_FLAGS_VALID, input_adj_mod.f' ) + ENDIF + ENDIF + + !================================================================= + ! Check forward and adjoint process options + !================================================================= + ! Much of the relevant aerosol chemistry is DRYDEP, and adjoint + ! of sulfate chemistry will get called if LADJ_CHEM is true, + ! so we shouldn't have DRYDEP = FALSE and LADJ_CHEM = TRUE. + ! Should this depend on LSULF at all? +! IF ( ( LADJ_CHEM .AND. ( .NOT. LDRYD ) ) .OR. +! & ( LDRYD .AND. ( .NOT. LADJ_CHEM ) ) ) THEN + ! I think we can have DRYD w/o chem + IF ( ITS_A_FULLCHEM_SIM() .AND. + & LADJ_CHEM .AND. ( .NOT. LDRYD ) ) THEN + CALL ERROR_STOP( ' LADJ_CHEM and LDRYD inconsistent ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + +! Not sure about this, leave it out for now (dkh, 06/24/09) +! ! Don't know why, but if WETD, and CHEM are only fwd true +! ! and LADJ_CHEM is only adj true, get error. Have to turn +! ! on LTRAN. ( though just WETD, no adj_chem, no TRAN, seems ok). +! ! something to do with RH? I think there may be others that +! ! require LTRAN.... The error pops up as "Invalid EXTRA", caused +! ! because TS_DYN is 60. +! IF ( LCHEM .AND. ( .NOT. LTRAN ) ) THEN +! CALL ERROR_STOP( ' LCHEM and LTRAN inconsistent ', +! & ' ARE_FLAGS_VALID, geos_chem_mod.f ' ) +! ENDIF + + ! LCHEM controls chemistry in the fwd calc, so need this on + ! if want aerosol thermo or the rest of chemistry. + IF ( ( LAERO_THERM .OR. LADJ_CHEM ) + & .AND. ( .NOT. LCHEM ) ) THEN + CALL ERROR_STOP( ' LCHEM, LADJ_CHEM, LAERO_THERM inconsistent', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + ! ... and the opposite... + IF ( .not. ( LADJ_CHEM ) + & .and. ( LCHEM ) ) THEN + CALL ERROR_STOP( ' LADJ_CHEM off but LCHEM is on! ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! If you have LTURB and LTRAN, but nothing else, adjoints explode. + ! (dkh, 11/22/05) + IF ( LTURB .AND. LTRAN .AND. LTRAN .AND. ( .NOT. LCONV ) + & .AND. ( .NOT. LWETD ) .AND. ( .NOT. LCHEM ) ) THEN + CALL ERROR_STOP( ' LTURB and LTRAN lead to errors in adj? ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + + ! Now use new strat_chem_mod (hml, dkh, 02/14/12, adj32_025) + !! Make sure that if strat fluxes are on, LINOZE adj is on (dkh, 04/25/10) + !IF ( LUPBD /= LLINOZ ) THEN + ! CALL ERROR_STOP( ' LUPBD and LLINOZ not consistent ', + ! ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + !ENDIF + + + ! Only include adjoint w.r.t strat fluxes if strat chem is turned on + IF ( LADJ_STRAT .and. ( .not. LSCHEM ) ) THEN + CALL ERROR_STOP( ' LADJ_STRAT needs LSCHEM on ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + !================================================================= + ! Check adjoint simulation type + ! + ! Overall simulation type must be one and only one of: + ! - 3DVAR + ! - 4DVAR + ! - SENS + !================================================================= + ! check at least one: + IF ( (.not. LSENS ) .and. ( .not. L3DVAR ) + & .and. ( .not. L4DVAR ) ) THEN + MSG = 'Invalid adj run options: no simulation type defined!' + CALL ERROR_STOP( MSG, 'ARE_FLAGS_VALID ("input_adj_mod.f")' ) + ! check not more than one: + ENDIF + IF ( ( LSENS .AND. L4DVAR ) .or. + & ( LSENS .AND. L3DVAR ) .or. + & ( L4DVAR .AND. L3DVAR ) ) THEN + CALL ERROR_STOP( 'Either sensitivity or a var, pick only one!', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + + !================================================================= + ! Check adjoint simulation subtypes + !================================================================= +#if defined ( PM_ATTAINMENT ) || defined ( SOMO35_ATTAINMENT ) + IF ( OBS_FREQ /= 60 ) THEN + CALL ERROR_STOP( ' OBS_FREQ should be 60 for attainment ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF +#endif + + !If none of the datasets are selected or PSEUDO_OBS FLAG, then it should be + ! 3DVAR and 4DVAR + ! add IMPROVE_BC_OC_OBS (adj32_013), MODIS_AOD_OBS (adj32_011) + ! add OMI_SO2_OBS () + ! add MOPITT_V5_CO_OBS (adj32_016) + ! add CH4 (kjw, dkh, 02/12/12, adj32_023) + IF ( L3DVAR .or. L4DVAR ) THEN +#if !defined(MOPITT_V5_CO_OBS) && !defined(MOPITT_V6_CO_OBS) && !defined(MOPITT_V7_CO_OBS) && !defined(AIRS_CO_OBS) && !defined(SCIA_BRE_CO_OBS) && !defined(TES_NH3_OBS)&& !defined(SCIA_DAL_SO2_OBS) && !defined(PM_ATTAINMENT) && !defined(IMPROVE_SO4_NIT_OBS) && !defined(CASTNET_NH4_OBS) && !defined(SOMO35_ATTAINMENT) && !defined(TES_O3_OBS)&& !defined(SCIA_KNMI_NO2_OBS) && !defined(SCIA_DAL_NO2_OBS) && !defined(PSEUDO_OBS) && !defined(GOSAT_CO2_OBS) & !defined(MODIS_AOD_OBS) && !defined(IMPROVE_BC_OC_OBS) && !defined(TES_CH4_OBS) && !defined(SCIA_CH4_OBS) && !defined(MEM_CH4_OBS) && !defined(LEO_CH4_OBS) && !defined(GEOCAPE_CH4_OBS) && !defined( TES_O3_IRK ) && !defined( OMI_SO2_OBS ) && !defined( OMI_NO2_OBS ) && !defined( OMI_CH2O_OBS ) && !defined( MLS_HNO3_OBS ) && !defined( MLS_O3_OBS ) && !defined( IASI_O3_OBS ) && !defined( IASI_CO_OBS ) && !defined( OSIRIS_OBS ) && !defined( OSIRIS_NO2_OBS) + MSG = 'Invalid adj run options: need to define obs for xDVAR' + CALL ERROR_STOP( MSG, 'ARE_FLAGS_VALID ("input_adj_mod.f")' ) +#endif + ENDIF + + ! Conversely, if any of the obs operators are defined, then make sure it is + ! a 3DVAR or 4DVAR simulation + ! add IMPROVE_BC_OC_OBS (adj32_013), MODIS_AOD_OBS (adj32_011) + ! add OMI_SO2_OBS () + ! add MOPITT_V5_CO_OBS (adj32_016) + ! add CH4 (kjw, dkh, 02/12/12, adj32_023) +#if defined(MOPITT_V5_CO_OBS) || defined(MOPITT_V6_CO_OBS) || defined(MOPITT_V7_CO_OBS) || defined(AIRS_CO_OBS) || defined(SCIA_BRE_CO_OBS) || defined(TES_NH3_OBS) || defined(SCIA_DAL_SO2_OBS) || defined(PM_ATTAINMENT) || defined(IMPROVE_SO4_NIT_OBS) || defined(CASTNET_NH4_OBS) || defined(SOMO35_ATTAINMENT) || defined(TES_O3_OBS) || defined(SCIA_KNMI_NO2_OBS) || defined(SCIA_DAL_NO2_OBS) || defined(GOSAT_CO2_OBS) || defined(MODIS_AOD_OBS) || defined(IMPROVE_BC_OC_OBS) || defined(TES_CH4_OBS) || defined(SCIA_CH4_OBS) || defined(MEM_CH4_OBS) || defined(LEO_CH4_OBS) || defined(GEOCAPE_CH4_OBS) || defined(TES_O3_IRK) || defined(OMI_SO2_OBS) || defined( OMI_NO2_OBS ) || defined(OMI_CH2O_OBS) || defined( MLS_HNO3_OBS ) || defined( MLS_O3_OBS ) || defined( IASI_O3_OBS ) || defined( IASI_CO_OBS ) || defined( OSIRIS_OBS ) || defined( OSIRIS_NO2_OBS ) || defined(PSEUDO_OBS) + + IF ( .not. ( L3DVAR .or. L4DVAR ) ) THEN + MSG = 'Invalid adj run options: need to define VAR for obs' + CALL ERROR_STOP( MSG, 'ARE_FLAGS_VALID ("input_adj_mod.f")') + ENDIF +#endif + + IF ( LSAT_HDF_L2 .or. LSAT_HDF_L3 ) THEN +#if !defined(MOPITT_V5_CO_OBS) && !defined(MOPITT_V6_CO_OBS) && !defined(MOPITT_V7_CO_OBS) && !defined( OMI_SO2_OBS ) && !defined( OMI_NO2_OBS ) + MSG = 'Invalid adj run options: Satellite HDF diagnostics are + & only supported by OMI, TES and MOPITT obs operator for xDVAR' + CALL ERROR_STOP( MSG, 'ARE_FLAGS_VALID ("input_adj_mod.f")' ) +#endif + ENDIF + + ! If we are using real observations, make sure pseudo obs are commented (mak, dkh, 10/01/09) + ! add IMPROVE_BC_OC_OBS (adj32_013), MODIS_AOD_OBS (adj32_011) + ! add OMI_SO2_OBS () + ! add MOPITT_V5_CO_OBS (adj32_016) + ! add CH4 (kjw, dkh, 02/12/12, adj32_023) +#if defined(MOPITT_V5_CO_OBS) || defined(MOPITT_V6_CO_OBS) || defined(MOPITT_V7_CO_OBS) || defined(AIRS_CO_OBS) || defined(SCIA_BRE_CO_OBS) || defined(TES_NH3_OBS) || defined(SCIA_DAL_SO2_OBS) || defined(PM_ATTAINMENT) || defined(IMPROVE_SO4_NIT_OBS) || defined(CASTNET_NH4_OBS) || defined(SOMO35_ATTAINMENT) || defined(TES_O3_OBS) || defined(SCIA_KNMI_NO2_OBS) || defined(SCIA_DAL_NO2_OBS) || defined(GOSAT_CO2_OBS) || defined(MODIS_AOD_OBS) || defined(IMPROVE_BC_OC_OBS) || defined(TES_CH4_OBS) || defined(SCIA_CH4_OBS) || defined(MEM_CH4_OBS) || defined(LEO_CH4_OBS) || defined(GEOCAPE_CH4_OBS) || defined(TES_O3_IRK) || defined(OMI_SO2_OBS) || defined( OMI_NO2_OBS ) || defined(OMI_CH2O_OBS) || defined( MLS_HNO3_OBS ) || defined( MLS_O3_OBS ) || defined( IASI_O3_OBS ) || defined( IASI_CO_OBS ) || defined( OSIRIS_OBS ) || defined( OSIRIS_NO2_OBS ) + + +#if defined(PSEUDO_OBS) + IF ( L4DVAR ) THEN + MSG = 'Invalid adj options: define real or pseudo obs' + CALL ERROR_STOP( MSG, 'ARE_FLAGS_VALID ("input_adj_mod.f")') + ENDIF +#endif + +#endif + ! ( LFDTEST .AND. .NOT. LSENS ) LSENS = .TRUE. + IF ( LFDTEST .AND. (.not. LSENS ) ) THEN + CALL ERROR_STOP( 'FD tests are a subtpye of SENS', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + + IF ( LFDTEST .AND. LICS .AND. LADJ_EMS ) THEN + CALL ERROR_STOP( 'FD test for ems AND ics not supported', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( LFDTEST .and. + & ( ( N_CALC_STOP > 3 ) .or. + & ( N_CALC_STOP < 1 ) ) ) THEN + CALL ERROR_STOP( 'FD tests need to have 1 < N_CALC_STOP < 3', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( LFDTEST .AND. LFD_GLOB .AND. LTRAN ) THEN + CALL ERROR_STOP( 'FD_GLOB should be done with transport off', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! Estimating inv Hessian only supported for 4DVar (dkh, 01/12/12, adj32_012) + IF ( ( LINVH .or. LINVH_BFGS ) .and. ( .not. L4DVAR ) ) THEN + CALL ERROR_STOP( 'LINVH and LINVH_BFGS only with 4DVAR ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! RTFD should equal the "Rate #" listed in input.gcadj (or RF_IDX) + ! corresponding to the listed rate we wish to test + IF ( LFDTEST .and. LADJ_RRATE ) THEN + IF ( RATFD > NRRATES ) THEN + CALL ERROR_STOP('Invalid RTFD', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + ENDIF + + IF ( .NOT. LADJ_RRATE .AND. ( NCOEFF_RATE .NE. 0 ) ) + & CALL ERROR_STOP('Invalid NCOEFF_RATE', 'ARE_FLAGS_VALID, + & input_adj_mod.f ') + + !================================================================= + ! Check adjoint control parameters + !================================================================= + IF ( (.not. LICS ) .AND. ( .not. LADJ_EMS ) ) THEN + CALL ERROR_STOP( 'Must select either ICS or EMS ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! LADJ_STRAT is a sub-type of LADJ_EMS (dkh, 02/23/12, adj32_025) + IF ( ( LADJ_STRAT ) .AND. ( .not. LADJ_EMS ) ) THEN + CALL ERROR_STOP( 'LADJ_STRAT is a sub-type of LADJ_EMS', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! check settings for tagged Ox sim + IF ( ITS_A_TAGOX_SIM() ) THEN + IF ( LICS ) THEN + CALL ERROR_STOP( 'Tagged OX adjoint only LADJ_EMS ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + IF ( MMSCL .ne. LLPAR ) THEN + CALL ERROR_STOP( 'Need MMSCL = LLPAR for tag ox adj ' , + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + ENDIF + + IF ( IFD .GT. IIPAR ) THEN + CALL ERROR_STOP( ' IFD has to be less than IIPAR !', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( JFD .GT. JJPAR ) THEN + CALL ERROR_STOP( ' JFD has to be less than JJPAR !', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( LFD .GT. LLPAR ) THEN + CALL ERROR_STOP( ' LFD has to be less than LLPAR !', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( NFD .GT. N_TRACERS ) THEN + CALL ERROR_STOP( ' NFD has to be less than number of tracers!', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( ICSFD .GT. N_TRACERS ) THEN + CALL ERROR_STOP( ' ICSFD has to be < number of tracers!', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! (dkh, 11/11/09) + IF ( LADJ_EMS ) THEN + IF ( EMSFD .GT. NNEMS ) THEN + CALL ERROR_STOP( + & ' EMSFD has to be < number of active adj emissons!', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + ENDIF + + ! (dkh, 01/12/12, adj32_012) +! IF ( LINVH .and. ( .not. LADJ_EMS .or. LICS ) ) THEN +! CALL ERROR_STOP( ' LINVH only supported for LADJ_EMS ', +! & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) +! ENDIF +! IF ( ( LINVH .or. LINVH_BFGS ) .and. +! & ( .not. LADJ_EMS .or. LICS ) ) THEN +! CALL ERROR_STOP( ' LINVH only supported for LADJ_EMS ', +! & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) +! ENDIF + + ! Check to make sure error specifications are usable for LAPSRC (dkh, 02/22/11) + IF ( LAPSRC ) THEN + + ! Check emissions + IF ( LADJ_EMS ) THEN + + DO N = 1, NNEMS + + ! Skip emissions that are not included in optimization + IF ( .not. OPT_THIS_EMS(N) ) CYCLE + + IF ( EMS_ERROR(N) < ( SMAL2 ) ) THEN + print*, ' EMS_ERROR stop at N = ', N + CALL ERROR_STOP( ' EMS_ERROR is too small ', + & ' input_adj_mod.f ' ) + ENDIF + + ENDDO + + ! Check strat prod and loss tracers (hml, adj32_025) + IF ( LADJ_STRAT ) THEN + + DO N = 1, NSTPL + + ! Skip tracers that are not included in optimization + IF (.not. OPT_THIS_PROD(N) .AND. + & .not. OPT_THIS_LOSS(N)) CYCLE + + IF ( PROD_ERROR(N) < ( SMAL2 ) ) THEN + print*, ' PROD_ERROR stop at N = ', N + CALL ERROR_STOP( ' PROD_ERROR is too small ', + & ' input_adj_mod.f ' ) + ENDIF + + IF ( LOSS_ERROR(N) < ( SMAL2 ) ) THEN + print*, ' LOSS_ERROR stop at N = ', N + CALL ERROR_STOP( ' LOSS_ERROR is too small ', + & ' input_adj_mod.f ' ) + ENDIF + ENDDO + ENDIF + + ! Check tracers + ELSEIF ( LICS ) THEN + + DO N = 1, N_TRACERS + + ! Skip tracers that are not included in optimization + IF ( .not. OPT_THIS_TRACER(N) ) CYCLE + +#if defined ( LOG_OPT ) + IF ( ICS_ERROR(N) < ( 1d0 + SMAL2 ) ) THEN + print*, ' ICS_ERROR stop at N = ', N + CALL ERROR_STOP( ' ICS_ERROR is too small ', + & ' input_adj_mod.f ' ) + ENDIF +#else + IF ( ICS_ERROR(N) < ( SMAL2 ) ) THEN + print*, ' ICS_ERROR stop at N = ', N + CALL ERROR_STOP( ' ICS_ERROR is too small ', + & ' input_adj_mod.f ' ) + ENDIF +#endif + ENDDO + ENDIF + ENDIF + + !================================================================= + ! Check observation settings + !================================================================= +#if defined ( SCIA_KNMI_NO2_OBS ) || defined ( SCIA_DAL_NO2_OBS ) + ! Since the NO2 obs operators will pass adjoints back + ! to CSPEC via CSPEC_AFTER_CHEM_ADJ, we need to make sure that + ! these species are listed as observed species + FOUND = .FALSE. + DO N = 1, NOBS_CSPEC + + IF ( TRIM( NAMEGAS( IDCSPEC_ADJ(N) ) ) == 'NO2' ) THEN + FOUND = .TRUE. + ENDIF + + ENDDO + IF ( .not. FOUND ) THEN + + CALL ERROR_STOP( ' Need to list NO2 as observed species', + & ' input_adj_mod ' ) + ENDIF + +! BUG FIX: move this to INIT_CSPEC_ADJ, by which point the necessary +! CSPEC variables have been initialized (nb, dkh, 01/06/12, adj32_002) +!-------------------------------------------------------------------- +!#elif defined ( TES_O3_OBS ) +! ! Since the O3 obs operators will pass adjoints back +! ! to CSPEC via CSPEC_AFTER_CHEM_ADJ, we need to make sure that +! ! these species are listed as observed species +! FOUND = .FALSE. +! DO N = 1, NOBS_CSPEC +! +! IF ( TRIM( NAMEGAS( IDCSPEC_ADJ(N) ) ) == 'O3' ) THEN +! FOUND = .TRUE. +! ENDIF +! +! ENDDO +! IF ( .not. FOUND ) THEN +! +! CALL ERROR_STOP( ' Need to list O3 as observed species', +! & ' input_adj_mod ' ) +! ENDIF +!-------------------------------------------------------------------- +#endif + + ! We only observe species in CSPEC for full chemistry runs + IF ( .not. ITS_A_FULLCHEM_SIM() .and. + & NOBS_CSPEC /= 0 ) THEN + CALL ERROR_STOP( ' NOBS_CSPEC needs to be zero', + & ' input_adj_mod ' ) + ENDIF + + ! If we are using CSPEC for the cost function, then + ! at least one species needs to be listed in the obsevation + ! menu. + IF ( LCSPEC_PPB .and. ( .not. LCSPEC_OBS ) ) THEN + CALL ERROR_STOP( + & ' Need to observe a cspec species for LCSPEC_PPB', + & ' input_adj_mod ' ) + ENDIF + + ! If we are doing a sensitivty calculation w.r.t. cspec + ! observations, then make sure we have the cspec-based + ! option selected. + IF ( LSENS .and. LCSPEC_OBS .and. ( .not. LCSPEC_PPB ) + & .and. ( .not. LADJ_DDEP_CSPEC ) ) THEN + CALL ERROR_STOP( + & ' Need to select a cost function option that uses CSPEC', + & ' input_adj_mod ' ) + ENDIF +#if defined ( PSEUDO_OBS ) + IF ( LCSPEC_OBS ) THEN + CALL ERROR_STOP( + & ' PSEUDO_OBS only implemented for tracer obs', + & ' input_adj_mod ' ) + ENDIF +#endif + +! ! The deposition forcings are cummulative, and the coding +! ! of the timing of the forcing assumes LMAX_OBS +! IF ( LADJ_FDEP .and. ( .not. LMAX_OBS ) ) THEN +! CALL ERROR_STOP (' Need LMAX_OBS = T and NSPAN for LADJ_FDEP', +! & ' input_adj_mod ' ) +! ENDIF + + ! Deposition forcing FD tests use forward model diagnostics + ! for evaluation of depo fluxes + IF ( LFD_GLOB .and. ( LADJ_DDEP_TRACER .or. LADJ_DDEP_CSPEC ) + & .and. ( ND44 == 0 ) ) THEN + CALL ERROR_STOP (' Turn on ND44 for dry dep forcing FD test ', + & ' input_adj_mod ' ) + ENDIF + + ! Only allow one dep forcing option at a time for FD tests + IF ( LFDTEST .and. LADJ_FDEP ) THEN + COUNT_ON = 0 + IF ( LADJ_WDEP_LS ) COUNT_ON = COUNT_ON + 1 + IF ( LADJ_WDEP_CV ) COUNT_ON = COUNT_ON + 1 + IF ( LADJ_DDEP_TRACER ) COUNT_ON = COUNT_ON + 1 + IF ( LADJ_DDEP_CSPEC ) COUNT_ON = COUNT_ON + 1 + IF ( COUNT_ON > 1 ) THEN + CALL ERROR_STOP (' Only one dep forcing for FD test ', + & ' input_adj_mod ' ) + ENDIF + IF ( COUNT_ON == 0 ) THEN + CALL ERROR_STOP (' Which dep forcing option do you want?', + & ' input_adj_mod ' ) + ENDIF + ENDIF + + ! Deposition forcing uses forward model diagnostics + ! for evaluation of depo fluxes + IF ( LADJ_WDEP_LS .and. ( ND39 == 0 ) ) THEN + CALL ERROR_STOP (' Turn on ND39 for wet LS forcing ', + & ' input_adj_mod ' ) + ENDIF + + ! Deposition forcing uses forward model diagnostics + ! for evaluation of depo fluxes + IF ( LADJ_WDEP_CV .and. ( ND38 == 0 ) ) THEN + CALL ERROR_STOP (' Turn on ND38 for wet CV forcing ', + & ' input_adj_mod ' ) + ENDIF + + ! Deposition forcing uses forward model diagnostics + ! for evaluation of depo fluxes + IF ( ( LADJ_DDEP_TRACER .or. LADJ_DDEP_CSPEC ) .and. + & ( ND44 == 0 ) ) THEN + CALL ERROR_STOP (' Turn on ND44 for DDEP forcing ', + & ' input_adj_mod ' ) + ENDIF + + ! FD test of the dry deposition adjoint only supported for molec/cm2/s + IF ( LFD_GLOB .and. ( LADJ_DDEP_TRACER .or. LADJ_DDEP_CSPEC ) + & .and. ( .not. LMOLECCM2S ) ) THEN + CALL ERROR_STOP (' Set units to molec/cm2/s for ddep FD test', + & ' input_adj_mod ' ) + ENDIF + + ! FD test of the wet deposition adjoint only supported for kg/s + IF ( LFD_GLOB .and. ( LADJ_WDEP_LS .or. LADJ_WDEP_CV ) + & .and. ( .not. LKGS ) ) THEN + CALL ERROR_STOP (' Set units to kg/s for wdep FD test', + & ' input_adj_mod ' ) + ENDIF + + ! Make sure that NFD matches the observed tracer or species + IF ( LFDTEST ) THEN + + ! check species + IF ( NOBS_CSPEC > 0 ) THEN + + IF ( NFD /= 1 .or. NOBS_CSPEC > 1 ) THEN + CALL ERROR_STOP( + & ' For species FD, list only one species and set NFD = 1', + & ' input_adj_mod' ) + ENDIF + + ! check tracers + ELSE + + IF ( .not. OBS_THIS_TRACER(NFD) ) THEN + CALL ERROR_STOP(' Observed tracer and NFD must match', + & ' input_adj_mod' ) + ENDIF + + IF ( NOBS > 1 ) THEN + CALL ERROR_STOP(' Only observe tracer NFD for FD test', + & ' input_adj_mod' ) + ENDIF + ENDIF + + ENDIF + + ! Check to make sure that our observation time range fits in the + ! simulation time range + IF ( LMAX_OBS ) THEN + DATE = GET_TIME_AHEAD( NSPAN * OBS_FREQ ) + print*, ' DDD DATE = ', DATE + print*, ' DDD NYMDe= ', GET_NYMDe() + print*, ' DDD NHMSe= ', GET_NHMSe() + IF ( ( DATE(1) > GET_NYMDe() ) .or. + & ( DATE(1) == GET_NYMDe().and. + & DATE(2) > GET_NHMSe() ) ) THEN + CALL ERROR_STOP(' NSPAN too long! ', + & ' input_adj_mod' ) + ENDIF + ENDIF + + !================================================================= + ! Check diagnostics + !================================================================= + IF ( LEMS_ABS .and. ( .not. LADJ_EMS ) ) THEN + CALL ERROR_STOP (' LEMS_ABS only for active vars = emissions', + & ' input_adj_mod ' ) + ENDIF + + !================================================================= + ! Check if all emissions adjoint ID #'s are defined for particular + ! sets of emissions species. + !================================================================= + + ! Primary carbonaceous aerosol emissions + IF ( IDADJ_EBCPI_an > 0 .and. IDADJ_EBCPO_an > 0 .and. + & IDADJ_EOCPI_an > 0 .and. IDADJ_EOCPO_an > 0 .and. + & IDADJ_EBCPI_bb > 0 .and. IDADJ_EBCPO_bb > 0 .and. + & IDADJ_EOCPI_bb > 0 .and. IDADJ_EOCPO_bb > 0 .and. + & IDADJ_EBCPI_bf > 0 .and. IDADJ_EBCPO_bf > 0 .and. + & IDADJ_EOCPI_bf > 0 .and. IDADJ_EOCPO_bf > 0 ) THEN + IS_CARB_EMS_ADJ = .TRUE. + ENDIF + IF ( N_CARB_EMS_ADJ > 0 .and. ( .not. IS_CARB_EMS_ADJ ) ) THEN + CALL ERROR_STOP( 'Not enough carbon emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + IF ( N_CARB_EMS_ADJ > 12 ) THEN + CALL ERROR_STOP( 'Too many carbon emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + + ! Sulfate aerosol (and precursor) emissions + IF ( IDADJ_ENH3_bb > 0 .and. IDADJ_ENH3_bf > 0 .and. + & IDADJ_ENH3_na > 0 .and. IDADJ_ENH3_an > 0 .and. + & IDADJ_ESO2_bb > 0 .and. IDADJ_ESO2_an1 > 0 .and. + & IDADJ_ESO2_bf > 0 .and. IDADJ_ESO2_an2 > 0 .and. + & IDADJ_ESO2_sh > 0 ) THEN + IS_SULF_EMS_ADJ = .TRUE. + ENDIF + IF ( N_SULF_EMS_ADJ > 0 .and. ( .not. IS_SULF_EMS_ADJ ) ) THEN + CALL ERROR_STOP( + & 'Not enough sulfate aerosol emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + IF ( N_SULF_EMS_ADJ > 9 ) THEN + CALL ERROR_STOP( 'Too many sulfate emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + + ! Dust aerosol emissions ( xxu, 11/01/10) (dkh, 01/09/12, adj32_011) + IF ( IDADJ_EDST1 > 0 .and. IDADJ_EDST2 > 0 .and. + & IDADJ_EDST3 > 0 .and. IDADJ_EDST4 > 0 ) THEN + IS_DUST_EMS_ADJ = .TRUE. + ENDIF + IF ( N_DUST_EMS_ADJ > 0 .and. ( .not. IS_DUST_EMS_ADJ ) ) THEN + CALL ERROR_STOP( + & 'Not enough Dust aerosol emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + IF ( N_DUST_EMS_ADJ > 4 ) THEN + CALL ERROR_STOP( 'Too many dust emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + + !================================================================= + ! Check consistency between input.gcadj and define_adj.h options + !================================================================= + + IF ( LBKCOV ) THEN + + IF ( LICS ) CALL ERROR_STOP( 'Off-diagonal calculation only + & works with LADJ_EMDS', 'ARE_FLAGS_VALID' ) + +#if ! defined ( LBKCOV_ERR ) + + CALL ERROR_STOP( 'Off-diagonal calculation requires LBKCOV_ERR + & to be set in define_adj.h ', 'ARE_FLAGS_VALID' ) + +#endif + ENDIF + +#if defined ( LBKCOV_ERR ) + IF ( .not. LBKCOV ) THEN + + CALL ERROR_STOP( 'Off-diagonal calculation requires LBKCOV + & to be set in input.gcadj ', 'ARE_FLAGS_VALID' ) + + ENDIF +#endif + + + IF ( LINVH_BFGS ) THEN +#if ! defined ( LBFGS_INV ) + + CALL ERROR_STOP( 'L-BFGS calculation requires LBFGS_INV + & to be set in define_adj.h ', 'ARE_FLAGS_VALID' ) + +#endif + ENDIF + +#if defined ( LBFGS_INV ) + IF ( .not. LINVH_BFGS ) THEN + + CALL ERROR_STOP( 'L-BFGS calculation requires an option + & to be set in input.gcadj ', 'ARE_FLAGS_VALID' ) + + ENDIF +#endif + + ! fp check for wetdep sensitivities: these units only make sense + ! if we observe one tracer or species at a time. + IF ( ( LKGS .OR. LMOLECCM2S ) .AND. + & ( ( NOBS_CSPEC .GT. 1 ) .OR. ( NOBS .GT. 1 ) ) ) THEN + + CALL ERROR_STOP(' Does not seem to make sense ?', + & 'ARE_FLAGS_VALID') + ENDIF + + !throw an error if kks and nobs_cspec>1 + IF ( LKGS .AND. ( NOBS_CSPEC .GT. 1) ) THEN + CALL ERROR_STOP(' not implemented', + & 'ARE_FLAGS_VALID') + ENDIF + + + IF ( LEQHAYR .OR. LKGNHAYR ) THEN + + DO T = 1, NOBS_CSPEC + + FOUND = .FALSE. + + DO N = 1, N_NDEP_CSPEC + + IF ( TRIM(CNAME(T)) + & .NE. TRIM(NDEP_CSPEC(N)) ) + & FOUND = .TRUE. + + ENDDO + + IF ( .not. FOUND ) THEN + WRITE(6,'( a )') CNAME(T) + CALL ERROR_STOP(' Does not seem to make sense ?', + & 'ARE_FLAGS_VALID') + ENDIF + + ENDDO + + DO T = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(T) ) THEN + + FOUND = .FALSE. + + DO N = 1,N_NDEP + + IF ( T .EQ. NDEP( N ) ) FOUND = .TRUE. + + ENDDO + + IF ( LEQHAYR ) THEN + + DO N = 1,N_ACID + + IF ( T .EQ. ACID(N) ) FOUND = .TRUE. + + ENDDO + + ENDIF + + IF ( .not. FOUND ) THEN + WRITE(6,*) 'TRACER: ',TRACER_NAME(T) + CALL ERROR_STOP(' Does not seem to make sense ?', + & 'ARE_FLAGS_VALID') + ENDIF + + ENDIF + ENDDO + + ENDIF + + IF ( LADJ_CL ) THEN + + IF ( .not. LADJ_CL_NDEP .and. + & .not. LADJ_CL_ACID ) THEN + + CALL ERROR_STOP(' Need to select N/Ac for Cl cost function', + & 'ARE_FLAGS_VALID') + + ENDIF + + IF ( LADJ_CL_NDEP .and. .not. LKGNHAYR ) + & CALL ERROR_STOP(' Units are inconsistent', + & 'ARE_FLAGS_VALID') + + + IF ( LADJ_CL_ACID .and. .not. LEQHAYR ) + & CALL ERROR_STOP(' Units are inconsistent', + & 'ARE_FLAGS_VALID') + + + IF ( .not. LADJ_DDEP_TRACER .OR. + & .not. LADJ_DDEP_CSPEC .OR. + & .not. LADJ_WDEP_LS .OR. + & .not. LADJ_WDEP_CV ) THEN + + CALL ERROR_STOP( + & ' All deposition flags need to be turned on', + & 'ARE_FLAGS_VALID') + + ENDIF + + DO T = 1, N_NDEP + + IF ( .not. OBS_THIS_TRACER( NDEP(T) ) ) THEN + + WRITE(*,*) 'TRACER: ',TRACER_NAME(NDEP(T)) + CALL ERROR_STOP( + & 'All N/Acid species need to be listed', + & 'ARE_FLAGS_VALID') + + ENDIF + + ENDDO + + IF ( LADJ_CL_ACID ) THEN + + DO T = 1, N_ACID + + IF ( .not. OBS_THIS_TRACER( ACID(T) ) ) THEN + + WRITE(*,*) 'TRACER: ',TRACER_NAME(ACID(T)) + + CALL ERROR_STOP( + & ' All N/Acid species need to be listed', + & 'ARE_FLAGS_VALID') + ENDIF + + ENDDO + + ENDIF + + DO N = 1, N_NDEP_CSPEC + + FOUND = .FALSE. + + DO T = 1, NOBS_CSPEC + + IF ( TRIM(CNAME(T)) + & .NE. TRIM(NDEP_CSPEC(N)) ) + & FOUND = .TRUE. + + ENDDO + + IF ( .not. FOUND ) THEN + + WRITE(*,*) 'CSPEC: ',TRIM(NDEP_CSPEC(N)) + CALL ERROR_STOP( + & ' All N/Acid species need to be listed', + & 'ARE_FLAGS_VALID') + ENDIF + + ENDDO + + + ENDIF + + + ! Return to calling program + END SUBROUTINE ARE_FLAGS_VALID + +!------------------------------------------------------------------------------ + + SUBROUTINE VALIDATE_DIRECTORIES +! +!****************************************************************************** +! Subroutine VALIDATE_DIRECTORIES makes sure that each of the directories +! that we have read from the GEOS-CHEM input file are valid. Also, trailing +! separator characters will be added. (bmy, 7/20/04, 8/4/06) +! +! NOTES: +! (1 ) Now make sure all USE statements are USE, ONLY. Now also validate +! GCAP and GEOS-5 directories. (bmy, 10/3/05) +! (2 ) Now references DATA_DIR_1x1 from directory_mod.f (bmy, 10/24/05) +! (3 ) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +!****************************************************************************** +! + ! References to F90 modules + ! References to F90 modules + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR, ADJTMP_DIR, DIAGADJ_DIR + + ! Local variables + CHARACTER(LEN=255) :: DIR + + !================================================================= + ! VALIDATE_DIRECTORIES begins here! + !================================================================= + + ! Check directories + CALL CHECK_DIRECTORY( OPTDATA_DIR ) + CALL CHECK_DIRECTORY( ADJTMP_DIR ) + CALL CHECK_DIRECTORY( DIAGADJ_DIR ) + + ! Return to calling program + END SUBROUTINE VALIDATE_DIRECTORIES + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_DIRECTORY( DIR ) +! +!****************************************************************************** +! Subroutine CHECK_DIRECTORY makes sure that the given directory +! is valid. Also a trailing slash character will be added if necessary. +! (bmy, 3/20/03, 3/23/05) +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) DIR (CHARACTER) : Directory to be checked +! +! NOTES: +! (1 ) Now references FILE_EXISTS from "file_mod.f" (bmy, 3/23/05) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE FILE_MOD, ONLY : FILE_EXISTS + USE UNIX_CMDS_MOD, ONLY : SEPARATOR + + ! Arguments + CHARACTER(LEN=*), INTENT(INOUT) :: DIR + + ! Local variables + INTEGER :: C + CHARACTER(LEN=255) :: MSG + + !================================================================= + ! CHECK_DIRECTORY begins here! + !================================================================= + + ! Locate the last non-white-space character of NEWDIR + C = LEN_TRIM( DIR ) + + ! Add the trailing directory separator if it is not present + IF ( DIR(C:C) /= TRIM( SEPARATOR ) ) THEN + DIR(C+1:C+1) = TRIM( SEPARATOR ) + ENDIF + + !================================================================= + ! Test if the directory actually exists + !================================================================= + + ! If the directory does not exist then stop w/ an error message + IF ( .not. FILE_EXISTS( DIR ) ) THEN + MSG = 'Invalid directory: ' // TRIM( DIR ) + CALL ERROR_STOP( MSG, 'CHECK_DIRECTORY ("input_adj_mod.f")' ) + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK_DIRECTORY + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_FILE( FILE ) +! +!****************************************************************************** +! Subroutine CHECK_FILE makes sure that the given file exists. (dkh, 03/10/13) +! Based on CHECK_DIR (bmy, 3/20/03, 3/23/05) +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) FILE (CHARACTER) : File to be checked +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE FILE_MOD, ONLY : FILE_EXISTS + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: FILE + + ! Local variables + CHARACTER(LEN=255) :: MSG + + !================================================================= + ! CHECK_FILE begins here! + !================================================================= + + ! If the directory does not exist then stop w/ an error message + IF ( .not. FILE_EXISTS( FILE ) ) THEN + MSG = 'Invalid file: ' // TRIM( FILE ) + CALL ERROR_STOP( MSG, 'CHECK_FILE ("input_adj_mod.f")' ) + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEAN_FILE_DIRS() +! +!****************************************************************************** +! Subroutine CLEAN_FILE_DIRS gets rid of files in ADJTMP_DIR and in OptData that +! are left over from previous runs. (10/28/04) +! +! +! NOTES: +! (1 ) If the last run to be computed completed cleanly, there will not be +! any *.chk.* files, and SYSTEM will complain a bit about this. It's OK +! (dkh, 10/03/04) +! (2 ) Add caviot that if L_MAKE_CHK is false, don't delete old *chk* files +! (3 ) Add feature to clean out OPTDATA_DIR (dkh, 10/28/04) +! (4 ) Delete *.ics.* and *.gdt.* files during observation run. (dkh, 11/11/04) +! (5 ) Delete cfn.* files during observation run. (dkh, 02/13/06) +! (6 ) Move from inverse_mod.f to input_adj_mod.f (dkh, 07/28/09) +! (7 ) Now clean out old ems.adj.* and gctm.iteration files (dkh, 02/17/11) +! (8 ) Now keep files for offline inv hessian (dkh, 01/12/12, adj32_012) +! (9 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (10 ) Add LINVH_BFGS (nab, 25/03/12 ) +!****************************************************************************** +! + ! Reference to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_STOP + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LEMS_ABS + USE LOGICAL_ADJ_MOD, ONLY : LITR + USE LOGICAL_ADJ_MOD, ONLY : LINVH,LINVH_BFGS + +# include "CMN_SIZE" ! Size params + + ! Local variables + CHARACTER(LEN=255) :: REMOVE_OBS_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_ADJ_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_OPT_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_FD_FILE_CMD + + !============================================================ + ! CLEAN_FILE_DIRS starts here! + !============================================================ + + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C L E A N O U T O L D F I L E S' + + IF ( N_CALC_STOP == 0 ) THEN + + ! Clear any old .obs. files + REMOVE_OBS_FILE_CMD = 'rm ' // + & TRIM( ADJTMP_DIR ) // '*.obs.*' + + WRITE( 6, 102 ) TRIM( REMOVE_OBS_FILE_CMD ) + 102 FORMAT( ' - INVERSE: Executing: ',a ) + + CALL SYSTEM( TRIM ( REMOVE_OBS_FILE_CMD ) ) + + ! Clean out old *.gdt.*, *.ics.* and cnf.* files + REMOVE_OPT_FILE_CMD = 'rm ' // + & TRIM (OPTDATA_DIR) // '*.gdt.*' + & // ' ' // + & TRIM (OPTDATA_DIR) // '*.sf.*' + & // ' ' // + & TRIM (OPTDATA_DIR) // 'cfn.*' + + WRITE( 6, 102 ) TRIM( REMOVE_OPT_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_OPT_FILE_CMD ) ) + + + ELSE + + + ! Clean out old .chk. files + REMOVE_CHK_FILE_CMD = 'rm ' // + & TRIM (ADJTMP_DIR) // '*.chk.*' + + WRITE( 6, 102 ) TRIM( REMOVE_CHK_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_CHK_FILE_CMD ) ) + + + ! Clean out old .adj. files + ! BUG FIX: the *.adj.* files are in DAIGADJ_DIR (jk, dkh, 04/25/10) + ! Update: be more specific here so that we don't delete ems.adj.NN + ! (dkh, 02/18/11) + ! Now keep these if doing inv Hessian update (dkh, 01/12/12, adj32_012) + IF ( .not. ( LINVH .or. LINVH_BFGS ) ) THEN + + REMOVE_ADJ_FILE_CMD = 'rm ' // + & TRIM (DIAGADJ_DIR) // 'gctm.adj.*' + + WRITE( 6, 102 ) TRIM( REMOVE_ADJ_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_ADJ_FILE_CMD ) ) + + ! Remove optimization files now, as would have been done normally + ! for the "REFERENCE" run at N_CALC_STOP = 0, as the JACOBIAN test + ! run begins with N_CALC_STOP = 1. + IF ( N_CALC_STOP == 1 ) THEN + + ! Clean out old *.gdt.*, *.ics.* and cnf.* files + REMOVE_OPT_FILE_CMD = 'rm ' // + & TRIM (OPTDATA_DIR) // '*.gdt.*' + & // ' ' // + & TRIM (OPTDATA_DIR) // '*.sf.*' + & // ' ' // + & TRIM (OPTDATA_DIR) // 'cfn.*' + + WRITE( 6, 102 ) TRIM( REMOVE_OPT_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_OPT_FILE_CMD ) ) + + ! Clean out old *.fd.* files (dkh, 06/24/09) + REMOVE_FD_FILE_CMD = 'rm ' // + & TRIM (DIAGADJ_DIR) // '*.fd.*' + & // ' ' // + & TRIM (DIAGADJ_DIR) // '*.fdglob.*' + + WRITE( 6, 102 ) TRIM( REMOVE_FD_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_FD_FILE_CMD ) ) + + ! Clean out old ems.adj.* files (dkh, 02/17/11) + IF ( LEMS_ABS ) THEN + REMOVE_ADJ_FILE_CMD = 'rm ' // + & TRIM (DIAGADJ_DIR) // 'ems.adj.*' + + WRITE( 6, 102 ) TRIM( REMOVE_ADJ_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_ADJ_FILE_CMD ) ) + ENDIF + + ! Clean out old gctm.iteration file (dkh, 02/17/11) + IF ( LITR ) THEN + REMOVE_ADJ_FILE_CMD = 'rm ' // + + & TRIM (DIAGADJ_DIR) // 'gctm.iteration' + + WRITE( 6, 102 ) TRIM( REMOVE_ADJ_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_ADJ_FILE_CMD ) ) + ENDIF + + ENDIF + + ENDIF ! LINV + + ENDIF + + END SUBROUTINE CLEAN_FILE_DIRS + +!----------------------------------------------------------------------------------------- + + SUBROUTINE INIT_DEP_MAPS +! +!****************************************************************************** +! Subroutine INIT_DEP_MAPS creates mapping arrays for going from tracer and +! species concentrations to deposition index. (dkh, 05/30/13) +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NOBS2NDEP + USE ADJ_ARRAYS_MOD, ONLY : NOBSCSPEC2NDEP + USE ADJ_ARRAYS_MOD, ONLY : NOBS2NWDEP + USE ADJ_ARRAYS_MOD, ONLY : NTR2NOBS + USE ADJ_ARRAYS_MOD, ONLY : TRACER_IND + USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE DRYDEP_MOD, ONLY : NTRAIND + USE DRYDEP_MOD, ONLY : NUMDEP + USE DRYDEP_MOD, ONLY : DEPNAME + USE ERROR_MOD, ONLY : ERROR_STOP + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRACER_MOD, ONLY : N_TRACERS + USE WETSCAV_MOD, ONLY : GET_WETDEP_IDWETD + USE WETSCAV_MOD, ONLY : NSOL + +# include "CMN_SIZE" +# include "comode.h" ! IRM + + ! Local variables + INTEGER :: N + INTEGER :: NN + INTEGER :: AS + INTEGER :: JJ + INTEGER :: NK + LOGICAL :: FOUND + + !================================================================= + ! INIT_DEP_MAPS begins here! + !================================================================= + + ALLOCATE( NOBS2NDEP( NOBS ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NOBS2NDEP' ) + NOBS2NDEP = 0 + + ALLOCATE( NOBSCSPEC2NDEP( NOBS_CSPEC ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NOBSCSPEC2NDEP' ) + NOBSCSPEC2NDEP = 0 + + ALLOCATE( NOBS2NWDEP( NOBS ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NOBS2NWDEP' ) + NOBS2NWDEP = 0 + + ALLOCATE( NTR2NOBS( N_TRACERS ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NTR2NOBS' ) + NTR2NOBS = 0 + + ! NOBS2NDEP: Map from NOBS to N_DEP (drydep id) + DO N = 1, NOBS + + DO NN = 1, NUMDEP + IF ( NTRAIND(NN) == TRACER_IND(N) ) NOBS2NDEP(N) = NN + ENDDO + + ENDDO + + ! NOBSCSPEC2NDEP: Map from NOBS_CSPEC to N_DEP (drydep id) + DO N = 1, NOBS_CSPEC + + !DO NN = 1, NUMDEP + ! this may not work since CNAME would by DRYNO2 and DEPNAME NO2? or NOx? + ! IF ( DEPNAME(NN) == CNAME(N) ) NOBSCSPEC2NDEP(N) = NN + ! ENDDO + + ! Determine drydep ID that corresponds to this species + NOBSCSPEC2NDEP(N) = -999 + NCS = NCSURBAN + + DO NN = 1, NUMDEP + + NK = NTDEP(NN) + IF ( NK <= 0 ) CYCLE + JJ = IRM(NPRODLO+1,NK,NCS) + IF ( JJ == IDCSPEC_ADJ(N) ) NOBSCSPEC2NDEP(N) = NN + + ENDDO + + IF ( NOBSCSPEC2NDEP(N) < 0 ) THEN + CALL ERROR_STOP('Species not in ND44','INIT_CSPEC_ADJ.f') + ENDIF + + ENDDO + + ! NOBS2NWDEP: Map from NOBS to N_WDEP (wetdep id) + DO N = 1, NOBS + + ! Get wetdep ID number for this observed tracer + DO NN = 1, NSOL + IF ( GET_WETDEP_IDWETD(NN) == TRACER_IND(N) ) + & NOBS2NWDEP(N) = NN + ENDDO + + ENDDO + + ! NTR2NOBS: Map from tracer index to observed tracer index + DO NN = 1, N_TRACERS + + DO N = 1, NOBS + + IF ( TRACER_IND(N) == NN ) NTR2NOBS(NN) = N + + ENDDO + + ENDDO + +! ! NTR2NOBSCSPEC: Map from tracer index to observed species index +! DO NN = 1, NTRACER +! +! DO N = 1, NOBS_CSPEC +! +! IF ( TRACER_IND(N) == NN ) NTR2NOBSCSPEC(NN) = N +! +! ENDDO +! +! ENDDO + + ! Return to calling program + END SUBROUTINE INIT_DEP_MAPS + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_INPUT_ADJ +! +!****************************************************************************** +! Subroutine INIT_INPUT_ADJ initializes all variables from +! "directory_adj_mod.f" and "logical_adj_mod.f" for safety's sake. +! (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Add LTES_PSO (kjw, dkh, 02/12/12, adj32_023) +! (2 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (3 ) Add LINVH_BFGS (nab, 25/03/12 ) +!****************************************************************************** +! + ! References to F90 modules + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR, ADJTMP_DIR, DIAGADJ_DIR + USE LOGICAL_ADJ_MOD, ONLY : LADJ,LADJ_TRAN, LADJ_CHEM, + & LAERO_THERM, LFD_SPOT, LFD_GLOB, + & LSENS, L4DVAR, L3DVAR, LAPSRC, + & LBKCOV,LINVH,LINVH_BFGS, + & LLINOZ, LFDTEST, LISO, + & LICS, LRXNR, LADJDIAG, LJSAVE, + & LDCOSAT, LHMOD, LHOBS, + & LHMODIFF, LADJ_FORCE, LMODBIAS, + & LOBS_COUNT, LDOFS, LADJ_EMS, + & LDEL_CHKPT, LADJ_TRAJ, LITR, + & LDEVOC, LTES_PSO, LADJ_STRAT, + & LADJ_RRATE, + & LADJ_CL, LADJ_CL_NDEP, LADJ_CL_ACID + + + !================================================================= + ! INIT_INPUT_ADJ begins here! + !================================================================= + + ! Initialize directories + OPTDATA_DIR = '' + DIAGADJ_DIR = '' + ADJTMP_DIR = '' + + ! Initialize logicals + LADJ = .FALSE. + LADJ_TRAN = .FALSE. + LADJ_CHEM = .FALSE. + LAERO_THERM = .FALSE. + LFD_SPOT = .FALSE. + LFD_GLOB = .FALSE. + LSENS = .FALSE. + L4DVAR = .FALSE. + L3DVAR = .FALSE. + LAPSRC = .FALSE. + LBKCOV = .FALSE. + LINVH = .FALSE. + LINVH_BFGS = .FALSE. + LISO = .FALSE. + !LLINOZ = .FALSE. + LFDTEST = .FALSE. + LADJ_EMS = .FALSE. + LICS = .FALSE. + LRXNR = .FALSE. + LADJDIAG = .FALSE. + LJSAVE = .FALSE. + LADJ_TRAJ = .FALSE. + LDCOSAT = .FALSE. + LHMOD = .FALSE. + LHOBS = .FALSE. + LHMODIFF = .FALSE. + LADJ_FORCE = .FALSE. + LMODBIAS = .FALSE. + LOBS_COUNT = .FALSE. + LDOFS = .FALSE. + LDEL_CHKPT = .FALSE. + LITR = .FALSE. + LDEVOC = .TRUE. + LTES_PSO = .FALSE. + LADJ_STRAT = .FALSE. + LADJ_RRATE = .FALSE. + LADJ_CL = .FALSE. + LADJ_CL_NDEP= .FALSE. + LADJ_CL_ACID= .FALSE. + + ! Initialize counters + CT1 = 0 + CT2 = 0 + CT3 = 0 + + ! Return to calling program + END SUBROUTINE INIT_INPUT_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_STRID_FILE +! +!****************************************************************************** +! Subroutine READ_STRID_FILE reads the list of stratospheric production +! and loss rates from STR_ID file in run directory. +! (hml, 05/22/13) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE ADJ_ARRAYS_MOD, ONLY : ID_PROD + USE ADJ_ARRAYS_MOD, ONLY : ID_LOSS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_PROD + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_LOSS + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : PROD_NAME + USE ADJ_ARRAYS_MOD, ONLY : LOSS_NAME + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_PROD + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_LOSS + USE ADJ_ARRAYS_MOD, ONLY : PROD_ERROR + USE ADJ_ARRAYS_MOD, ONLY : LOSS_ERROR + USE FILE_MOD, ONLY : IOERROR, IU_STR + + + ! local variables + INTEGER :: IOS + INTEGER :: T + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + + !================================================================= + ! READ_STRID_FILE begins here! + !================================================================= + + ! Open STR_ID file containing list of 24x2 strat prod & loss + OPEN( IU_STR, FILE='STR_ID', STATUS='OLD', IOSTAT=IOS ) + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_STR,'read_input_adj_strat:1') + + READ_STR_ID = .TRUE. + + ! Read a header line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_STR_ID:1') + + DO T = 1, NSTPL + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_strat_p') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_PROD(T) + + ! Save tracer name + PROD_NAME(T) = TRIM( SUBSTRS(2) ) + + ! optimize this strat prod & loss? + READ( SUBSTRS(3), *) OPT_THIS_PROD(T) + + ! Defualt prod scaling factor for this strat tracer + READ( SUBSTRS(4), *) PROD_SF_DEFAULT(T) + + ! REG_PARAM for this strat tracer + READ( SUBSTRS(5), *) REG_PARAM_PROD(T) + + ! STR_ERROR for this strat tracer + READ( SUBSTRS(6), *) PROD_ERROR(T) + + ENDDO + + DO T = 1, NSTPL + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1,'read_strat_l') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_LOSS(T) + + ! Save tracer name + LOSS_NAME(T) = TRIM( SUBSTRS(2) ) + + ! optimize this strat prod & loss? + READ( SUBSTRS(3), *) OPT_THIS_LOSS(T) + + ! Defualt loss scaling factor for this strat tracer + READ( SUBSTRS(4), *) LOSS_SF_DEFAULT(T) + + ! REG_PARAM for this strat tracer + READ( SUBSTRS(5), *) REG_PARAM_LOSS(T) + + ! STR_ERROR for this strat tracer + READ( SUBSTRS(6), *) LOSS_ERROR(T) + + ENDDO + + CLOSE(IU_STR) + + READ_STR_ID = .FALSE. + + ! Return to calling program + END SUBROUTINE READ_STRID_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_RXNID_FILE +! +!****************************************************************************** +! Subroutine READ_RXNID_FILE reads the list of kpp reactions +! from RXN_ID file in run directory. +! (hml, 05/22/13) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE FILE_MOD, ONLY : IOERROR, IU_RXN + USE ADJ_ARRAYS_MOD, ONLY : NRRATES + USE ADJ_ARRAYS_MOD, ONLY : ID_RRATES + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_RATE + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : RRATES_NAME + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_RATE + USE ADJ_ARRAYS_MOD, ONLY : RATE_ERROR + + ! local variables + INTEGER :: IOS + INTEGER :: N + INTEGER :: T + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + + !================================================================= + ! READ_RXNID_FILE begins here! + !================================================================= + + ! Open RXN_ID file containing list of 297 reactions + OPEN( IU_RXN, FILE='RXN_ID', STATUS='OLD', IOSTAT=IOS ) + + IF ( IOS /= 0 ) CALL IOERROR( + & IOS,IU_RXN,'read_input_adj_rrate:1') + + READ_RXN_ID = .TRUE. + + ! Read a header line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_RXN_ID:1') + + DO T = 1, NRRATES + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_RXN_ID:2') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_RRATES(T) + + ! Save tracer name + RRATES_NAME(T) = TRIM( SUBSTRS(2) ) + + ! Optimize this rate? + READ( SUBSTRS(3), * ) OPT_THIS_RATE(T) + + ! Default scaling factor for this rate + READ( SUBSTRS(4), * ) RATE_SF_DEFAULT(T) + + ! REG_PARAM for this rate + READ( SUBSTRS(5), * ) REG_PARAM_RATE(T) + + ! RATE_ERROR for this rate + READ( SUBSTRS(6), * ) RATE_ERROR(T) + + ENDDO + + CLOSE(IU_RXN) + + READ_RXN_ID = .FALSE. + + + ! Return to calling program + END SUBROUTINE READ_RXNID_FILE + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE INPUT_ADJ_MOD diff --git a/code/adjoint/input_adj_mod.f~ b/code/adjoint/input_adj_mod.f~ new file mode 100644 index 0000000..b096f24 --- /dev/null +++ b/code/adjoint/input_adj_mod.f~ @@ -0,0 +1,4146 @@ +!$Id: input_adj_mod.f,v 1.21 2012/08/10 22:08:22 nicolas Exp $ + MODULE INPUT_ADJ_MOD +! +!****************************************************************************** +! Module INPUT_ADJ_MOD reads the GEOS-Chem ADJOINT input file (input.gcadj) +! at the start of the inverse run and passes the information to several other +! GEOS-Chem F90 modules. It complements input.geos with adjoint specific flags +! and settings. Most of the code follows the convention from input_mod.f +! (adj_group, 6/6/09) +! +! Module Variables: +! ============================================================================ +! (1 ) VERBOSE (LOGICAL ) : Turns on echo-back of lines read from disk. +! (2 ) FIRSTCOL (INTEGER ) : First column of the input file (default=26) +! (3 ) MAXDIM (INTEGER ) : Maximum number of substrings to read in +! (9 ) FILENAME (CHAR*255) : GEOS-CHEM adjoint input file name +! (10) TOPTITLE (CHAR*255) : Top line of input file +! +! Module Routines: +! ============================================================================ +! (1 ) READ_INPUT_ADJ_FILE : Driver routine for reading GEOS-CHEM input file +! (2 ) READ_ONE_LINE : Reads one line at a time +! (3 ) SPLIT_ONE_LINE : Splits one line into substrings (by spaces) +! (4 ) READ_ADJ_SIMULATION_MENU : Reads the GEOS-Chem adjoint simulation menu +! (5 ) READ_FWD_MODEL_MENU : Reads forward model options +! (6 ) READ_ADJ_OPTIONS_MENU : Reads adjoint model options +! (7 ) READ_ADJ_DIRECTORIES_MENU : Reads the GEOS-Chem adj. directories +! (8 ) READ_CONTROL_VARS_MENU: Reads what are control variables +! (9 ) READ_OBSERVATION_MENU : Reads vars related to observations +! (10) READ_FD_ MENU : Reads finite difference test variables +! (11) READ_ADJ_DIAGNOSTICS_MENU : Reads the GEOS-Chem adj. diagnostic menu +! (12) VALIDATE_DIRECTORIES : Makes sure all given directories are valid +! (13) ARE_FLAGS_VALID : Makes sure all flags are valid/not conflicting +! (14) CHECK_DIRECTORY : Checks a single directory for errors +! (15) CLEAN_FILE_DIRS : Clean out directories +! (16) INIT_DEP_MAPS : Make mapping arrays for dep adjoint forcing +! (17) INIT_INPUT_ADJ : Initializes directory & logical variables +! +! GEOS-CHEM modules referenced by "input_adj_mod.f" +! ============================================================================ +! (1 ) directory_adj_mod.f : Module w/ GC adjoint directories +! (2 ) error_mod.f : Module w/ I/O error and NaN check routines +! (3 ) file_mod.f : Module w/ file unit numbers and error checks +! (4 ) grid_mod.f : Module w/ horizontal grid information +! (5 ) logical_adj_mod.f : Module w/ GC adjoint logical switches +! (6 ) adj_arrays_mod.f : Module w/ adj. arrays. +! NOTES: +! (1 ) Add LPOP_UGM3 (sev, dkh, 02/13/12, adj32_024) +! (2 ) Add LINVH_BFGS (nab, 25/03/12 ) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "input_adj_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: READ_INPUT_ADJ_FILE + PUBLIC :: INIT_DEP_MAPS + + !================================================================= + ! MODULE VARIABLES + !================================================================= + LOGICAL :: VERBOSE = .FALSE. + INTEGER, PARAMETER :: FIRSTCOL = 33 + INTEGER, PARAMETER :: MAXDIM = 255 + INTEGER :: CT1, CT2, CT3 + CHARACTER(LEN=255) :: FILENAME = 'input.gcadj' + CHARACTER(LEN=255) :: TOPTITLE + + ! For RRATE list + LOGICAL :: READ_STR_ID = .FALSE. + LOGICAL :: READ_RXN_ID = .FALSE. + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_INPUT_ADJ_FILE +! +!****************************************************************************** +! Subroutine READ_INPUT_ADJ_FILE is the driver program for reading the +! GEOS_CHEM adjoint input file "input.gcadj" from disk. (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Now call DO_GAMAP (dkh, 02/09/10) +! (2 ) Now call INIT_TRACERID_ADJ (dkh, 03/30/10) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : INIT_TRACERID_ADJ + USE CHARPAK_MOD, ONLY : STRREPL + USE FILE_MOD, ONLY : IU_GEOS, IOERROR + USE INPUT_MOD, ONLY : TRACERINFO, DIAGINFO + USE GAMAP_MOD, ONLY : DO_GAMAP + + ! Local variables + LOGICAL :: EOF + INTEGER :: IOS + CHARACTER(LEN=1) :: TAB = ACHAR(9) + CHARACTER(LEN=1) :: SPACE = ' ' + CHARACTER(LEN=255) :: LINE + + !================================================================= + ! READ_INPUT_ADJ_FILE begins here! + !================================================================= + + ! Echo output + WRITE( 6, '(a )' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' )'G E O S - C H E M A D J O I N T I N P U T' + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_INPUT_ADJ_FILE: Reading ', a ) + + ! Initialize directory & logical variables + CALL INIT_INPUT_ADJ + + ! Initialize adjoint tracer ID's to zero + CALL INIT_TRACERID_ADJ + + ! Open file + OPEN( IU_GEOS, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_GEOS,'read_input_adj_file:1') + + ! Read TOPTITLE for binary punch file + TOPTITLE = READ_ONE_LINE( EOF ) + IF ( EOF ) RETURN + + ! Loop until EOF + DO + + ! Read a line from the file, exit if EOF + LINE = READ_ONE_LINE( EOF ) + IF ( EOF ) EXIT + + ! Replace tab characters in LINE (if any) w/ spaces + CALL STRREPL( LINE, TAB, SPACE ) + + !============================================================= + ! Call individual subroutines to read sections of the file + !============================================================= + IF ( INDEX( LINE, 'ADJOINT SIMULATION MENU' ) > 0 ) THEN + CALL READ_ADJ_SIMULATION_MENU + + ELSE IF ( INDEX( LINE, 'FORWARD MODEL OPTIONS' ) > 0 ) THEN + CALL READ_FWD_MODEL_MENU + + ELSE IF ( INDEX( LINE, 'ADJOINT MODEL OPTIONS' ) > 0 ) THEN + CALL READ_ADJ_OPTIONS_MENU + + ELSE IF ( INDEX( LINE, 'DIRECTORIES' ) > 0 ) THEN + CALL READ_ADJ_DIRECTORIES_MENU + + ELSE IF ( INDEX( LINE, 'CONTROL VARIABLE MENU' ) > 0 ) THEN + CALL READ_CONTROL_VARS_MENU + + !mkeller: weak constraint menu + ELSE IF ( INDEX( LINE, 'WEAK CONSTRAINT MENU' ) > 0 ) THEN + CALL READ_WEAK_CONSTRAINT_MENU + + ELSE IF ( INDEX( LINE, 'OBSERVATION MENU' ) > 0 ) THEN + CALL READ_OBSERVATION_MENU + + ELSE IF ( INDEX( LINE, 'FINITE DIFFERENCE MENU' ) > 0 ) THEN + CALL READ_FD_MENU + + ELSE IF ( INDEX( LINE, 'DIAGNOSTICS MENU' ) > 0 ) THEN + CALL READ_ADJ_DIAGNOSTICS_MENU + + ELSE IF ( INDEX( LINE, 'CRITICAL LOAD MENU' ) > 0 ) THEN + CALL READ_ADJ_CRITICAL_LOAD_MENU + + ELSE IF ( INDEX( LINE, 'END OF FILE' ) > 0 ) THEN + EXIT + + ENDIF + ENDDO + + ! Close input file + CLOSE( IU_GEOS ) + + !================================================================= + ! Further error-checking and initialization + !================================================================= + + ! Make sure all directories are valid + CALL VALIDATE_DIRECTORIES + + ! Clean out file directories (rm *.chk.* , *.adj.* , *.sf.* and + ! *.gdt.* files ) + CALL CLEAN_FILE_DIRS + + ! Are all the flags a valid combination? + CALL ARE_FLAGS_VALID + + ! Echo output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Now call this routine here so that adjoint names have been + ! defined. (dkh, 02/09/10) + CALL DO_GAMAP( DIAGINFO, TRACERINFO ) + + ! Return to calling program + END SUBROUTINE READ_INPUT_ADJ_FILE + +!------------------------------------------------------------------------------ + + FUNCTION READ_ONE_LINE( EOF, LOCATION ) RESULT( LINE ) +! +!****************************************************************************** +! Subroutine READ_ONE_LINE reads a line from the input file. If the global +! variable VERBOSE is set, the line will be printed to stdout. READ_ONE_LINE +! can trap an unexpected EOF if LOCATION is passed. Otherwise, it will pass +! a logical flag back to the calling routine, where the error trapping will +! be done. (bmy, 7/20/04) +! +! Arguments as Output: +! =========================================================================== +! (1 ) EOF (CHARACTER) : Logical flag denoting EOF condition +! (2 ) LOCATION (CHARACTER) : Name of calling routine; traps premature EOF +! +! Function value: +! =========================================================================== +! (1 ) LINE (CHARACTER) : A line of text as read from the file +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE FILE_MOD, ONLY : IU_GEOS, IOERROR + USE FILE_MOD, ONLY : IU_RXN !(hml, 04/03/13) + USE FILE_MOD, ONLY : IU_STR !(hml, 05/22/13) + + ! Arguments + LOGICAL, INTENT(OUT) :: EOF + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: LOCATION + + ! Local variables + INTEGER :: IOS + CHARACTER(LEN=255) :: LINE, MSG + + !================================================================= + ! READ_ONE_LINE begins here! + !================================================================= + + ! Initialize + EOF = .FALSE. + + ! Read a line from the file (hml, 05/22/13) + IF ( READ_STR_ID ) READ ( IU_STR, '(a)', IOSTAT=IOS ) LINE + IF ( READ_RXN_ID ) READ ( IU_RXN, '(a)', IOSTAT=IOS ) LINE + IF ( .NOT. READ_STR_ID .AND. .NOT. READ_RXN_ID ) THEN + READ ( IU_GEOS,'(a)', IOSTAT=IOS ) LINE + ENDIF + + ! IO Status < 0: EOF condition + IF ( IOS < 0 ) THEN + EOF = .TRUE. + + ! Trap unexpected EOF -- stop w/ error msg if LOCATION is passed + ! Otherwise, return EOF to the calling program + IF ( PRESENT( LOCATION ) ) THEN + MSG = 'READ_ONE_LINE: error at: ' // TRIM( LOCATION ) + WRITE( 6, '(a)' ) MSG + WRITE( 6, '(a)' ) 'Unexpected end of file encountered!' + WRITE( 6, '(a)' ) 'STOP in READ_ONE_LINE (input_mod.f)' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + STOP + ELSE + RETURN + ENDIF + ENDIF + + ! IO Status > 0: true I/O error condition (hml, 05/22/13) + IF ( READ_STR_ID ) THEN + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_STR, 'read_one_line:1-a' ) + ENDIF + IF ( READ_RXN_ID ) THEN + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_RXN, 'read_one_line:1-b' ) + ENDIF + IF ( .NOT. READ_STR_ID .AND. .NOT. READ_RXN_ID ) THEN + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_GEOS,'read_one_line:1-c' ) + ENDIF + + ! Print the line (if necessary) + IF ( VERBOSE ) WRITE( 6, '(a)' ) TRIM( LINE ) + + ! Return to calling program + END FUNCTION READ_ONE_LINE + +!------------------------------------------------------------------------------ + + SUBROUTINE SPLIT_ONE_LINE( SUBSTRS, N_SUBSTRS, N_EXP, LOCATION ) +! +!****************************************************************************** +! Subroutine SPLIT_ONE_LINE reads a line from the input file (via routine +! READ_ONE_LINE), and separates it into substrings. (bmy, 7/20/04) +! +! SPLIT_ONE_LINE also checks to see if the number of substrings found is +! equal to the number of substrings that we expected to find. However, if +! you don't know a-priori how many substrings to expect a-priori, +! you can skip the error check. +! +! Arguments as Input: +! =========================================================================== +! (3 ) N_EXP (INTEGER ) : Number of substrings we expect to find +! (N_EXP < 0 will skip the error check!) +! (4 ) LOCATION (CHARACTER) : Name of routine that called SPLIT_ONE_LINE +! +! Arguments as Output: +! =========================================================================== +! (1 ) SUBSTRS (CHARACTER) : Array of substrings (separated by " ") +! (2 ) N_SUBSTRS (INTEGER ) : Number of substrings actually found +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE CHARPAK_MOD, ONLY: STRSPLIT + + ! Arguments + CHARACTER(LEN=255), INTENT(OUT) :: SUBSTRS(MAXDIM) + INTEGER, INTENT(OUT) :: N_SUBSTRS + INTEGER, INTENT(IN) :: N_EXP + CHARACTER(LEN=*), INTENT(IN) :: LOCATION + + ! Local varaibles + LOGICAL :: EOF + CHARACTER(LEN=255) :: LINE, MSG + + !================================================================= + ! SPLIT_ONE_LINE begins here! + !================================================================= + + ! Create error msg + MSG = 'SPLIT_ONE_LINE: error at ' // TRIM( LOCATION ) + + !================================================================= + ! Read a line from disk + !================================================================= + LINE = READ_ONE_LINE( EOF ) + + ! STOP on End-of-File w/ error msg + IF ( EOF ) THEN + WRITE( 6, '(a)' ) TRIM( MSG ) + WRITE( 6, '(a)' ) 'End of file encountered!' + WRITE( 6, '(a)' ) 'STOP in SPLIT_ONE_LINE (input_mod.f)!' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + STOP + ENDIF + + !================================================================= + ! Split the lines between spaces -- start at column FIRSTCOL + !================================================================= + CALL STRSPLIT( LINE(FIRSTCOL:), ' ', SUBSTRS, N_SUBSTRS ) + + ! Sometimes we don't know how many substrings to expect, + ! if N_EXP is greater than MAXDIM, then skip the error check + IF ( N_EXP < 0 ) RETURN + + ! Stop if we found the wrong + IF ( N_EXP /= N_SUBSTRS ) THEN + WRITE( 6, '(a)' ) TRIM( MSG ) + WRITE( 6, 100 ) N_EXP, N_SUBSTRS + WRITE( 6, '(a)' ) 'STOP in SPLIT_ONE_LINE (input_mod.f)!' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + STOP + 100 FORMAT( 'Expected ',i2, ' substrs but found ',i3 ) + ENDIF + + ! Return to calling program + END SUBROUTINE SPLIT_ONE_LINE + +!------------------------------------------------------------------------------ + +!MK-WEAK_CONSTRAINT: + SUBROUTINE READ_WEAK_CONSTRAINT_MENU +! +!****************************************************************************** +! Subroutine READ_WEAK_CONSTRAINT_MENU reads the WEAK CONSTRAINT MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! (1 ) first attempt at subroutine (mkeller) +!****************************************************************************** +! + ! References to F90 modules + USE WEAK_CONSTRAINT_MOD, ONLY : DO_WEAK_CONSTRAINT + USE WEAK_CONSTRAINT_MOD, ONLY : MIN_LON_U + USE WEAK_CONSTRAINT_MOD, ONLY : MAX_LON_U + USE WEAK_CONSTRAINT_MOD, ONLY : MIN_LAT_U + USE WEAK_CONSTRAINT_MOD, ONLY : MAX_LAT_U + USE WEAK_CONSTRAINT_MOD, ONLY : MIN_LEV_U_INDEX + USE WEAK_CONSTRAINT_MOD, ONLY : MAX_LEV_U_INDEX + USE WEAK_CONSTRAINT_MOD, ONLY : LEN_SUBWINDOW_U + USE WEAK_CONSTRAINT_MOD, ONLY : N_TRACER_U + USE TRACER_MOD, ONLY : N_TRACERS + USE ERROR_MOD, ONLY : ERROR_STOP + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + !================================================================= + ! READ_WEAK_CONSTRAINT_MENU begins here! + !================================================================= + + ! Check if we are running the weak constraint module at all + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:1') + READ( SUBSTRS(1:N), * ) DO_WEAK_CONSTRAINT + IF (.NOT. DO_WEAK_CONSTRAINT) THEN + PRINT*, 'NOT RUNNING WEAK CONSTRAINT MODEL!' + RETURN + ENDIF + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:2') + READ( SUBSTRS(1:N), * ) N_TRACER_U + + IF ( N_TRACER_U > N_TRACERS ) THEN + CALL ERROR_STOP( 'WC-Index bigger than total number of tracers', + & 'read_weak_constraint_menu, input_adj_mod.f') + ENDIF + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:3') + READ( SUBSTRS(1:N), * ) MIN_LON_U + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:4') + READ( SUBSTRS(1:N), * ) MAX_LON_U + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:5') + READ( SUBSTRS(1:N), * ) MIN_LAT_U + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:6') + READ( SUBSTRS(1:N), * ) MAX_LAT_U + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:7') + READ( SUBSTRS(1:N), * ) MIN_LEV_U_INDEX + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:8') + READ( SUBSTRS(1:N), * ) MAX_LEV_U_INDEX + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_weak_constraint_menu:9') + READ( SUBSTRS(1:N), * ) LEN_SUBWINDOW_U + + END SUBROUTINE READ_WEAK_CONSTRAINT_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ADJ_SIMULATION_MENU + +! +!****************************************************************************** +! Subroutine READ_ADJ_SIMULATION_MENU reads the SIMULATION MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Reordering and updates (dkh, 02/09/11) +!****************************************************************************** +! + ! References to F90 modules + USE LOGICAL_MOD, ONLY : LTRAN + USE LOGICAL_ADJ_MOD, ONLY : LADJ + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST + USE LOGICAL_ADJ_MOD, ONLY : LSENS + USE LOGICAL_ADJ_MOD, ONLY : L4DVAR + USE LOGICAL_ADJ_MOD, ONLY : L3DVAR + + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + !================================================================= + ! READ_ADJ_SIMULATION_MENU begins here! + !================================================================= + + ! Check if we are running the adjoint at all + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:1' ) + READ( SUBSTRS(1:N), * ) LADJ + IF (.NOT. LADJ) THEN + PRINT*, 'NOT RUNNING THE ADJOINT!' + RETURN + ENDIF + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_adj_sim_menu:2' ) + + !! Doing transport adjoint + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:2' ) + !READ( SUBSTRS(1:N), * ) LADJ_TRAN + + ! Doing 4DVAR + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:3' ) + READ( SUBSTRS(1:N), * ) L4DVAR + + ! Doing 3DVAR + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:4' ) + READ( SUBSTRS(1:N), * ) L3DVAR + + ! Doing sensitivity run (no differences in cost function, just tracer conc) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:5' ) + READ( SUBSTRS(1:N), * ) LSENS + + ! Move to FORWARD MODEL menu (dkh, 02/09/11) + !! Doing chemistry + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:3' ) + !READ( SUBSTRS(1:N), * ) LADJ_CHEM + ! + !! Doing aerosol thermodynamics + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:4' ) + !READ( SUBSTRS(1:N), * ) LAERO_THERM + + IF ( .NOT. ( LSENS .OR. L4DVAR .OR. L3DVAR ) ) THEN + PRINT*, '******************************************' + PRINT*, 'HAVE TO PICK A SIMULATION, READ THE MANUAL!' + PRINT*, '******************************************' + RETURN + ENDIF + + ! Check to see if its a finite difference calculation + IF ( LSENS ) THEN + + ! Doing finite difference test in 1 gridbox + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_menu:6' ) + READ( SUBSTRS(1:N), * ) LFD_SPOT + + ! Doing finite difference test in all grid boxes, turn transport off + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_menu:7' ) + READ( SUBSTRS(1:N), * ) LFD_GLOB + + ! turn of transport for global FD test + IF ( LFD_GLOB ) LTRAN = .FALSE. + + ! define a more generic LFDTEST flag if either method is true + IF ( LFD_GLOB .OR. LFD_SPOT ) LFDTEST = .TRUE. + + ENDIF + + ! Move these to other menus (dkh, 02/09/11) + !!================================================================= + !! Include a priori term of the cost function (the one without the data) + !! aka source term + !! aka background term + !! aka penalty term + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:10' ) + !READ( SUBSTRS(1:N), * ) LAPSRC + ! + !! Compute background error covariance + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:11' ) + !READ( SUBSTRS(1:N), * ) LBKCOV + ! + !! Compute approximation of inverse Hessian + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:12' ) + !READ( SUBSTRS(1:N), * ) LINVH + ! + !! include LINOZ + !! NOTE: This flag controls both forward and adjoint execution + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim_menu:13' ) + !READ( SUBSTRS(1:N), * ) LLINOZ + ! + !! Check if we are running the adjoint at all + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_sim _menu:14' ) + !READ( SUBSTRS(1:N), * ) LRXNR + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'ADJOINT SIMULATION MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Doing adjoint run : ', LADJ + !WRITE( 6, 100 ) 'Doing adjoint transport : ', LADJ_TRAN + !WRITE( 6, 100 ) 'Doing adjoint chemistry : ', LADJ_CHEM + !WRITE( 6, 100 ) 'Doing aerosol thermodynamics : ',LAERO_THERM + WRITE( 6, 100 ) 'Doing 4DVAR (inversion) : ', L4DVAR + WRITE( 6, 100 ) 'Doing 3DVAR : ', L3DVAR + WRITE( 6, 100 ) 'Doing sensitivity run : ', LSENS + !WRITE( 6, 100 ) 'Include source term in J : ', LAPSRC + !WRITE( 6, 100 ) 'Compute background error cov : ', LBKCOV + !WRITE( 6, 100 ) 'Compute inverse Hessian : ', LINVH + !WRITE( 6, 100 ) 'Use LINOZ (fwd and adj) : ', LLINOZ + !WRITE( 6, 100 ) 'Include reaction rates LRXNR : ', LRXNR + WRITE( 6, 100 ) 'Doing finite diff check (1box): ', LFD_SPOT + WRITE( 6, 100 ) 'Doing finite diff check (glob): ', LFD_GLOB + + + ! Format statements + 100 FORMAT( A, L5 ) + 110 FORMAT( A, I5 ) + + !================================================================= + ! Call setup routines from other GEOS-CHEM modules + !================================================================= + + ! Set counter + CT1 = CT1 + 1 + + ! Return to calling program + END SUBROUTINE READ_ADJ_SIMULATION_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_FWD_MODEL_MENU +! +!****************************************************************************** +! Subroutine READ_FWD_MODEL_MENU reads the FORWARD MODEL OPTIONS section of +! the GEOS-CHEM adjoint input file (dkh, 02/09/11) +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE LOGICAL_MOD, ONLY : LTRAN + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CHEM + !USE LOGICAL_ADJ_MOD, ONLY : LLINOZ + USE LOGICAL_ADJ_MOD, ONLY : LAERO_THERM + USE LOGICAL_ADJ_MOD, ONLY : LISO + + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + !================================================================= + ! READ_FWD_MODEL_MENU begins here! + !================================================================= + + ! Doing chemistry + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fwd_menu:1' ) + READ( SUBSTRS(1:N), * ) LADJ_CHEM + + ! Doing aerosol thermodynamics + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fwd_menu:2' ) + READ( SUBSTRS(1:N), * ) LAERO_THERM + + ! Use ISORROPIAII + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fwd_menu:3' ) + READ( SUBSTRS(1:N), * ) LISO + + ! Now use new strat_chem_mod (hml, dkh, 02/14/12, adj32_025) + !! include LINOZ + !! NOTE: This flag controls both forward and adjoint execution + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fwd_menu:3' ) + !READ( SUBSTRS(1:N), * ) LLINOZ + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'FORWARD MODEL OPTIONS' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Doing adjoint chemistry : ', LADJ_CHEM + WRITE( 6, 100 ) 'Doing aerosol thermodynamics : ',LAERO_THERM + WRITE( 6, 100 ) ' => ISORROPIAII : ', LISO + !WRITE( 6, 100 ) 'Use LINOZ (fwd and adj) : ', LLINOZ + + ! Format statements + 100 FORMAT( A, L5 ) + 110 FORMAT( A, I5 ) + + !================================================================= + ! Call setup routines from other GEOS-CHEM modules + !================================================================= + + ! Set counter + CT1 = CT1 + 1 + + ! Return to calling program + END SUBROUTINE READ_FWD_MODEL_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ADJ_OPTIONS_MENU +! +!****************************************************************************** +! Subroutine READ_ADJ_OPTIONS_MENU reads the ADJOINT MODEL OPTIONS section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Reordering and updates (dkh, 02/09/11) +! (2 ) Add LINVH_BFGS (nab, 25/03/12 ) +!****************************************************************************** +! + ! References to F90 modules + USE LOGICAL_MOD, ONLY : LTRAN + USE LOGICAL_ADJ_MOD, ONLY : LAPSRC + USE LOGICAL_ADJ_MOD, ONLY : LBKCOV + USE LOGICAL_ADJ_MOD, ONLY : LINVH, LINVH_BFGS + USE LOGICAL_ADJ_MOD, ONLY : LRXNR + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE LOGICAL_ADJ_MOD, ONLY : LFILL_ADJ + + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + !================================================================= + ! READ_ADJ_OPTIONS_MENU begins here! + !================================================================= + + ! Move these to other menus (dkh, 02/09/11) + !================================================================= + ! Include a priori term of the cost function (the one without the data) + ! aka source term + ! aka background term + ! aka penalty term + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:10' ) + READ( SUBSTRS(1:N), * ) LAPSRC + + ! Compute background error covariance + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:11' ) + READ( SUBSTRS(1:N), * ) LBKCOV + + ! Compute approximation of inverse Hessian + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:12' ) + READ( SUBSTRS(1:N), * ) LINVH + + ! Compute approximation of L-BFGS inverse Hessian + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:13' ) + READ( SUBSTRS(1:N), * ) LINVH_BFGS + + ! Compute reaction rate constant sensitivities + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:14' ) + READ( SUBSTRS(1:N), * ) LRXNR + + ! Delete checkpt files + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:15' ) + READ( SUBSTRS(1:N), * ) LDEL_CHKPT + + ! Scale up and FILL adj transport + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_opt_menu:15' ) + READ( SUBSTRS(1:N), * ) LFILL_ADJ + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'ADJOINT MODEL OPTIONS' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Include source term in J : ', LAPSRC + WRITE( 6, 100 ) 'Compute background error cov : ', LBKCOV + WRITE( 6, 100 ) 'Compute inverse Hessian : ', LINVH + WRITE( 6, 100 ) 'Compute L-BFGS inverse Hessian : ' + & , LINVH_BFGS + WRITE( 6, 100 ) 'Include reaction rates LRXNR : ', LRXNR + WRITE( 6, 100 ) 'Delete chkpt files LDEL_CHKPT : ', + & LDEL_CHKPT + WRITE( 6, 100 ) 'Scale up and FILL adj transport: ', LFILL_ADJ + + + ! Format statements + 100 FORMAT( A, L5 ) + 110 FORMAT( A, I5 ) + + !================================================================= + ! Call setup routines from other GEOS-CHEM modules + !================================================================= + + ! Set counter + CT1 = CT1 + 1 + + ! Return to calling program + END SUBROUTINE READ_ADJ_OPTIONS_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ADJ_DIRECTORIES_MENU +! +!****************************************************************************** +! Subroutine READ_ADJ_DIRECTORIES_MENU reads the DIRECTORIES MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR, ADJTMP_DIR, DIAGADJ_DIR + + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + !================================================================= + ! READ_ADJ_DIRECTORIES_MENU begins here! + !================================================================= + + ! Optimization output data dir + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_directories_menu:1' ) + READ( SUBSTRS(1:N), '(a)' ) OPTDATA_DIR + + ! Optimization temporary directory + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_directories_menu:2' ) + READ( SUBSTRS(1:N), '(a)' ) ADJTMP_DIR + + ! Optimization diagnostic file directory + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_directories_menu:2' ) + READ( SUBSTRS(1:N), '(a)' ) DIAGADJ_DIR + + WRITE( 6, '(/,a)' ) 'DIRECTORIES MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 110 ) 'Optimization output directory : ', + & TRIM( OPTDATA_DIR ) + WRITE( 6, 110 ) 'Temporary adjoint directory : ', + & TRIM( ADJTMP_DIR ) + WRITE( 6, 110 ) 'Diagnostic adjoint directory : ', + & TRIM( DIAGADJ_DIR ) + + 110 FORMAT( A, A ) + + ! Set counter + CT1 = CT1 + 1 + + + END SUBROUTINE READ_ADJ_DIRECTORIES_MENU +!--------------------------------------------------------------------------------------- +! +! SUBROUTINE READ_CONTROL_PARAMS_MENU +!! +!!****************************************************************************** +!! Subroutine READ_CONTROL_PARAMS_MENU reads the CONTROL PARAMETERS MENU section of +!! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +!! +!! NOTES: +!! (1 ) Add ICS_SF_tmp, EMS_SF_tmp (mak, dkh, 10/01/09) +!! (2 ) Merge this with CONTROL_VARS_MENU +!!****************************************************************************** +!! +! ! References to F90 modules +! USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS +! USE LOGICAL_ADJ_MOD, ONLY : LICS +! USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_tmp +! USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_tmp +! +! +! ! Local variables +! INTEGER :: N +! CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) +! +! !================================================================= +! ! READ_ADJ_SIMULATION_MENU begins here! +! !================================================================= +! +! ! Optimizing emissions +! CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_params_menu:1' ) +! READ( SUBSTRS(1:N), * ) LADJ_EMS +! +! ! Optimizing initial conditions +! CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_params_menu:3' ) +! READ( SUBSTRS(1:N), * ) LICS +! +! ! Optimizing initial conditions +! CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_params_menu:4' ) +! READ( SUBSTRS(1:N), * ) ICS_SF_tmp +! +! ! Optimizing initial conditions +! CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_params_menu:5' ) +! READ( SUBSTRS(1:N), * ) EMS_SF_tmp +! +! +! !================================================================= +! ! Print to screen +! !================================================================= +! WRITE( 6, '(/,a)' ) 'CONTROL PARAMETERS MENU' +! WRITE( 6, '( a)' ) '---------------' +! WRITE( 6, 100 ) 'Optimizing emissions : ', LADJ_EMS +! WRITE( 6, 100 ) 'Optimizing initial conditions : ', LICS +! WRITE( 6, 110 ) 'First guess for ICS_SF is : ', ICS_SF_tmp +! WRITE( 6, 110 ) 'First guess for EMS_SF is : ', EMS_SF_tmp +! +! +! ! Format statements +! 100 FORMAT( A, L5 ) +! 110 FORMAT( A, f7.2 ) +! +! +! !================================================================= +! ! Call setup routines from other GEOS-CHEM modules +! !================================================================= +! +! ! Set counter +! CT1 = CT1 + 1 +! +! ! Return to calling program +! END SUBROUTINE READ_CONTROL_PARAMS_MENU +! +!!------------------------------------------------------------------------------ + SUBROUTINE READ_CONTROL_VARS_MENU +! +!****************************************************************************** +! Subroutine READ_CONTROL_VARS_MENU reads the CONTROL VARIABLES MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Reorder and update (dkh, 02/09/11) +! (2 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LICS + USE ADJ_ARRAYS_MOD, ONLY : NNEMS + USE ADJ_ARRAYS_MOD, ONLY : ID_ADEMS + USE ADJ_ARRAYS_MOD, ONLY : ADEMS_NAME + USE ADJ_ARRAYS_MOD, ONLY : TRACERID_ADJ + USE ADJ_ARRAYS_MOD, ONLY : INIT_ADJ_EMS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_EMS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_ICS + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_EMS + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : COV_ERROR_LX, COV_ERROR_LY + USE ADJ_ARRAYS_MOD, ONLY : ICS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_DEFAULT + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : TRACER_NAME + + ! for strat prod and loss SF (hml, 08/14/11) + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE ADJ_ARRAYS_MOD, ONLY : ID_PROD + USE ADJ_ARRAYS_MOD, ONLY : ID_LOSS + USE ADJ_ARRAYS_MOD, ONLY : PROD_NAME + USE ADJ_ARRAYS_MOD, ONLY : LOSS_NAME + USE ADJ_ARRAYS_MOD, ONLY : STRPID_ADJ + USE ADJ_ARRAYS_MOD, ONLY : STRLID_ADJ + USE ADJ_ARRAYS_MOD, ONLY : INIT_ADJ_STRAT + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_PROD + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_LOSS + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_PROD + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_LOSS + USE ADJ_ARRAYS_MOD, ONLY : PROD_ERROR + USE ADJ_ARRAYS_MOD, ONLY : LOSS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_DEFAULT + + ! for reaction rates (tww, 05/08/12) + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + USE ADJ_ARRAYS_MOD, ONLY : NRRATES + USE ADJ_ARRAYS_MOD, ONLY : ID_RRATES + USE ADJ_ARRAYS_MOD, ONLY : RRATES_NAME + USE ADJ_ARRAYS_MOD, ONLY : INIT_ADJ_RRATES + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_RATE + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_RATE + USE ADJ_ARRAYS_MOD, ONLY : RATE_ERROR + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_DEFAULT + USE GCKPP_ADJ_GLOBAL, ONLY : NCOEFF_RATE + ! (hml, 05/22/13) + USE LOGICAL_ADJ_MOD, ONLY : FI_STRID + USE LOGICAL_ADJ_MOD, ONLY : FI_RXNID + USE FILE_MOD, ONLY : IOERROR + USE FILE_MOD, ONLY : IU_STR + USE FILE_MOD, ONLY : IU_RXN + +# include "define_adj.h" + + ! Local variables + INTEGER :: N, T, NSOPT, TMP, AS + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + ! For RRATE list (hml, 04/03/13) + INTEGER :: IOS + + !================================================================= + ! READ_CONTROL_VARS_MENU begins here! + !================================================================= + + !================================================================= + ! Allocate arrays + !================================================================= + ! First allocate OPT_THIS_TRACER to be max species + ALLOCATE( OPT_THIS_TRACER( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OPT_THIS_TRACER' ) + OPT_THIS_TRACER = .FALSE. + + ALLOCATE( REG_PARAM_ICS( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REG_PARAM_ICS' ) + REG_PARAM_ICS = 1d0 + + ALLOCATE( ICS_ERROR( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_ERROR' ) + ICS_ERROR = 1d0 +#if defined ( LOG_OPT ) + ICS_ERROR = EXP(1d0) +#endif + + ALLOCATE( ICS_SF_DEFAULT( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_SF_DEFAULT' ) + ICS_SF_DEFAULT = 1d0 + + !================================================================= + ! Read menu + !================================================================= + + ! Optimizing initial conditions + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:1' ) + READ( SUBSTRS(1:N), * ) LICS + + ! Optimizing emissions + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:2' ) + READ( SUBSTRS(1:N), * ) LADJ_EMS + + ! Optimizing strat prod & loss (hml, 08/11/11, adj32_025) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:3a' ) + READ( SUBSTRS(1:N), * ) LADJ_STRAT + + ! Specifying reaction rates (tww, 05/08/12) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:3d' ) + READ( SUBSTRS(1:N), * ) LADJ_RRATE + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:3b' ) + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:3c') + + ! Number of species to optimize + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:4' ) + READ( SUBSTRS(1:N), * ) NSOPT + + IF ( LICS .AND. NSOPT .EQ. 0) THEN + CALL ERROR_STOP( ' LICS is T but NSOPT is 0 ', + & ' READ_CONTROL_VARS_MENU, geos_chem_mod.f ' ) + ENDIF + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:5' ) + + DO T = 1, NSOPT + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1,'read_control_vars_menu:6') + + ! set OPT_THIS_TRACER to true for species we're optimizing + READ( SUBSTRS(1), * ) TMP + OPT_THIS_TRACER(TMP) = .TRUE. + + ! now move this to observation menu (dkh, 02/09/11) + !! observe this species? + !READ( SUBSTRS(3), *) OBS_THIS_SPECIES(TMP) + + ! Defualt scaling factor for this initial condition + READ( SUBSTRS(3), *) ICS_SF_DEFAULT(TMP) + + ! REG_PARAM for this species + READ( SUBSTRS(4), *) REG_PARAM_ICS(TMP) + + ! ICS_ERROR for this emission + READ( SUBSTRS(5), *) ICS_ERROR(TMP) + + ENDDO + + ! Obsolete -- now we only list tracer that are observed + ! compute number of observed species + !NOBS = 0 + !DO T = 1, N_TRACERS + ! IF ( OBS_THIS_SPECIES(T) ) THEN + ! NOBS = NOBS + 1 + ! ENDIF + !ENDDO + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:7' ) + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:7b') + + ! Optimizing emissions + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_control_vars_menu:8' ) + READ( SUBSTRS(1:N), * ) NNEMS + + IF ( .NOT. LADJ_EMS ) NNEMS = 0 + + ! If we're optimizing initial conditions, number of tracers is + !N_TRACERS + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:9' ) + + IF ( LADJ_EMS .AND. NNEMS .GT. 0) THEN + + CALL INIT_ADJ_EMS + + ELSEIF ( LADJ_EMS .AND. NNEMS .EQ. 0) THEN + CALL ERROR_STOP( ' LADJ_EMS is T but NNEMS is 0 ', + & ' READ_CONTROL_VARS_MENU, geos_chem_mod.f ' ) + ENDIF + + !================================================================= + ! Read emission ID + !================================================================= + IF ( LADJ_EMS ) THEN + DO T = 1, NNEMS + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:10') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_ADEMS(T) + + ! Save tracer name + ADEMS_NAME(T) = TRIM( SUBSTRS(2) ) + + ! optimize this emission?Q + READ( SUBSTRS(3), *) OPT_THIS_EMS(T) + + ! Defualt scaling factor for this emission + READ( SUBSTRS(4), *) EMS_SF_DEFAULT(T) + + ! REG_PARAM for this emission + READ( SUBSTRS(5), *) REG_PARAM_EMS(T) + + ! EMS_ERROR for this emission + READ( SUBSTRS(6), *) EMS_ERROR(T) + + ! CORR_LX for this emission + READ( SUBSTRS(7), *) COV_ERROR_LX(T) + + ! CORR_LY for this emission + READ( SUBSTRS(8), *) COV_ERROR_LY(T) + + ENDDO + + ! Number of temporal groups of the control vector, + ! e.g. monthly optimization in a year-long simulation would have + ! 12. If in doubt, set to 1 + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_control_vars_menu:11' ) + READ( SUBSTRS(1:N), * ) MMSCL + + ! Strat prod and loss (hml, adj32_025) + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:12b') + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:12c') + + ! Optimizing strat prod & loss + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_control_vars_menu:13' ) + READ( SUBSTRS(1:N), * ) NSTPL + IF ( .NOT. LADJ_STRAT ) NSTPL = 0 + + ! Read the list from file? (hml, 05/21/13) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_control_vars_menu:14' ) + READ( SUBSTRS(1:N), * ) FI_STRID + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:15' ) + + IF ( LADJ_STRAT .AND. NSTPL .GT. 0) THEN + + CALL INIT_ADJ_STRAT + + ELSEIF ( LADJ_STRAT .AND. NSTPL .EQ. 0) THEN + CALL ERROR_STOP( ' LADJ_STRAT is T but NSTPL is 0 ', + & ' READ_CONTROL_VARS_MENU, geos_chem_mod.f ' ) + ENDIF + + !PRINT *, ' NSTPL = ' , NSTPL + + !================================================================= + ! Read Stratospheric Tracers ID + !================================================================= + IF ( LADJ_STRAT .AND. .NOT. FI_STRID ) THEN ! (hml, 05/21/13) + + DO T = 1, NSTPL + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:16') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_PROD(T) + + ! Save tracer name + PROD_NAME(T) = TRIM( SUBSTRS(2) ) + + ! optimize this strat prod & loss? + READ( SUBSTRS(3), *) OPT_THIS_PROD(T) + + ! Defualt prod scaling factor for this strat tracer + READ( SUBSTRS(4), *) PROD_SF_DEFAULT(T) + + ! REG_PARAM for this strat tracer + READ( SUBSTRS(5), *) REG_PARAM_PROD(T) + + ! STR_ERROR for this strat tracer + READ( SUBSTRS(6), *) PROD_ERROR(T) + + ENDDO + + DO T = 1, NSTPL + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:16-b') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_LOSS(T) + + ! Save tracer name + LOSS_NAME(T) = TRIM( SUBSTRS(2) ) + + ! optimize this strat prod & loss? + READ( SUBSTRS(3), *) OPT_THIS_LOSS(T) + + ! Defualt loss scaling factor for this strat tracer + READ( SUBSTRS(4), *) LOSS_SF_DEFAULT(T) + + ! REG_PARAM for this strat tracer + READ( SUBSTRS(5), *) REG_PARAM_LOSS(T) + + ! STR_ERROR for this strat tracer + READ( SUBSTRS(6), *) LOSS_ERROR(T) + + ENDDO + + ELSE IF ( LADJ_STRAT .AND. FI_STRID ) THEN + + CALL READ_STRID_FILE + + ENDIF + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:15' ) + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:16' ) + + ! Specifying reaction rates + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_control_vars_menu:16b' ) + READ( SUBSTRS(1:N), * ) NRRATES + + IF ( .NOT. LADJ_RRATE ) NRRATES = 0 + + ! Read the list from file? + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_control_vars_menu:16c' ) + READ( SUBSTRS(1:N), * ) FI_RXNID + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:16d' ) + + IF ( LADJ_RRATE .AND. NRRATES .GT. 0) THEN + + CALL INIT_ADJ_RRATES + + ELSEIF ( LADJ_RRATE .AND. NRRATES .EQ. 0) THEN + + CALL ERROR_STOP( ' LADJ_RRATE is T but NRRATES is 0 ', + & ' READ_CONTROL_VARS_MENU, geos_chem_mod.f ' ) + + ENDIF + + IF ( LADJ_RRATE .AND. ( NRRATES .NE. NCOEFF_RATE ) ) THEN + + print*, 'NRRATES =', NRRATES + print*, 'NCOEFF_RATE =', NCOEFF_RATE + CALL ERROR_STOP( 'NRRATES not equal NCOEFF_RATE + & Check gckpp_adj_Global.f90 ', + & ' READ_CONTROL_VARS_MENU, geos_chem_mod.f ' ) + + ENDIF + + + + !================================================================= + ! Read Reaction Rates ID + !================================================================= + IF ( LADJ_RRATE .AND. .NOT. FI_RXNID ) THEN + + ! Added block to read reaction rate entries (tww, 05/08/12) + + DO T = 1, NRRATES + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:17') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_RRATES(T) + + ! Save tracer name + RRATES_NAME(T) = TRIM( SUBSTRS(2) ) + + ! Optimize this rate? + READ( SUBSTRS(3), *) OPT_THIS_RATE(T) + + ! Default scaling factor for this rate + READ( SUBSTRS(4), *) RATE_SF_DEFAULT(T) + + ! REG_PARAM for this rate + READ( SUBSTRS(5), *) REG_PARAM_RATE(T) + + ! RATE_ERROR for this rate + READ( SUBSTRS(6), *) RATE_ERROR(T) + + ENDDO + + ELSEIF ( LADJ_RRATE .AND. FI_RXNID ) THEN + + CALL READ_RXNID_FILE + + ENDIF + + ENDIF + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) + & 'CONTROL VARIABLE MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 130 ) 'Optimizing initial conditions : ', LICS + WRITE( 6, 130 ) 'Optimizing emissions : ', LADJ_EMS + WRITE( 6, 130 ) 'Optimizing strat prod & loss : ', LADJ_STRAT + WRITE( 6, 130 ) 'Optimizing rxn rates : ', LADJ_RRATE + WRITE( 6, '( a)' ) '>------------------------------<' + + IF ( LICS ) THEN + WRITE( 6, '( a)' ) + & ' Tracers optimizing SF_DEFAULT REG_PARAM ERROR' + ! Print info about each tracer + DO T = 1, N_TRACERS + + IF( OPT_THIS_TRACER(T) ) THEN + ! Write tracer number, name and it's default scaling factor + WRITE( 6, 140 ) T, TRACER_NAME(T), ICS_SF_DEFAULT(T), + & REG_PARAM_ICS(T), ICS_ERROR(T) + ENDIF + + ENDDO + + ELSEIF ( LADJ_EMS ) THEN + + WRITE( 6, '( a)' ) + & ' # Emission Opt SF REG ERR' + + ! Print info about each tracer + DO T = 1, NNEMS + + ! Write tracer number, name, optimize, default SF, reg param + ! and error + WRITE( 6, 120 ) ID_ADEMS(T), ADEMS_NAME(T), OPT_THIS_EMS(T), + & EMS_SF_DEFAULT(T), REG_PARAM_EMS(T), EMS_ERROR(T) + + ENDDO + + WRITE( 6, 110 ) 'Number of time contrl groups : ', MMSCL + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + WRITE( 6, '( a)' ) + & ' # Strat trc Opt SF REG ERR' + + ! Print info about each prod tracer + DO T = 1, NSTPL + + ! Write tracer number, name, default SF of prod, + ! reg param, and error + WRITE( 6, 150 ) ID_PROD(T), PROD_NAME(T), + & OPT_THIS_PROD(T), PROD_SF_DEFAULT(T), + & REG_PARAM_PROD(T), PROD_ERROR(T) + + ENDDO + + CALL STRPID_ADJ + + ! Print info about each tracer loss + DO T = 1, NSTPL + + ! Write tracer number, name, default SF of loss, + ! reg param, and error + WRITE( 6, 150 ) ID_LOSS(T), LOSS_NAME(T), + & OPT_THIS_LOSS(T), LOSS_SF_DEFAULT(T), + & REG_PARAM_LOSS(T), LOSS_ERROR(T) + + ENDDO + + CALL STRLID_ADJ + + ENDIF + + ! Print info about rxn rates (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN + + WRITE( 6, '(a)' ) + & ' RXN ID NAME OPT DEF_SF REG ERR' + + ! Print info about each tracer + DO T = 1, NRRATES + + ! Write tracer number, name + WRITE( 6, 150 ) ID_RRATES(T), RRATES_NAME(T), + & OPT_THIS_RATE(T), RATE_SF_DEFAULT(T), + & REG_PARAM_RATE(T), RATE_ERROR(T) + + ENDDO + + ENDIF + + !================================================================= + ! Call setup routines from other F90 modules + !================================================================= + + CALL TRACERID_ADJ + + ENDIF + + ! Set counter + CT1 = CT1 + 1 + + ! Format statements + 100 FORMAT( I3, 1x, A10, 6x, f5.2, 6x, f5.2 ) + 110 FORMAT( A, I5 ) +! 120 FORMAT( I3, 1x, A14, 6x, L5, 1x, f5.2, 1x, f5.2, 1x, f5.2 ) + 120 FORMAT( I3, 1x, A14, 6x, L5, 1x, f5.2, 1x, f6.2, 1x, f5.2 ) + 130 FORMAT( A, L5 ) + 140 FORMAT( I3, 1x, A10, 6x, f5.2, 6x, f5.2, 6x f5.2 ) + 150 FORMAT( I3, 1x, A14, 5x, L5, 1x, f5.2, 1x, f5.2, 1x, f5.2 ) + + ! Return to calling program + END SUBROUTINE READ_CONTROL_VARS_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_OBSERVATION_MENU +! +!****************************************************************************** +! Subroutine READ_OBSERVATION_MENU reads the OBSERVATION OPTIONS MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! a) calculate NSPAN using NYMDf, NHMSf (fp) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : OBS_FREQ + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_SPECIES + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ID2C + USE ADJ_ARRAYS_MOD, ONLY : GET_SPEC + USE ADJ_ARRAYS_MOD, ONLY : CNAME + USE ADJ_ARRAYS_MOD, ONLY : FORCING_MASK_FILE + USE ADJ_ARRAYS_MOD, ONLY : FORCING_MASK_VARIABLE + USE ADJ_ARRAYS_MOD, ONLY : FORCING_MASK_FILE_NC + USE ADJ_ARRAYS_MOD, ONLY : NB_MASK_VAR + USE ADJ_ARRAYS_MOD, ONLY : DEP_UNIT + USE ADJ_ARRAYS_MOD, ONLY : TRACER_IND + USE ADJ_ARRAYS_MOD, ONLY : NFD + USE ERROR_MOD, ONLY : ALLOC_ERR + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS + USE LOGICAL_ADJ_MOD, ONLY : LKGBOX + USE LOGICAL_ADJ_MOD, ONLY : LUGM3 + USE LOGICAL_ADJ_MOD, ONLY : LPOP_UGM3 + USE LOGICAL_ADJ_MOD, ONLY : LSTT_PPB + USE LOGICAL_ADJ_MOD, ONLY : LSTT_TROP_PPM + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_PPB + USE LOGICAL_ADJ_MOD, ONLY : LCSPEC_OBS + USE LOGICAL_ADJ_MOD, ONLY : LSENS + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE LOGICAL_ADJ_MOD, ONLY : LKGNHAYR + USE LOGICAL_ADJ_MOD, ONLY : LEQHAYR + USE LOGICAL_ADJ_MOD, ONLY : LMOLECCM2S + USE LOGICAL_ADJ_MOD, ONLY : LKGS + USE LOGICAL_ADJ_MOD, ONLY : LFORCE_MASK + USE LOGICAL_ADJ_MOD, ONLY : LFORCE_MASK_NC, LFORCE_MASK_BPCH + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE TRACER_MOD, ONLY : N_TRACERS, ITS_A_FULLCHEM_SIM + USE TIME_MOD, ONLY : GET_JD, NYMDe, NHMSe, NYMDb, NHMSb + ! for flux based cost function (hml,06/13/12) + USE LOGICAL_ADJ_MOD, ONLY : LFLX_UGM2 + +# include "CMN_SIZE" +# include "comode.h" ! IGAS, NAMEGAS + + ! Local variables + INTEGER :: N,T,J + INTEGER :: TMP + INTEGER :: NUNIT_COUNT + INTEGER :: AS + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + LOGICAL :: EOF + CHARACTER(LEN=255) :: LINE + CHARACTER(LEN=15) :: TNAME(N_TRACERS) + REAL*8 :: MASK_AREA + INTEGER :: NHMSf, NYMDf !fp + REAL*8 :: JDF, JDE, JDB !fp + + !================================================================= + ! READ_OBSERVATION_MENU begins here! + !================================================================= + + ! First allocate OBS_THIS_TRACER to be max species + ALLOCATE( OBS_THIS_TRACER( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS_THIS_TRACER' ) + OBS_THIS_TRACER = 0 + + ! Also allocation the mapping between observed and all tracers + ALLOCATE( TRACER_IND( N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TRACER_IND' ) + TRACER_IND = 0 + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_obs_menu:1' ) + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_obs_menu:2' ) + + ! Optimization output data dir + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_obs_menu:3' ) + READ( SUBSTRS(1:N), * ) OBS_FREQ + + ! Maximum number of obs? + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_obs_menu:4' ) + READ( SUBSTRS(1:N), * ) LMAX_OBS + + ! Number of obs evaluations + CALL SPLIT_ONE_LINE( SUBSTRS, N, 2, 'read_observation_menu:5' ) + READ( SUBSTRS(1:N), * ) NYMDf, NHMSf + + !calculate nspan (fp) + JDE = GET_JD(NYMDe, NHMSe) + JDB = GET_JD(NYMDb, NHMSb) + +! Need to review this with fp, not sure it gives desired behavior +! !fp to avoid error with new definition of nspan when LMAX_OBS is false but LFD_GLOB is true +! IF ( LFD_GLOB ) THEN +! IF ( .not. LMAX_OBS ) THEN +! LMAX_OBS = .TRUE. +! NYMDF = NYMDB +! NHMSF = NHMSB +! ENDIF +! ENDIF + + JDF = GET_JD(NYMDf, NHMSf) + + ! add error catch (fp) + IF ( JDB .GT. JDF .and. LMAX_OBS) THEN + CALL ERROR_STOP( + & ' You cannot force adjoint beyond simulation start time ', + & ' input_adj_mod.f ') + ENDIF + + ! add error catch (yd) + IF ( JDF .GT. JDE .and. LMAX_OBS ) THEN + CALL ERROR_STOP( + & ' The forcing time period is outside of the run period', + & ' input_adj_mod.f ') + ENDIF + + NSPAN = NINT( ( JDE - JDF ) * 24D0 * 60D0 / OBS_FREQ ) + + ! Want to only evalute CF once for FD_GLOB test + IF ( LFD_GLOB ) THEN + LMAX_OBS = .TRUE. + NSPAN = 1 + ENDIF + + !================================================================= + ! Cost function options + !================================================================= + NUNIT_COUNT = 0 + + ! Separator line: COST FUNCTION options for LSENS:--- + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_observation_menu:6' ) + + ! Cost function STT in kg / box + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:7' ) + READ( SUBSTRS(1:N), * ) LKGBOX + IF ( LKGBOX ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function STT in ug / m3 + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:8' ) + READ( SUBSTRS(1:N), * ) LUGM3 + IF ( LUGM3 ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function STT in ppb + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:9' ) + READ( SUBSTRS(1:N), * ) LSTT_PPB + IF ( LSTT_PPB ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function STT in free trop in ppm + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:10' ) + READ( SUBSTRS(1:N), * ) LSTT_TROP_PPM + IF ( LSTT_TROP_PPM ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function CSPEC in ppb + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:11' ) + READ( SUBSTRS(1:N), * ) LCSPEC_PPB + IF ( LCSPEC_PPB ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function STT in population weighted ug / m3 (adj32_024) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:12' ) + READ( SUBSTRS(1:N), * ) LPOP_UGM3 + IF ( LPOP_UGM3 ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! Cost function STT in flux ug / m2 / hr (hml,06/13/12) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13' ) + READ( SUBSTRS(1:N), * ) LFLX_UGM2 + IF ( LFLX_UGM2 ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! deposition based cost function? + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.a' ) + READ( SUBSTRS(1:N), * ) LADJ_FDEP + + ! tracer dry deposition + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.b' ) + READ( SUBSTRS(1:N), * ) LADJ_DDEP_TRACER + + ! species dry deposition + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.b2') + READ( SUBSTRS(1:N), * ) LADJ_DDEP_CSPEC + + ! wet deposition LS + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.c' ) + READ( SUBSTRS(1:N), * ) LADJ_WDEP_LS + + ! wet deposition CV + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.d' ) + READ( SUBSTRS(1:N), * ) LADJ_WDEP_CV + + ! wet deposition units + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.e1') + READ( SUBSTRS(1:N), * ) LMOLECCM2S + IF ( LMOLECCM2S .and. LADJ_FDEP ) NUNIT_COUNT = NUNIT_COUNT + 1 + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.e2') + READ( SUBSTRS(1:N), * ) LKGNHAYR + IF ( LKGNHAYR .and. LADJ_FDEP ) NUNIT_COUNT = NUNIT_COUNT + 1 + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.e3') + READ( SUBSTRS(1:N), * ) LEQHAYR + IF ( LEQHAYR .and. LADJ_FDEP ) NUNIT_COUNT = NUNIT_COUNT + 1 + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.e4') + READ( SUBSTRS(1:N), * ) LKGS + IF ( LKGS .and. LADJ_FDEP ) NUNIT_COUNT = NUNIT_COUNT + 1 + + ! now we can define units of the deposition cost function + ! fp 3/10/2013 + IF ( LADJ_FDEP ) THEN + IF ( LKGNHAYR ) THEN + DEP_UNIT = TRIM( 'kgN/ha/yr' ) + ELSEIF ( LEQHAYR ) THEN + DEP_UNIT = TRIM( 'eq/ha/yr' ) + ELSEIF ( LMOLECCM2S ) THEN + DEP_UNIT = TRIM( 'molec/cm2/s' ) + ELSEIF ( LKGS ) THEN + DEP_UNIT = TRIM( 'kg/s' ) + ELSE + CALL ERROR_STOP(' No unit selected for deposition ', + & ' input_adj_mod.f ') + ENDIF + ELSE + !set all deposition switches to false to avoid unwanted behavior with fd tests (fp) + LKGS = .FALSE. + LEQHAYR = .FALSE. + LKGNHAYR = .FALSE. + LMOLECCM2S = .FALSE. + + LADJ_DDEP_TRACER = .FALSE. + LADJ_DDEP_CSPEC = .FALSE. + LADJ_WDEP_CV = .FALSE. + LADJ_WDEP_LS = .FALSE. + + ENDIF + + ! Make sure that we haven't defined too many + IF ( NUNIT_COUNT > 1 ) THEN + CALL ERROR_STOP(' More than one choice for cost function ', + & ' input_adj_mod.f ') + + + ! Make sure that we have picked at least one. For + ! FD tests, the default is forced to be kg/box. + ELSEIF ( NUNIT_COUNT == 0 .and. LSENS .and. ( .not. LFDTEST ) ) + & THEN + CALL ERROR_STOP(' Need to choose one option for units ', + & ' input_adj_mod.f ') + ENDIF + ! Make sure that if deposition is selected that at least one option + ! is turned on. + IF ( LADJ_FDEP .and. ( .not. LADJ_FDEP ) + & .and. ( .not. LADJ_WDEP_LS ) + & .and. ( .not. LADJ_WDEP_CV ) ) THEN + CALL ERROR_STOP(' No deposition option selected ', + & ' input_adj_mod.f ') + ENDIF + + ! Regional mask? + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:13.f' ) + READ( SUBSTRS(1:N), * ) LFORCE_MASK + + IF ( LFORCE_MASK ) THEN + + !fp add option for nc file + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_observation_menu:13.b1') + + READ( SUBSTRS(1:N), * ) LFORCE_MASK_BPCH + + IF ( LFORCE_MASK_BPCH ) THEN + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_observation_menu:13.b2' ) + + READ( SUBSTRS(1:N), '(a)' ) FORCING_MASK_FILE + CALL CHECK_FILE( FORCING_MASK_FILE ) + + ELSE + + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_observation_menu:13.b2' ) + + ENDIF + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_observation_menu:13.b3') + + READ( SUBSTRS(1:N), * ) LFORCE_MASK_NC + + IF ( LFORCE_MASK_NC ) THEN + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, + & 'read_observation_menu:13.b4' ) + + READ( SUBSTRS(1:N), '(a)' ) FORCING_MASK_FILE_NC + + CALL CHECK_FILE( FORCING_MASK_FILE_NC ) + + CALL SPLIT_ONE_LINE( SUBSTRS, NB_MASK_VAR, -1, + & 'read_observation_menu:13.b5' ) + + ALLOCATE( FORCING_MASK_VARIABLE( NB_MASK_VAR ), STAT = AS ) + + DO N = 1, NB_MASK_VAR + FORCING_MASK_VARIABLE( N ) = TRIM( SUBSTRS(N) ) + ENDDO + + ELSE + + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_observation_menu:13.b5' ) + + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_observation_menu:13.b5' ) + + ENDIF + + ELSE + + ! skip lines + ! bpch switch + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:13.a1') + + ! bpch file + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:13.a2') + + ! nc switch + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:13.a3') + + ! nc file + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:13.a4') + + ! nc variable + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:13.a5') + + ENDIF + + IF ( LFORCE_MASK ) THEN + IF ( LFORCE_MASK_BPCH .and. LFORCE_MASK_NC ) THEN + CALL ERROR_STOP(' Two mask files are defined', + & ' input_adj_mod.f ') + ENDIF + + IF ( .not. LFORCE_MASK_BPCH .and. .not. LFORCE_MASK_NC ) THEN + CALL ERROR_STOP(' No mask file is defined', + & ' input_adj_mod.f ') + ENDIF + + ENDIF + + !================================================================= + ! Tracer observations + !================================================================= + + ! Separator line: >------------------------------< + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:11b') + + + ! Number of tracers to observe + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:12' ) + READ( SUBSTRS(1:N), * ) NOBS + + ! Separator line: => obs these tracers------> : TRC# tracer_name + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:13' ) + + IF ( NOBS > 0 ) THEN + DO T = 1, NOBS + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:14') + + ! tracer id number + READ( SUBSTRS(1), *) TMP + + ! tracer name + READ( SUBSTRS(2), *) TNAME(TMP) + + ! observe this species? + OBS_THIS_TRACER(TMP) = .TRUE. + + ! track tracer index + TRACER_IND(T) = TMP + + ENDDO + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_control_vars_menu:14b') + + ELSE + + ! Loop until at the next section + DO + + ! Read a line from the file + LINE = READ_ONE_LINE( EOF ) + + ! Stop reading lines when we've passed the Tracer section + IF ( .not. (INDEX( LINE, 'Tracer' ) > 0 ) ) EXIT + + ENDDO + + ENDIF + + !================================================================= + ! Species observations + !================================================================= + + ! Number of species to observe + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_observation_menu:15' ) + READ( SUBSTRS(1:N), * ) NOBS_CSPEC + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:15b') + + IF ( NOBS_CSPEC > 0 ) LCSPEC_OBS = .TRUE. + + IF ( ITS_A_FULLCHEM_SIM() .and. LCSPEC_OBS ) THEN + + ! First allocate OBS_THIS_SPECIES to be max species + ALLOCATE( OBS_THIS_SPECIES( NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OBS_THIS_SPECIES' ) + OBS_THIS_SPECIES = 0 + + ! + ALLOCATE( CNAME( NOBS_CSPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CNAME' ) + CNAME = '' + + + DO T = 1, NOBS_CSPEC + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, + & 'read_observation_menu:17') + + ! Save species name + CNAME(T) = TRIM( SUBSTRS(1) ) + + ! observe this species? + OBS_THIS_SPECIES(T) = .TRUE. + + ENDDO + + ENDIF + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'OBSERVATION MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 110 ) 'Observation frequency : ', OBS_FREQ + IF ( LFD_GLOB ) THEN + !print*,' *** FD_GLOB: enforce values on LMAX_OBS and NSPAN ***' + print*,' *** FD_GLOB: enforce values on LMAX_OBS ***' + ENDIF + WRITE( 6, 100 ) 'Limit number of observations : ', LMAX_OBS + WRITE( 6, 150 ) 'Forcing time till : ', + & NYMDf, NHMSf + WRITE( 6, 110 ) ' NSPAN => ', NSPAN + WRITE( 6, '( a)' ) 'Cost function options :--- ' + WRITE( 6, 100 ) ' tracer kg/box : ', LKGBOX + WRITE( 6, 100 ) ' tracer ug/m3 : ', LUGM3 + WRITE( 6, 100 ) ' tracer ppb : ', LSTT_PPB + WRITE( 6, 100 ) ' tracer ppm free trop : ', + & LSTT_TROP_PPM + WRITE( 6, 100 ) ' species ppb w/averaging : ', LCSPEC_PPB + WRITE( 6, 100 ) ' tracer ug/m3 pop weighted : ', LPOP_UGM3 + WRITE( 6, 100 ) ' deposition based? : ', LADJ_FDEP + WRITE( 6, 100 ) ' => tracer dry dep : ', + & LADJ_DDEP_TRACER + WRITE( 6, 100 ) ' => species dry dep : ', + & LADJ_DDEP_CSPEC + WRITE( 6, 100 ) ' => wet LS deposition : ', + & LADJ_WDEP_LS + WRITE( 6, 100 ) ' => wet CV deposition : ', + & LADJ_WDEP_CV + IF (LADJ_FDEP) THEN + WRITE( 6, 140 ) ' Deposition : ', DEP_UNIT + ELSE + WRITE( 6, 140 ) ' Deposition : NONE ' + ENDIF + WRITE( 6, 100 ) ' Regional forcing mask? : ', + & LFORCE_MASK + IF ( LFORCE_MASK ) THEN + IF ( LFORCE_MASK_BPCH ) THEN + WRITE( 6, 140 ) ' => mask name : ', + & TRIM(FORCING_MASK_FILE) + ELSEIF ( LFORCE_MASK_NC ) THEN + WRITE( 6, 140 ) ' => mask name : ', + & TRIM(FORCING_MASK_FILE_NC) + DO N = 1,NB_MASK_VAR + WRITE( 6, 140 ) ' => varname : ', + & TRIM(FORCING_MASK_VARIABLE(N)) + ENDDO + ENDIF + ELSE + WRITE( 6, 140 ) ' => mask name : ', + & 'NOT USED' + ENDIF + WRITE( 6, '( a)' ) '>------------------------------<' + WRITE( 6, 110 ) 'Number of tracers to observe : ', NOBS + + IF ( NOBS > 0 ) THEN + WRITE( 6, '( a)' ) ' Tracers to observe ' + + ! Print info about each tracer + DO T = 1, N_TRACERS + + IF( OBS_THIS_TRACER(T) ) THEN + ! Write tracer number, name and if it's observed + WRITE( 6, 130 ) T, TNAME(T) + ENDIF + + ENDDO + + ENDIF + + IF ( LCSPEC_OBS ) THEN + WRITE( 6, '( a)' ) REPEAT( '-', 48 ) + WRITE( 6, 110 ) 'Number of species to observe : ', + & NOBS_CSPEC + WRITE( 6, '( a)' ) ' Species to observe ' + + ! Print info about each tracer + DO T = 1, NOBS_CSPEC + + ! Write tracer number, name and if it's observed + WRITE( 6, 120 ) T, CNAME(T) + + ENDDO + + ENDIF + + + + 100 FORMAT( A, L5 ) + 110 FORMAT( A, I5 ) + 120 FORMAT( I3, 1x, A10 ) + 130 FORMAT( I3, 1x, A10, 6x, I5 ) + 140 FORMAT( A, A ) + 150 FORMAT( A, I8, 1x, I6 ) + + ! Set counter + CT1 = CT1 + 1 + + + END SUBROUTINE READ_OBSERVATION_MENU + +!--------------------------------------------------------------------------------------- + + SUBROUTINE READ_FD_MENU +! +!****************************************************************************** +! Subroutine READ_FD_MENU reads the FINITE DIFFERENCE MENU section of +! the GEOS-CHEM adj input file (adj_group, 6/08/09) +! +! NOTES: +! (1 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : FD_DIFF + USE ADJ_ARRAYS_MOD, ONLY : LONFD + USE ADJ_ARRAYS_MOD, ONLY : LATFD + USE ADJ_ARRAYS_MOD, ONLY : IFD + USE ADJ_ARRAYS_MOD, ONLY : JFD + USE ADJ_ARRAYS_MOD, ONLY : LFD + USE ADJ_ARRAYS_MOD, ONLY : NFD + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + USE ADJ_ARRAYS_MOD, ONLY : EMSFD + USE ADJ_ARRAYS_MOD, ONLY : MFD + USE ADJ_ARRAYS_MOD, ONLY : STRFD + USE DRYDEP_MOD, ONLY : NTRAIND + USE DRYDEP_MOD, ONLY : NUMDEP + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_BOUNDING_BOX + USE GRID_MOD, ONLY : GET_XMID + USE GRID_MOD, ONLY : GET_YMID + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_CSPEC + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_CV + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE LOGICAL_MOD, ONLY : LTRAN + USE WETSCAV_MOD, ONLY : GET_WETDEP_IDWETD + USE WETSCAV_MOD, ONLY : NSOL + USE ADJ_ARRAYS_MOD, ONLY : RATFD + + ! Local variables + INTEGER :: N + REAL*8 :: tmpbox(4) + INTEGER :: tmpbox1(4) + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + LOGICAL :: USEINDEX = .FALSE. + INTEGER :: IFDTMP, JFDTMP + + !================================================================= + ! READ_FD_MENU begins here! + !================================================================= + + ! FD difference size + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:1' ) + READ( SUBSTRS(1:N), * ) FD_DIFF + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_fd_menu:1.5' ) + + ! if we're doing global check, then exit + ! But it is still nice to define IFD, JFD, LFD, etc, if LPRINTFD + ! is on. Returning here makes these ind undefined, + ! which lead to seg faults (dkh, 06/11/09) + !IF ( LFD_GLOB ) THEN + ! PRINT*, 'All gridboxes are used in the global FD test' + ! RETURN + !ENDIF + + ! longitude of the FD gridbox + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:5' ) + READ( SUBSTRS(1:N), * ) LONFD + + ! latitude of the FD gridbox + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:6' ) + READ( SUBSTRS(1:N), * ) LATFD + + ! check if we're specifying indecies (as opposed to lat/lon) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:2' ) + READ( SUBSTRS(1:N), * ) USEINDEX + + ! IFD gridbox + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:3' ) + READ( SUBSTRS(1:N), * ) IFDTMP + + ! JFD gridbox + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:4' ) + READ( SUBSTRS(1:N), * ) JFDTMP + + ! get corresponding box indecies for the LONFD and LATFD + tmpbox(1) = LONFD + tmpbox(2) = LATFD + tmpbox(3) = LONFD + tmpbox(4) = LATFD + + ! Move this below, as it doesn't work with nested domain (dkh, 01/19/12, adj32_015 ) + !CALL GET_BOUNDING_BOX(tmpbox,tmpbox1) + + IF ( USEINDEX ) THEN + IFD = IFDTMP + JFD = JFDTMP + + ! now also adjust LONFD and LATFD (dkh, 02/11/11) + LONFD = GET_XMID( IFD ) + LATFD = GET_YMID( JFD ) + + ELSE + + ! Moved here (dkh, 01/19/12, adj32_015) + CALL GET_BOUNDING_BOX(tmpbox,tmpbox1) + + IFD = tmpbox1(1) + JFD = tmpbox1(2) + ENDIF + + ! FD perturbation box level + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:7' ) + READ( SUBSTRS(1:N), * ) LFD + + ! FD perturbation species + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:8' ) + READ( SUBSTRS(1:N), * ) NFD + + ! Separator line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_fd_menu:8.5' ) + + + ! FD perturbation box temporal element + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:9' ) + READ( SUBSTRS(1:N), * ) MFD + + ! FD perturbation species + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:10' ) + READ( SUBSTRS(1:N), * ) EMSFD + + ! FD perturbation species + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:11' ) + READ( SUBSTRS(1:N), * ) ICSFD + + ! FD perturbation species (hml, 08/11/11, adj32_025) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:12' ) + READ( SUBSTRS(1:N), * ) STRFD + + ! FD perturbation rate (tww, 05/15/12) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:13' ) + READ( SUBSTRS(1:N), * ) RATFD + + ! Move these to adjoint menu (dkh, 02/09/11) + !! Doing finite difference test in 1 gridbox + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:12' ) + !READ( SUBSTRS(1:N), * ) LFD_SPOT + ! + !! Doing finite difference test in all grid boxes, turn transport off + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_fd_menu:13' ) + !READ( SUBSTRS(1:N), * ) LFD_GLOB + ! + !! turn of transport for global FD test + !IF ( LFD_GLOB ) LTRAN = .FALSE. + ! + !! define a more generic LFDTEST flag if either method is true + !IF ( LFD_GLOB .OR. LFD_SPOT ) LFDTEST = .TRUE. + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'FINITE DIFFERENCE MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Finite diff. increment FD_DIFF: ', FD_DIFF + WRITE( 6, 120 ) 'Finite diff longitude LONFD : ', LONFD + WRITE( 6, 110 ) 'Finite diff long. index IFD : ', IFD + WRITE( 6, 120 ) 'Finite diff latitude LATFD : ', LATFD + WRITE( 6, 110 ) 'Finite diff lat. index JFD : ', JFD + WRITE( 6, 110 ) 'Finite diff vert index LFD : ', LFD + WRITE( 6, 110 ) 'FD species NFD : ', NFD + WRITE( 6, 110 ) 'FD time.group index MFD : ', MFD + WRITE( 6, 110 ) 'FD emiss EMSFD : ', EMSFD + WRITE( 6, 110 ) 'FD initial cond ICSFD : ', ICSFD + WRITE( 6, 110 ) 'FD strat prod & loss STRFD : ', STRFD + WRITE( 6, 110 ) 'FD reaction rate RATFD : ', RATFD + !WRITE( 6, 130 ) 'Doing finite diff check (1box): ', LFD_SPOT + !WRITE( 6, 130 ) 'Doing finite diff check (glob): ', LFD_GLOB + + ! Format statements + 100 FORMAT( A, f11.6 ) + 110 FORMAT( A, I4 ) + 120 FORMAT( A, f7.2 ) + 130 FORMAT( A, L5 ) + + !================================================================= + ! Call setup routines from other GEOS-CHEM modules + !================================================================= + + ! Set counter + CT1 = CT1 + 1 + + ! Return to calling program + END SUBROUTINE READ_FD_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ADJ_DIAGNOSTICS_MENU +! +!****************************************************************************** +! Subroutine READ_ADJ_DIAGNOSTICS_MENU reads the DIAGNOSTICS MENU section of +! the GEOS-CHEM adjoint input file (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Add LITR (zhe, dkh, 02/04/11) +! (2 ) Add LTRAJ_SCALE (dkh, 02/09/11) +! (3 ) Add LEMS_ABS, LTES_BLVMR (dkh, 02/17/11) +! (4 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE CHARPAK_MOD, ONLY : STRREPL + USE LOGICAL_ADJ_MOD, ONLY : LADJDIAG + USE LOGICAL_ADJ_MOD, ONLY : LJSAVE + USE LOGICAL_ADJ_MOD, ONLY : LADJ_TRAJ + USE LOGICAL_ADJ_MOD, ONLY : LDCOSAT + USE LOGICAL_ADJ_MOD, ONLY : LHMOD + USE LOGICAL_ADJ_MOD, ONLY : LhOBS + USE LOGICAL_ADJ_MOD, ONLY : LHMODIFF + USE LOGICAL_ADJ_MOD, ONLY : LADJ_FORCE + USE LOGICAL_ADJ_MOD, ONLY : LMODBIAS + USE LOGICAL_ADJ_MOD, ONLY : LOBS_COUNT + USE LOGICAL_ADJ_MOD, ONLY : LDOFS + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE LOGICAL_ADJ_MOD, ONLY : LITR + USE LOGICAL_ADJ_MOD, ONLY : LTRAJ_SCALE + USE LOGICAL_ADJ_MOD, ONLY : LTES_BLVMR + USE LOGICAL_ADJ_MOD, ONLY : LEMS_ABS + USE LOGICAL_ADJ_MOD, ONLY : LSAT_HDF_L2, LSAT_HDF_L3 + + ! Local variables + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + ! (dkh, 01/09/12, adj32_010) + LOGICAL :: EOF + INTEGER :: IOS + CHARACTER(LEN=1) :: TAB = ACHAR(9) + CHARACTER(LEN=1) :: SPACE = ' ' + CHARACTER(LEN=255) :: LINE + + !================================================================= + ! READ_ADJ_SIMULATION_MENU begins here! + !================================================================= + + LJSAVE = .FALSE. + LADJ_TRAJ = .FALSE. + LHMOD = .FALSE. + LhOBS = .FALSE. + LHMODIFF = .FALSE. + LADJ_FORCE = .FALSE. + LMODBIAS = .FALSE. + LOBS_COUNT = .FALSE. + LDOFS = .FALSE. + LITR = .FALSE. + LTRAJ_SCALE= .FALSE. + LTES_BLVMR = .FALSE. + LEMS_ABS = .FALSE. + LSAT_HDF_L2= .FALSE. + LSAT_HDF_L3= .FALSE. + + + ! Save any diagnostics? If not, exit subroutine with all flags FALSE + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:1' ) + READ( SUBSTRS(1:N), * ) LADJDIAG + + IF ( .NOT. LADJDIAG ) THEN + WRITE( 6, '(/,a)' ) 'SKIPPING DIAGNOSTICS MENU' + RETURN + ENDIF + + ! PRINT debug messages in FD cell files + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:2' ) + READ( SUBSTRS(1:N), * ) LPRINTFD + + ! Move to other menu (dkh, 02/09/11) + !! Delete checkpt files + !CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:2.1' ) + !READ( SUBSTRS(1:N), * ) LDEL_CHKPT + + ! SAVE .save and .sav2 files + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:3' ) + READ( SUBSTRS(1:N), * ) LJSAVE + + ! Save adjoint trajectory files + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:4' ) + READ( SUBSTRS(1:N), * ) LADJ_TRAJ + + ! save STT adjoints as scaling factor sensitivities? + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:4.0' ) + READ( SUBSTRS(1:N), * ) LTRAJ_SCALE + + ! Save iteration information + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:4.1' ) + READ( SUBSTRS(1:N), * ) LITR + + ! Save sense w.r.t absolute emis + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:4.2' ) + READ( SUBSTRS(1:N), * ) LEMS_ABS + + ! CO satellite diagnostics? if not, don't read the next 7 lines + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:5' ) + READ( SUBSTRS(1:N), * ) LDCOSAT + + IF ( LDCOSAT ) THEN + + ! Save H(model), model *ak + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:6' ) + READ( SUBSTRS(1:N), * ) LHMOD + + ! Save h(obs), gridded and filtered observations + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:7' ) + READ( SUBSTRS(1:N), * ) LhOBS + + ! Save H(mod) - h(obs) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:8' ) + READ( SUBSTRS(1:N), * ) LHMODIFF + + ! Save adjoint forcing + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:9' ) + READ( SUBSTRS(1:N), * ) LADJ_FORCE + + ! Save model bias (H(model)-h(obs))/h(obs) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:10' ) + READ( SUBSTRS(1:N), * ) LMODBIAS + + ! Save observation count (array with count/box) + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:11' ) + READ( SUBSTRS(1:N), * ) LOBS_COUNT + + ! Save gridded DOFs + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:12' ) + READ( SUBSTRS(1:N), * ) LDOFs + + !---------------------------------------------------------------- + ! BUG FIX: Allow for proper reading of menu below the CO sub menu + ! (dkh, 01/08/12, adj32_010) + ! OLD CODE: + !ENDIF + ! + !! Separator line: TES NH3 diagnostics + !CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_fd_menu:8.5' ) + ! NEW CODE: + ELSE + + DO WHILE ( INDEX( LINE, 'TES NH3 diagnostics' ) .le. 0 ) + + ! still need to advance through the file + LINE = READ_ONE_LINE( EOF ) + IF ( EOF ) EXIT + + ! Replace tab characters in LINE (if any) w/ spaces + CALL STRREPL( LINE, TAB, SPACE ) + + ENDDO + + ENDIF + !---------------------------------------------------------------- + + ! Save BLVMR + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:12' ) + READ( SUBSTRS(1:N), * ) LTES_BLVMR + + ! Separator line: >------------------------------< + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_control_vars_menu:13') + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:14' ) + READ( SUBSTRS(1:N), * ) LSAT_HDF_L2 + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_adj_diag_menu:15' ) + READ( SUBSTRS(1:N), * ) LSAT_HDF_L3 + + !================================================================= + ! Print to screen + !================================================================= + WRITE( 6, '(/,a)' ) 'DIAGNOSTICS MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Print adj debug LPRINTFD : ', LPRINTFD + !WRITE( 6, 100 ) 'Delete chkpt files LDEL_CHKPT : ', LDEL_CHKPT + WRITE( 6, 100 ) 'Save .jsave and .jsave2 files : ', LJSAVE + WRITE( 6, 100 ) 'Adjoint trajectory files : ', LADJ_TRAJ + WRITE( 6, 100 ) ' w.r.t. scaling factors : ', + & LTRAJ_SCALE + WRITE( 6, 100 ) 'Save iteration diagnostics : ', LITR + WRITE( 6, 100 ) 'Save sense w.r.t absolute emis: ', LEMS_ABS + IF ( LEMS_ABS ) PRINT*, ' ### WARNING: LEMS_ABS only for SO2, BC' + WRITE( 6, 100 ) 'Save CO sat. diagnostics : ', LDCOSAT + + IF ( LDCOSAT) THEN + WRITE( 6, 100 ) 'Save H(model) : ', LHMOD + WRITE( 6, 100 ) 'Save h(obs) : ', LhOBS + WRITE( 6, 100 ) 'Save H(model)-h(obs) : ', LHMODIFF + WRITE( 6, 100 ) 'Save adjoint forcing : ', LADJ_FORCE + WRITE( 6, 100 ) 'Save model bias : ', LMODBIAS + WRITE( 6, 100 ) 'Save number of obs/gridbox : ', LOBS_COUNT + WRITE( 6, 100 ) 'Save gridded DOFs : ', LDOFS + ENDIF + + WRITE( 6, 100 ) 'TES NH3 BLVMR : ', LTES_BLVMR + WRITE( 6, 100 ) 'HDF Level 2 : ',LSAT_HDF_L2 + WRITE( 6, 100 ) 'HDF Level 3 : ',LSAT_HDF_L3 + + ! Format statements + 100 FORMAT( A, L5 ) + + !================================================================= + ! Call setup routines from other GEOS-CHEM modules + !================================================================= + + ! Set counter + CT1 = CT1 + 1 + + ! Return to calling program + END SUBROUTINE READ_ADJ_DIAGNOSTICS_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_ADJ_CRITICAL_LOAD_MENU +!fp +!add new menu to streamline the inputs for critical load sensitivity simulations + + USE CRITICAL_LOAD_MOD, ONLY : CL_FILENAME + USE CRITICAL_LOAD_MOD, ONLY : GC_FILENAME + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CL + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CL_NDEP + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CL_ACID + +# include "CMN_SIZE" + + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + REAL*8 :: MASK(IIPAR,JJPAR) + + + !================================================================= + ! READ_ADJ_CRITICAL_LOAD begins here! + !================================================================= + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_critical_load_menu:1' ) + READ( SUBSTRS(1:N), * ) LADJ_CL + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_critical_load_menu:2' ) + READ( SUBSTRS(1:N), * ) LADJ_CL_NDEP + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_critical_load_menu:3' ) + READ( SUBSTRS(1:N), * ) LADJ_CL_ACID + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_critical_load_menu:2' ) + READ( SUBSTRS(1:N), '(a)' ) CL_FILENAME + + CALL SPLIT_ONE_LINE( SUBSTRS, N, 1, 'read_critical_load_menu:3' ) + READ( SUBSTRS(1:N), '(a)' ) GC_FILENAME + + + WRITE( 6, '(/,a)' ) 'CRITICAL LOAD MENU' + WRITE( 6, '( a)' ) '---------------' + WRITE( 6, 100 ) 'Doing critical load run : ', + & LADJ_CL + WRITE( 6, 100 ) ' => based on N deposition : ', + & LADJ_CL_NDEP + WRITE( 6, 100 ) ' => based on acid deposition : ', + & LADJ_CL_ACID + WRITE( 6, '( a)' ) ' Critical Load base file : ', + & TRIM(CL_FILENAME) + WRITE( 6, '( a)' ) ' GC Load file : ', + & TRIM(GC_FILENAME) + + 100 FORMAT( A, L5 ) + + ! Return to calling program + END SUBROUTINE READ_ADJ_CRITICAL_LOAD_MENU + +!------------------------------------------------------------------------------ + + SUBROUTINE ARE_FLAGS_VALID( ) +! +!****************************************************************************** +! Subroutine ARE_FLAGS_VALID checks to make sure that flags for the forward +! calculation (set in input.geos) do not confict with flags for the adjoint +! calculation (set in input.gcadj ). (dkh, 11/02/05, adj_group 6/07/09) +! +! NOTES: +! (1 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (2 ) Add LINVH_BFGS (nab, 25/03/12) +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : OBS_FREQ + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, EMSFD + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EBCPI_an, IDADJ_EBCPO_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EOCPI_an, IDADJ_EOCPO_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EBCPI_bb, IDADJ_EBCPO_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EOCPI_bb, IDADJ_EOCPO_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EBCPI_bf, IDADJ_EBCPO_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EOCPI_bf, IDADJ_EOCPO_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_na + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_sh + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_an1 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_an2 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EDST1, IDADJ_EDST2 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_EDST3, IDADJ_EDST4 + USE ADJ_ARRAYS_MOD, ONLY : N_CARB_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_SULF_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : N_DUST_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IS_CARB_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IS_SULF_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IS_DUST_EMS_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_SPECIES + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_EMS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : ICS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, STRFD + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_PROD + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_LOSS + USE ADJ_ARRAYS_MOD, ONLY : PROD_ERROR + USE ADJ_ARRAYS_MOD, ONLY : LOSS_ERROR + USE ADJ_ARRAYS_MOD, ONLY : NRRATES, RATFD + USE ADJ_ARRAYS_MOD, ONLY : OBS_FREQ + USE ADJ_ARRAYS_MOD, ONLY : CNAME + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LDRYD, LCHEM, LTURB, + & LCHEM, LWETD, LTRAN, + & LCONV, LSOILNOX, LSCHEM + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CHEM, LAERO_THERM, LADJ_TRAN, + & LSENS, LFDTEST, L4DVAR, + & LICS, LADJ_EMS, LFD_GLOB, + & LBKCOV, LADJ, LLINOZ, + & L3DVAR, LCSPEC_PPB, LCSPEC_OBS, + & LEMS_ABS, LAPSRC, LINVH, + & LINVH_BFGS, + & LADJ_STRAT, LADJ_RRATE, + & LADJ_FDEP, + & LADJ_DDEP_TRACER, + & LADJ_DDEP_CSPEC, + & LADJ_WDEP_LS, + & LADJ_WDEP_CV, + & LMAX_OBS + USE ADJ_ARRAYS_MOD, ONLY : OBS_FREQ + USE LOGICAL_ADJ_MOD, ONLY : LKGNHAYR + USE LOGICAL_ADJ_MOD, ONLY : LEQHAYR + USE LOGICAL_ADJ_MOD, ONLY : LMOLECCM2S + USE LOGICAL_ADJ_MOD, ONLY : LKGS + USE TIME_MOD, ONLY : GET_TIME_AHEAD + USE TIME_MOD, ONLY : GET_NYMDe + USE TIME_MOD, ONLY : GET_NHMSe + USE TRACER_MOD, ONLY : N_TRACERS, ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGOX_SIM + USE TRACER_MOD, ONLY : SIM_TYPE + USE TRACERID_MOD, ONLY : IDTSO4, IDTDST1, IDTSOA1 + USE TRACERID_MOD, ONLY : IDTSALA + USE TRACERID_MOD, ONLY : IDTNIT, IDTNH4, IDTNH3 + USE TRACERID_MOD, ONLY : IDTHNO3, IDTSO2 + USE LOGICAL_ADJ_MOD, ONLY : LSAT_HDF_L2, LSAT_HDF_L3 + USE LOGICAL_ADJ_MOD, ONLY : LADJ_CL, LADJ_CL_NDEP, LADJ_CL_ACID + USE TRACER_MOD, ONLY : TRACER_NAME + USE GCKPP_ADJ_GLOBAL, ONLY: NCOEFF_RATE + +# include "CMN_SIZE" ! Size params +# include "comode.h" ! NAMEGAS, SMAL2 +# include "define_adj.h" +# include "CMN_DIAG" ! ND44 + + + + ! local variables + INTEGER :: N,T + CHARACTER(LEN=255) :: MSG + INTEGER :: COUNT_ON + + INTEGER, PARAMETER :: N_NDEP = 4 !number of tracers for N deposition + INTEGER, PARAMETER :: N_ACID = 2 !number of tracers for acid deposition (on top of N_NDEP tracers) + INTEGER, PARAMETER :: N_NDEP_CSPEC = 7 + INTEGER :: NDEP(N_NDEP), ACID(N_ACID) + INTEGER :: DATE(2) + CHARACTER*255 :: NDEP_CSPEC(N_NDEP_CSPEC) + LOGICAL :: FOUND + + !NITS and SO4S are not supported at the moment for wet/dry deposition (fp 1/5/2013) + + NDEP(1) = IDTHNO3 + NDEP(2) = IDTNIT + NDEP(3) = IDTNH3 + NDEP(4) = IDTNH4 + ACID(1) = IDTSO2 + ACID(2) = IDTSO4 + + NDEP_CSPEC(1) = 'DRYHNO3' + NDEP_CSPEC(2) = 'DRYNO2' + NDEP_CSPEC(3) = 'DRYPAN' + NDEP_CSPEC(4) = 'DRYPPN' + NDEP_CSPEC(5) = 'DRYPMN' + NDEP_CSPEC(6) = 'DRYN2O5' + NDEP_CSPEC(7) = 'DRYR4N2' + + !================================================================= + ! ARE_FLAGS_VALID begins here! + !================================================================= + + ! check if we are even doing an adjoint run + IF ( .not. LADJ ) RETURN + + !================================================================= + ! Check forward model options + !================================================================= + ! first check if "input.geos" is set to a supported simulation: + IF ( SIM_TYPE .NE. 7 .AND. ! FULL CHEM + & SIM_TYPE .NE. 3 .AND. ! TAGGED CO + & SIM_TYPE .NE. 9 .AND. ! CH4 (kjw, adj32_023) + & SIM_TYPE .NE. 6 .and. ! TAGGED OX (lzh, 12/12/2009) + & SIM_TYPE .NE.10 .and. ! Offline aerosol (adj32_013) + & SIM_TYPE .NE. 12) THEN ! TAGGED CO2 + CALL ERROR_STOP( ' This simulation is not supported ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! So far only BC and OC will work with the offline aerosol sim, + ! but not the other aerosols (well, dust might, but untested). + ! (yhmao, dkh, 01/13/12, adj32_013) + IF ( SIM_TYPE == 10 ) THEN + IF ( IDTSO4 .or. IDTSALA .or. IDTSOA1 ) THEN + CALL ERROR_STOP('offline aero adj only for dust and BC/OC', + & ' ARE_FLAGS_VALID, input_adj_mod.f' ) + ENDIF + ENDIF + + !================================================================= + ! Check forward and adjoint process options + !================================================================= + ! Much of the relevant aerosol chemistry is DRYDEP, and adjoint + ! of sulfate chemistry will get called if LADJ_CHEM is true, + ! so we shouldn't have DRYDEP = FALSE and LADJ_CHEM = TRUE. + ! Should this depend on LSULF at all? +! IF ( ( LADJ_CHEM .AND. ( .NOT. LDRYD ) ) .OR. +! & ( LDRYD .AND. ( .NOT. LADJ_CHEM ) ) ) THEN + ! I think we can have DRYD w/o chem + IF ( ITS_A_FULLCHEM_SIM() .AND. + & LADJ_CHEM .AND. ( .NOT. LDRYD ) ) THEN + CALL ERROR_STOP( ' LADJ_CHEM and LDRYD inconsistent ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + +! Not sure about this, leave it out for now (dkh, 06/24/09) +! ! Don't know why, but if WETD, and CHEM are only fwd true +! ! and LADJ_CHEM is only adj true, get error. Have to turn +! ! on LTRAN. ( though just WETD, no adj_chem, no TRAN, seems ok). +! ! something to do with RH? I think there may be others that +! ! require LTRAN.... The error pops up as "Invalid EXTRA", caused +! ! because TS_DYN is 60. +! IF ( LCHEM .AND. ( .NOT. LTRAN ) ) THEN +! CALL ERROR_STOP( ' LCHEM and LTRAN inconsistent ', +! & ' ARE_FLAGS_VALID, geos_chem_mod.f ' ) +! ENDIF + + ! LCHEM controls chemistry in the fwd calc, so need this on + ! if want aerosol thermo or the rest of chemistry. + IF ( ( LAERO_THERM .OR. LADJ_CHEM ) + & .AND. ( .NOT. LCHEM ) ) THEN + CALL ERROR_STOP( ' LCHEM, LADJ_CHEM, LAERO_THERM inconsistent', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + ! ... and the opposite... + IF ( .not. ( LADJ_CHEM ) + & .and. ( LCHEM ) ) THEN + CALL ERROR_STOP( ' LADJ_CHEM off but LCHEM is on! ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! If you have LTURB and LTRAN, but nothing else, adjoints explode. + ! (dkh, 11/22/05) + IF ( LTURB .AND. LTRAN .AND. LTRAN .AND. ( .NOT. LCONV ) + & .AND. ( .NOT. LWETD ) .AND. ( .NOT. LCHEM ) ) THEN + CALL ERROR_STOP( ' LTURB and LTRAN lead to errors in adj? ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + + ! Now use new strat_chem_mod (hml, dkh, 02/14/12, adj32_025) + !! Make sure that if strat fluxes are on, LINOZE adj is on (dkh, 04/25/10) + !IF ( LUPBD /= LLINOZ ) THEN + ! CALL ERROR_STOP( ' LUPBD and LLINOZ not consistent ', + ! ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + !ENDIF + + + ! Only include adjoint w.r.t strat fluxes if strat chem is turned on + IF ( LADJ_STRAT .and. ( .not. LSCHEM ) ) THEN + CALL ERROR_STOP( ' LADJ_STRAT needs LSCHEM on ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + !================================================================= + ! Check adjoint simulation type + ! + ! Overall simulation type must be one and only one of: + ! - 3DVAR + ! - 4DVAR + ! - SENS + !================================================================= + ! check at least one: + IF ( (.not. LSENS ) .and. ( .not. L3DVAR ) + & .and. ( .not. L4DVAR ) ) THEN + MSG = 'Invalid adj run options: no simulation type defined!' + CALL ERROR_STOP( MSG, 'ARE_FLAGS_VALID ("input_adj_mod.f")' ) + ! check not more than one: + ENDIF + IF ( ( LSENS .AND. L4DVAR ) .or. + & ( LSENS .AND. L3DVAR ) .or. + & ( L4DVAR .AND. L3DVAR ) ) THEN + CALL ERROR_STOP( 'Either sensitivity or a var, pick only one!', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + + !================================================================= + ! Check adjoint simulation subtypes + !================================================================= +#if defined ( PM_ATTAINMENT ) || defined ( SOMO35_ATTAINMENT ) + IF ( OBS_FREQ /= 60 ) THEN + CALL ERROR_STOP( ' OBS_FREQ should be 60 for attainment ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF +#endif + + !If none of the datasets are selected or PSEUDO_OBS FLAG, then it should be + ! 3DVAR and 4DVAR + ! add IMPROVE_BC_OC_OBS (adj32_013), MODIS_AOD_OBS (adj32_011) + ! add OMI_SO2_OBS () + ! add MOPITT_V5_CO_OBS (adj32_016) + ! add CH4 (kjw, dkh, 02/12/12, adj32_023) + IF ( L3DVAR .or. L4DVAR ) THEN +#if !defined(MOPITT_V5_CO_OBS) && !defined(MOPITT_V6_CO_OBS) && !defined(MOPITT_V7_CO_OBS) && !defined(AIRS_CO_OBS) && !defined(SCIA_BRE_CO_OBS) && !defined(TES_NH3_OBS)&& !defined(SCIA_DAL_SO2_OBS) && !defined(PM_ATTAINMENT) && !defined(IMPROVE_SO4_NIT_OBS) && !defined(CASTNET_NH4_OBS) && !defined(SOMO35_ATTAINMENT) && !defined(TES_O3_OBS)&& !defined(SCIA_KNMI_NO2_OBS) && !defined(SCIA_DAL_NO2_OBS) && !defined(PSEUDO_OBS) && !defined(GOSAT_CO2_OBS) & !defined(MODIS_AOD_OBS) && !defined(IMPROVE_BC_OC_OBS) && !defined(TES_CH4_OBS) && !defined(SCIA_CH4_OBS) && !defined(MEM_CH4_OBS) && !defined(LEO_CH4_OBS) && !defined(GEOCAPE_CH4_OBS) && !defined( TES_O3_IRK ) && !defined( OMI_SO2_OBS ) && !defined( OMI_NO2_OBS ) && !defined( OMI_CH2O_OBS ) && !defined( MLS_HNO3_OBS ) && !defined( MLS_O3_OBS ) && !defined( IASI_O3_OBS ) && !defined( IASI_CO_OBS ) && !defined( OSIRIS_OBS ) && !defined( OSIRIS_NO2_OBS) + MSG = 'Invalid adj run options: need to define obs for xDVAR' + CALL ERROR_STOP( MSG, 'ARE_FLAGS_VALID ("input_adj_mod.f")' ) +#endif + ENDIF + + ! Conversely, if any of the obs operators are defined, then make sure it is + ! a 3DVAR or 4DVAR simulation + ! add IMPROVE_BC_OC_OBS (adj32_013), MODIS_AOD_OBS (adj32_011) + ! add OMI_SO2_OBS () + ! add MOPITT_V5_CO_OBS (adj32_016) + ! add CH4 (kjw, dkh, 02/12/12, adj32_023) +#if defined(MOPITT_V5_CO_OBS) || defined(MOPITT_V6_CO_OBS) || defined(MOPITT_V7_CO_OBS) || defined(AIRS_CO_OBS) || defined(SCIA_BRE_CO_OBS) || defined(TES_NH3_OBS) || defined(SCIA_DAL_SO2_OBS) || defined(PM_ATTAINMENT) || defined(IMPROVE_SO4_NIT_OBS) || defined(CASTNET_NH4_OBS) || defined(SOMO35_ATTAINMENT) || defined(TES_O3_OBS) || defined(SCIA_KNMI_NO2_OBS) || defined(SCIA_DAL_NO2_OBS) || defined(GOSAT_CO2_OBS) || defined(MODIS_AOD_OBS) || defined(IMPROVE_BC_OC_OBS) || defined(TES_CH4_OBS) || defined(SCIA_CH4_OBS) || defined(MEM_CH4_OBS) || defined(LEO_CH4_OBS) || defined(GEOCAPE_CH4_OBS) || defined(TES_O3_IRK) || defined(OMI_SO2_OBS) || defined( OMI_NO2_OBS ) || defined(OMI_CH2O_OBS) || defined( MLS_HNO3_OBS ) || defined( MLS_O3_OBS ) || defined( IASI_O3_OBS ) || defined( IASI_CO_OBS ) || defined( OSIRIS_OBS ) || defined( OSIRIS_NO2_OBS ) || defined(PSEUDO_OBS) + + IF ( .not. ( L3DVAR .or. L4DVAR ) ) THEN + MSG = 'Invalid adj run options: need to define VAR for obs' + CALL ERROR_STOP( MSG, 'ARE_FLAGS_VALID ("input_adj_mod.f")') + ENDIF +#endif + + IF ( LSAT_HDF_L2 .or. LSAT_HDF_L3 ) THEN +#if !defined(MOPITT_V5_CO_OBS) && !defined(MOPITT_V6_CO_OBS) && !defined(MOPITT_V7_CO_OBS) && !defined( OMI_SO2_OBS ) && !defined( OMI_NO2_OBS ) + MSG = 'Invalid adj run options: Satellite HDF diagnostics are + & only supported by OMI, TES and MOPITT obs operator for xDVAR' + CALL ERROR_STOP( MSG, 'ARE_FLAGS_VALID ("input_adj_mod.f")' ) +#endif + ENDIF + + ! If we are using real observations, make sure pseudo obs are commented (mak, dkh, 10/01/09) + ! add IMPROVE_BC_OC_OBS (adj32_013), MODIS_AOD_OBS (adj32_011) + ! add OMI_SO2_OBS () + ! add MOPITT_V5_CO_OBS (adj32_016) + ! add CH4 (kjw, dkh, 02/12/12, adj32_023) +#if defined(MOPITT_V5_CO_OBS) || defined(MOPITT_V6_CO_OBS) || defined(MOPITT_V7_CO_OBS) || defined(AIRS_CO_OBS) || defined(SCIA_BRE_CO_OBS) || defined(TES_NH3_OBS) || defined(SCIA_DAL_SO2_OBS) || defined(PM_ATTAINMENT) || defined(IMPROVE_SO4_NIT_OBS) || defined(CASTNET_NH4_OBS) || defined(SOMO35_ATTAINMENT) || defined(TES_O3_OBS) || defined(SCIA_KNMI_NO2_OBS) || defined(SCIA_DAL_NO2_OBS) || defined(GOSAT_CO2_OBS) || defined(MODIS_AOD_OBS) || defined(IMPROVE_BC_OC_OBS) || defined(TES_CH4_OBS) || defined(SCIA_CH4_OBS) || defined(MEM_CH4_OBS) || defined(LEO_CH4_OBS) || defined(GEOCAPE_CH4_OBS) || defined(TES_O3_IRK) || defined(OMI_SO2_OBS) || defined( OMI_NO2_OBS ) || defined(OMI_CH2O_OBS) || defined( MLS_HNO3_OBS ) || defined( MLS_O3_OBS ) || defined( IASI_O3_OBS ) || defined( IASI_CO_OBS ) || defined( OSIRIS_OBS ) || defined( OSIRIS_NO2_OBS ) + + +#if defined(PSEUDO_OBS) + IF ( L4DVAR ) THEN + MSG = 'Invalid adj options: define real or pseudo obs' + CALL ERROR_STOP( MSG, 'ARE_FLAGS_VALID ("input_adj_mod.f")') + ENDIF +#endif + +#endif + ! ( LFDTEST .AND. .NOT. LSENS ) LSENS = .TRUE. + IF ( LFDTEST .AND. (.not. LSENS ) ) THEN + CALL ERROR_STOP( 'FD tests are a subtpye of SENS', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + + IF ( LFDTEST .AND. LICS .AND. LADJ_EMS ) THEN + CALL ERROR_STOP( 'FD test for ems AND ics not supported', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( LFDTEST .and. + & ( ( N_CALC_STOP > 3 ) .or. + & ( N_CALC_STOP < 1 ) ) ) THEN + CALL ERROR_STOP( 'FD tests need to have 1 < N_CALC_STOP < 3', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( LFDTEST .AND. LFD_GLOB .AND. LTRAN ) THEN + CALL ERROR_STOP( 'FD_GLOB should be done with transport off', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! Estimating inv Hessian only supported for 4DVar (dkh, 01/12/12, adj32_012) + IF ( ( LINVH .or. LINVH_BFGS ) .and. ( .not. L4DVAR ) ) THEN + CALL ERROR_STOP( 'LINVH and LINVH_BFGS only with 4DVAR ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! RTFD should equal the "Rate #" listed in input.gcadj (or RF_IDX) + ! corresponding to the listed rate we wish to test + IF ( LFDTEST .and. LADJ_RRATE ) THEN + IF ( RATFD > NRRATES ) THEN + CALL ERROR_STOP('Invalid RTFD', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + ENDIF + + IF ( .NOT. LADJ_RRATE .AND. ( NCOEFF_RATE .NE. 0 ) ) + & CALL ERROR_STOP('Invalid NCOEFF_RATE', 'ARE_FLAGS_VALID, + & input_adj_mod.f ') + + !================================================================= + ! Check adjoint control parameters + !================================================================= + IF ( (.not. LICS ) .AND. ( .not. LADJ_EMS ) ) THEN + CALL ERROR_STOP( 'Must select either ICS or EMS ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! LADJ_STRAT is a sub-type of LADJ_EMS (dkh, 02/23/12, adj32_025) + IF ( ( LADJ_STRAT ) .AND. ( .not. LADJ_EMS ) ) THEN + CALL ERROR_STOP( 'LADJ_STRAT is a sub-type of LADJ_EMS', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! check settings for tagged Ox sim + IF ( ITS_A_TAGOX_SIM() ) THEN + IF ( LICS ) THEN + CALL ERROR_STOP( 'Tagged OX adjoint only LADJ_EMS ', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + IF ( MMSCL .ne. LLPAR ) THEN + CALL ERROR_STOP( 'Need MMSCL = LLPAR for tag ox adj ' , + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + ENDIF + + IF ( IFD .GT. IIPAR ) THEN + CALL ERROR_STOP( ' IFD has to be less than IIPAR !', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( JFD .GT. JJPAR ) THEN + CALL ERROR_STOP( ' JFD has to be less than JJPAR !', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( LFD .GT. LLPAR ) THEN + CALL ERROR_STOP( ' LFD has to be less than LLPAR !', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( NFD .GT. N_TRACERS ) THEN + CALL ERROR_STOP( ' NFD has to be less than number of tracers!', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + IF ( ICSFD .GT. N_TRACERS ) THEN + CALL ERROR_STOP( ' ICSFD has to be < number of tracers!', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + + ! (dkh, 11/11/09) + IF ( LADJ_EMS ) THEN + IF ( EMSFD .GT. NNEMS ) THEN + CALL ERROR_STOP( + & ' EMSFD has to be < number of active adj emissons!', + & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) + ENDIF + ENDIF + + ! (dkh, 01/12/12, adj32_012) +! IF ( LINVH .and. ( .not. LADJ_EMS .or. LICS ) ) THEN +! CALL ERROR_STOP( ' LINVH only supported for LADJ_EMS ', +! & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) +! ENDIF +! IF ( ( LINVH .or. LINVH_BFGS ) .and. +! & ( .not. LADJ_EMS .or. LICS ) ) THEN +! CALL ERROR_STOP( ' LINVH only supported for LADJ_EMS ', +! & ' ARE_FLAGS_VALID, input_adj_mod.f ' ) +! ENDIF + + ! Check to make sure error specifications are usable for LAPSRC (dkh, 02/22/11) + IF ( LAPSRC ) THEN + + ! Check emissions + IF ( LADJ_EMS ) THEN + + DO N = 1, NNEMS + + ! Skip emissions that are not included in optimization + IF ( .not. OPT_THIS_EMS(N) ) CYCLE + + IF ( EMS_ERROR(N) < ( SMAL2 ) ) THEN + print*, ' EMS_ERROR stop at N = ', N + CALL ERROR_STOP( ' EMS_ERROR is too small ', + & ' input_adj_mod.f ' ) + ENDIF + + ENDDO + + ! Check strat prod and loss tracers (hml, adj32_025) + IF ( LADJ_STRAT ) THEN + + DO N = 1, NSTPL + + ! Skip tracers that are not included in optimization + IF (.not. OPT_THIS_PROD(N) .AND. + & .not. OPT_THIS_LOSS(N)) CYCLE + + IF ( PROD_ERROR(N) < ( SMAL2 ) ) THEN + print*, ' PROD_ERROR stop at N = ', N + CALL ERROR_STOP( ' PROD_ERROR is too small ', + & ' input_adj_mod.f ' ) + ENDIF + + IF ( LOSS_ERROR(N) < ( SMAL2 ) ) THEN + print*, ' LOSS_ERROR stop at N = ', N + CALL ERROR_STOP( ' LOSS_ERROR is too small ', + & ' input_adj_mod.f ' ) + ENDIF + ENDDO + ENDIF + + ! Check tracers + ELSEIF ( LICS ) THEN + + DO N = 1, N_TRACERS + + ! Skip tracers that are not included in optimization + IF ( .not. OPT_THIS_TRACER(N) ) CYCLE + +#if defined ( LOG_OPT ) + IF ( ICS_ERROR(N) < ( 1d0 + SMAL2 ) ) THEN + print*, ' ICS_ERROR stop at N = ', N + CALL ERROR_STOP( ' ICS_ERROR is too small ', + & ' input_adj_mod.f ' ) + ENDIF +#else + IF ( ICS_ERROR(N) < ( SMAL2 ) ) THEN + print*, ' ICS_ERROR stop at N = ', N + CALL ERROR_STOP( ' ICS_ERROR is too small ', + & ' input_adj_mod.f ' ) + ENDIF +#endif + ENDDO + ENDIF + ENDIF + + !================================================================= + ! Check observation settings + !================================================================= +#if defined ( SCIA_KNMI_NO2_OBS ) || defined ( SCIA_DAL_NO2_OBS ) + ! Since the NO2 obs operators will pass adjoints back + ! to CSPEC via CSPEC_AFTER_CHEM_ADJ, we need to make sure that + ! these species are listed as observed species + FOUND = .FALSE. + DO N = 1, NOBS_CSPEC + + IF ( TRIM( NAMEGAS( IDCSPEC_ADJ(N) ) ) == 'NO2' ) THEN + FOUND = .TRUE. + ENDIF + + ENDDO + IF ( .not. FOUND ) THEN + + CALL ERROR_STOP( ' Need to list NO2 as observed species', + & ' input_adj_mod ' ) + ENDIF + +! BUG FIX: move this to INIT_CSPEC_ADJ, by which point the necessary +! CSPEC variables have been initialized (nb, dkh, 01/06/12, adj32_002) +!-------------------------------------------------------------------- +!#elif defined ( TES_O3_OBS ) +! ! Since the O3 obs operators will pass adjoints back +! ! to CSPEC via CSPEC_AFTER_CHEM_ADJ, we need to make sure that +! ! these species are listed as observed species +! FOUND = .FALSE. +! DO N = 1, NOBS_CSPEC +! +! IF ( TRIM( NAMEGAS( IDCSPEC_ADJ(N) ) ) == 'O3' ) THEN +! FOUND = .TRUE. +! ENDIF +! +! ENDDO +! IF ( .not. FOUND ) THEN +! +! CALL ERROR_STOP( ' Need to list O3 as observed species', +! & ' input_adj_mod ' ) +! ENDIF +!-------------------------------------------------------------------- +#endif + + ! We only observe species in CSPEC for full chemistry runs + IF ( .not. ITS_A_FULLCHEM_SIM() .and. + & NOBS_CSPEC /= 0 ) THEN + CALL ERROR_STOP( ' NOBS_CSPEC needs to be zero', + & ' input_adj_mod ' ) + ENDIF + + ! If we are using CSPEC for the cost function, then + ! at least one species needs to be listed in the obsevation + ! menu. + IF ( LCSPEC_PPB .and. ( .not. LCSPEC_OBS ) ) THEN + CALL ERROR_STOP( + & ' Need to observe a cspec species for LCSPEC_PPB', + & ' input_adj_mod ' ) + ENDIF + + ! If we are doing a sensitivty calculation w.r.t. cspec + ! observations, then make sure we have the cspec-based + ! option selected. + IF ( LSENS .and. LCSPEC_OBS .and. ( .not. LCSPEC_PPB ) + & .and. ( .not. LADJ_DDEP_CSPEC ) ) THEN + CALL ERROR_STOP( + & ' Need to select a cost function option that uses CSPEC', + & ' input_adj_mod ' ) + ENDIF +#if defined ( PSEUDO_OBS ) + IF ( LCSPEC_OBS ) THEN + CALL ERROR_STOP( + & ' PSEUDO_OBS only implemented for tracer obs', + & ' input_adj_mod ' ) + ENDIF +#endif + +! ! The deposition forcings are cummulative, and the coding +! ! of the timing of the forcing assumes LMAX_OBS +! IF ( LADJ_FDEP .and. ( .not. LMAX_OBS ) ) THEN +! CALL ERROR_STOP (' Need LMAX_OBS = T and NSPAN for LADJ_FDEP', +! & ' input_adj_mod ' ) +! ENDIF + + ! Deposition forcing FD tests use forward model diagnostics + ! for evaluation of depo fluxes + IF ( LFD_GLOB .and. ( LADJ_DDEP_TRACER .or. LADJ_DDEP_CSPEC ) + & .and. ( ND44 == 0 ) ) THEN + CALL ERROR_STOP (' Turn on ND44 for dry dep forcing FD test ', + & ' input_adj_mod ' ) + ENDIF + + ! Only allow one dep forcing option at a time for FD tests + IF ( LFDTEST .and. LADJ_FDEP ) THEN + COUNT_ON = 0 + IF ( LADJ_WDEP_LS ) COUNT_ON = COUNT_ON + 1 + IF ( LADJ_WDEP_CV ) COUNT_ON = COUNT_ON + 1 + IF ( LADJ_DDEP_TRACER ) COUNT_ON = COUNT_ON + 1 + IF ( LADJ_DDEP_CSPEC ) COUNT_ON = COUNT_ON + 1 + IF ( COUNT_ON > 1 ) THEN + CALL ERROR_STOP (' Only one dep forcing for FD test ', + & ' input_adj_mod ' ) + ENDIF + IF ( COUNT_ON == 0 ) THEN + CALL ERROR_STOP (' Which dep forcing option do you want?', + & ' input_adj_mod ' ) + ENDIF + ENDIF + + ! Deposition forcing uses forward model diagnostics + ! for evaluation of depo fluxes + IF ( LADJ_WDEP_LS .and. ( ND39 == 0 ) ) THEN + CALL ERROR_STOP (' Turn on ND39 for wet LS forcing ', + & ' input_adj_mod ' ) + ENDIF + + ! Deposition forcing uses forward model diagnostics + ! for evaluation of depo fluxes + IF ( LADJ_WDEP_CV .and. ( ND38 == 0 ) ) THEN + CALL ERROR_STOP (' Turn on ND38 for wet CV forcing ', + & ' input_adj_mod ' ) + ENDIF + + ! Deposition forcing uses forward model diagnostics + ! for evaluation of depo fluxes + IF ( ( LADJ_DDEP_TRACER .or. LADJ_DDEP_CSPEC ) .and. + & ( ND44 == 0 ) ) THEN + CALL ERROR_STOP (' Turn on ND44 for DDEP forcing ', + & ' input_adj_mod ' ) + ENDIF + + ! FD test of the dry deposition adjoint only supported for molec/cm2/s + IF ( LFD_GLOB .and. ( LADJ_DDEP_TRACER .or. LADJ_DDEP_CSPEC ) + & .and. ( .not. LMOLECCM2S ) ) THEN + CALL ERROR_STOP (' Set units to molec/cm2/s for ddep FD test', + & ' input_adj_mod ' ) + ENDIF + + ! FD test of the wet deposition adjoint only supported for kg/s + IF ( LFD_GLOB .and. ( LADJ_WDEP_LS .or. LADJ_WDEP_CV ) + & .and. ( .not. LKGS ) ) THEN + CALL ERROR_STOP (' Set units to kg/s for wdep FD test', + & ' input_adj_mod ' ) + ENDIF + + ! Make sure that NFD matches the observed tracer or species + IF ( LFDTEST ) THEN + + ! check species + IF ( NOBS_CSPEC > 0 ) THEN + + IF ( NFD /= 1 .or. NOBS_CSPEC > 1 ) THEN + CALL ERROR_STOP( + & ' For species FD, list only one species and set NFD = 1', + & ' input_adj_mod' ) + ENDIF + + ! check tracers + ELSE + + IF ( .not. OBS_THIS_TRACER(NFD) ) THEN + CALL ERROR_STOP(' Observed tracer and NFD must match', + & ' input_adj_mod' ) + ENDIF + + IF ( NOBS > 1 ) THEN + CALL ERROR_STOP(' Only observe tracer NFD for FD test', + & ' input_adj_mod' ) + ENDIF + ENDIF + + ENDIF + + ! Check to make sure that our observation time range fits in the + ! simulation time range + IF ( LMAX_OBS ) THEN + DATE = GET_TIME_AHEAD( NSPAN * OBS_FREQ ) + print*, ' DDD DATE = ', DATE + print*, ' DDD NYMDe= ', GET_NYMDe() + print*, ' DDD NHMSe= ', GET_NHMSe() + IF ( ( DATE(1) > GET_NYMDe() ) .or. + & ( DATE(1) == GET_NYMDe().and. + & DATE(2) > GET_NHMSe() ) ) THEN + CALL ERROR_STOP(' NSPAN too long! ', + & ' input_adj_mod' ) + ENDIF + ENDIF + + !================================================================= + ! Check diagnostics + !================================================================= + IF ( LEMS_ABS .and. ( .not. LADJ_EMS ) ) THEN + CALL ERROR_STOP (' LEMS_ABS only for active vars = emissions', + & ' input_adj_mod ' ) + ENDIF + + !================================================================= + ! Check if all emissions adjoint ID #'s are defined for particular + ! sets of emissions species. + !================================================================= + + ! Primary carbonaceous aerosol emissions + IF ( IDADJ_EBCPI_an > 0 .and. IDADJ_EBCPO_an > 0 .and. + & IDADJ_EOCPI_an > 0 .and. IDADJ_EOCPO_an > 0 .and. + & IDADJ_EBCPI_bb > 0 .and. IDADJ_EBCPO_bb > 0 .and. + & IDADJ_EOCPI_bb > 0 .and. IDADJ_EOCPO_bb > 0 .and. + & IDADJ_EBCPI_bf > 0 .and. IDADJ_EBCPO_bf > 0 .and. + & IDADJ_EOCPI_bf > 0 .and. IDADJ_EOCPO_bf > 0 ) THEN + IS_CARB_EMS_ADJ = .TRUE. + ENDIF + IF ( N_CARB_EMS_ADJ > 0 .and. ( .not. IS_CARB_EMS_ADJ ) ) THEN + CALL ERROR_STOP( 'Not enough carbon emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + IF ( N_CARB_EMS_ADJ > 12 ) THEN + CALL ERROR_STOP( 'Too many carbon emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + + ! Sulfate aerosol (and precursor) emissions + IF ( IDADJ_ENH3_bb > 0 .and. IDADJ_ENH3_bf > 0 .and. + & IDADJ_ENH3_na > 0 .and. IDADJ_ENH3_an > 0 .and. + & IDADJ_ESO2_bb > 0 .and. IDADJ_ESO2_an1 > 0 .and. + & IDADJ_ESO2_bf > 0 .and. IDADJ_ESO2_an2 > 0 .and. + & IDADJ_ESO2_sh > 0 ) THEN + IS_SULF_EMS_ADJ = .TRUE. + ENDIF + IF ( N_SULF_EMS_ADJ > 0 .and. ( .not. IS_SULF_EMS_ADJ ) ) THEN + CALL ERROR_STOP( + & 'Not enough sulfate aerosol emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + IF ( N_SULF_EMS_ADJ > 9 ) THEN + CALL ERROR_STOP( 'Too many sulfate emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + + ! Dust aerosol emissions ( xxu, 11/01/10) (dkh, 01/09/12, adj32_011) + IF ( IDADJ_EDST1 > 0 .and. IDADJ_EDST2 > 0 .and. + & IDADJ_EDST3 > 0 .and. IDADJ_EDST4 > 0 ) THEN + IS_DUST_EMS_ADJ = .TRUE. + ENDIF + IF ( N_DUST_EMS_ADJ > 0 .and. ( .not. IS_DUST_EMS_ADJ ) ) THEN + CALL ERROR_STOP( + & 'Not enough Dust aerosol emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + IF ( N_DUST_EMS_ADJ > 4 ) THEN + CALL ERROR_STOP( 'Too many dust emissions adjoint IDs ', + & 'ARE_FLAGS_VALID') + ENDIF + + !================================================================= + ! Check consistency between input.gcadj and define_adj.h options + !================================================================= + + IF ( LBKCOV ) THEN + + IF ( LICS ) CALL ERROR_STOP( 'Off-diagonal calculation only + & works with LADJ_EMDS', 'ARE_FLAGS_VALID' ) + +#if ! defined ( LBKCOV_ERR ) + + CALL ERROR_STOP( 'Off-diagonal calculation requires LBKCOV_ERR + & to be set in define_adj.h ', 'ARE_FLAGS_VALID' ) + +#endif + ENDIF + +#if defined ( LBKCOV_ERR ) + IF ( .not. LBKCOV ) THEN + + CALL ERROR_STOP( 'Off-diagonal calculation requires LBKCOV + & to be set in input.gcadj ', 'ARE_FLAGS_VALID' ) + + ENDIF +#endif + + + IF ( LINVH_BFGS ) THEN +#if ! defined ( LBFGS_INV ) + + CALL ERROR_STOP( 'L-BFGS calculation requires LBFGS_INV + & to be set in define_adj.h ', 'ARE_FLAGS_VALID' ) + +#endif + ENDIF + +#if defined ( LBFGS_INV ) + IF ( .not. LINVH_BFGS ) THEN + + CALL ERROR_STOP( 'L-BFGS calculation requires an option + & to be set in input.gcadj ', 'ARE_FLAGS_VALID' ) + + ENDIF +#endif + + ! fp check for wetdep sensitivities: these units only make sense + ! if we observe one tracer or species at a time. + IF ( ( LKGS .OR. LMOLECCM2S ) .AND. + & ( ( NOBS_CSPEC .GT. 1 ) .OR. ( NOBS .GT. 1 ) ) ) THEN + + CALL ERROR_STOP(' Does not seem to make sense ?', + & 'ARE_FLAGS_VALID') + ENDIF + + !throw an error if kks and nobs_cspec>1 + IF ( LKGS .AND. ( NOBS_CSPEC .GT. 1) ) THEN + CALL ERROR_STOP(' not implemented', + & 'ARE_FLAGS_VALID') + ENDIF + + + IF ( LEQHAYR .OR. LKGNHAYR ) THEN + + DO T = 1, NOBS_CSPEC + + FOUND = .FALSE. + + DO N = 1, N_NDEP_CSPEC + + IF ( TRIM(CNAME(T)) + & .NE. TRIM(NDEP_CSPEC(N)) ) + & FOUND = .TRUE. + + ENDDO + + IF ( .not. FOUND ) THEN + WRITE(6,'( a )') CNAME(T) + CALL ERROR_STOP(' Does not seem to make sense ?', + & 'ARE_FLAGS_VALID') + ENDIF + + ENDDO + + DO T = 1, N_TRACERS + + IF ( OBS_THIS_TRACER(T) ) THEN + + FOUND = .FALSE. + + DO N = 1,N_NDEP + + IF ( T .EQ. NDEP( N ) ) FOUND = .TRUE. + + ENDDO + + IF ( LEQHAYR ) THEN + + DO N = 1,N_ACID + + IF ( T .EQ. ACID(N) ) FOUND = .TRUE. + + ENDDO + + ENDIF + + IF ( .not. FOUND ) THEN + WRITE(6,*) 'TRACER: ',TRACER_NAME(T) + CALL ERROR_STOP(' Does not seem to make sense ?', + & 'ARE_FLAGS_VALID') + ENDIF + + ENDIF + ENDDO + + ENDIF + + IF ( LADJ_CL ) THEN + + IF ( .not. LADJ_CL_NDEP .and. + & .not. LADJ_CL_ACID ) THEN + + CALL ERROR_STOP(' Need to select N/Ac for Cl cost function', + & 'ARE_FLAGS_VALID') + + ENDIF + + IF ( LADJ_CL_NDEP .and. .not. LKGNHAYR ) + & CALL ERROR_STOP(' Units are inconsistent', + & 'ARE_FLAGS_VALID') + + + IF ( LADJ_CL_ACID .and. .not. LEQHAYR ) + & CALL ERROR_STOP(' Units are inconsistent', + & 'ARE_FLAGS_VALID') + + + IF ( .not. LADJ_DDEP_TRACER .OR. + & .not. LADJ_DDEP_CSPEC .OR. + & .not. LADJ_WDEP_LS .OR. + & .not. LADJ_WDEP_CV ) THEN + + CALL ERROR_STOP( + & ' All deposition flags need to be turned on', + & 'ARE_FLAGS_VALID') + + ENDIF + + DO T = 1, N_NDEP + + IF ( .not. OBS_THIS_TRACER( NDEP(T) ) ) THEN + + WRITE(*,*) 'TRACER: ',TRACER_NAME(NDEP(T)) + CALL ERROR_STOP( + & 'All N/Acid species need to be listed', + & 'ARE_FLAGS_VALID') + + ENDIF + + ENDDO + + IF ( LADJ_CL_ACID ) THEN + + DO T = 1, N_ACID + + IF ( .not. OBS_THIS_TRACER( ACID(T) ) ) THEN + + WRITE(*,*) 'TRACER: ',TRACER_NAME(ACID(T)) + + CALL ERROR_STOP( + & ' All N/Acid species need to be listed', + & 'ARE_FLAGS_VALID') + ENDIF + + ENDDO + + ENDIF + + DO N = 1, N_NDEP_CSPEC + + FOUND = .FALSE. + + DO T = 1, NOBS_CSPEC + + IF ( TRIM(CNAME(T)) + & .NE. TRIM(NDEP_CSPEC(N)) ) + & FOUND = .TRUE. + + ENDDO + + IF ( .not. FOUND ) THEN + + WRITE(*,*) 'CSPEC: ',TRIM(NDEP_CSPEC(N)) + CALL ERROR_STOP( + & ' All N/Acid species need to be listed', + & 'ARE_FLAGS_VALID') + ENDIF + + ENDDO + + + ENDIF + + + ! Return to calling program + END SUBROUTINE ARE_FLAGS_VALID + +!------------------------------------------------------------------------------ + + SUBROUTINE VALIDATE_DIRECTORIES +! +!****************************************************************************** +! Subroutine VALIDATE_DIRECTORIES makes sure that each of the directories +! that we have read from the GEOS-CHEM input file are valid. Also, trailing +! separator characters will be added. (bmy, 7/20/04, 8/4/06) +! +! NOTES: +! (1 ) Now make sure all USE statements are USE, ONLY. Now also validate +! GCAP and GEOS-5 directories. (bmy, 10/3/05) +! (2 ) Now references DATA_DIR_1x1 from directory_mod.f (bmy, 10/24/05) +! (3 ) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +!****************************************************************************** +! + ! References to F90 modules + ! References to F90 modules + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR, ADJTMP_DIR, DIAGADJ_DIR + + ! Local variables + CHARACTER(LEN=255) :: DIR + + !================================================================= + ! VALIDATE_DIRECTORIES begins here! + !================================================================= + + ! Check directories + CALL CHECK_DIRECTORY( OPTDATA_DIR ) + CALL CHECK_DIRECTORY( ADJTMP_DIR ) + CALL CHECK_DIRECTORY( DIAGADJ_DIR ) + + ! Return to calling program + END SUBROUTINE VALIDATE_DIRECTORIES + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_DIRECTORY( DIR ) +! +!****************************************************************************** +! Subroutine CHECK_DIRECTORY makes sure that the given directory +! is valid. Also a trailing slash character will be added if necessary. +! (bmy, 3/20/03, 3/23/05) +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) DIR (CHARACTER) : Directory to be checked +! +! NOTES: +! (1 ) Now references FILE_EXISTS from "file_mod.f" (bmy, 3/23/05) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE FILE_MOD, ONLY : FILE_EXISTS + USE UNIX_CMDS_MOD, ONLY : SEPARATOR + + ! Arguments + CHARACTER(LEN=*), INTENT(INOUT) :: DIR + + ! Local variables + INTEGER :: C + CHARACTER(LEN=255) :: MSG + + !================================================================= + ! CHECK_DIRECTORY begins here! + !================================================================= + + ! Locate the last non-white-space character of NEWDIR + C = LEN_TRIM( DIR ) + + ! Add the trailing directory separator if it is not present + IF ( DIR(C:C) /= TRIM( SEPARATOR ) ) THEN + DIR(C+1:C+1) = TRIM( SEPARATOR ) + ENDIF + + !================================================================= + ! Test if the directory actually exists + !================================================================= + + ! If the directory does not exist then stop w/ an error message + IF ( .not. FILE_EXISTS( DIR ) ) THEN + MSG = 'Invalid directory: ' // TRIM( DIR ) + CALL ERROR_STOP( MSG, 'CHECK_DIRECTORY ("input_adj_mod.f")' ) + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK_DIRECTORY + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_FILE( FILE ) +! +!****************************************************************************** +! Subroutine CHECK_FILE makes sure that the given file exists. (dkh, 03/10/13) +! Based on CHECK_DIR (bmy, 3/20/03, 3/23/05) +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) FILE (CHARACTER) : File to be checked +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE FILE_MOD, ONLY : FILE_EXISTS + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: FILE + + ! Local variables + CHARACTER(LEN=255) :: MSG + + !================================================================= + ! CHECK_FILE begins here! + !================================================================= + + ! If the directory does not exist then stop w/ an error message + IF ( .not. FILE_EXISTS( FILE ) ) THEN + MSG = 'Invalid file: ' // TRIM( FILE ) + CALL ERROR_STOP( MSG, 'CHECK_FILE ("input_adj_mod.f")' ) + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEAN_FILE_DIRS() +! +!****************************************************************************** +! Subroutine CLEAN_FILE_DIRS gets rid of files in ADJTMP_DIR and in OptData that +! are left over from previous runs. (10/28/04) +! +! +! NOTES: +! (1 ) If the last run to be computed completed cleanly, there will not be +! any *.chk.* files, and SYSTEM will complain a bit about this. It's OK +! (dkh, 10/03/04) +! (2 ) Add caviot that if L_MAKE_CHK is false, don't delete old *chk* files +! (3 ) Add feature to clean out OPTDATA_DIR (dkh, 10/28/04) +! (4 ) Delete *.ics.* and *.gdt.* files during observation run. (dkh, 11/11/04) +! (5 ) Delete cfn.* files during observation run. (dkh, 02/13/06) +! (6 ) Move from inverse_mod.f to input_adj_mod.f (dkh, 07/28/09) +! (7 ) Now clean out old ems.adj.* and gctm.iteration files (dkh, 02/17/11) +! (8 ) Now keep files for offline inv hessian (dkh, 01/12/12, adj32_012) +! (9 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (10 ) Add LINVH_BFGS (nab, 25/03/12 ) +!****************************************************************************** +! + ! Reference to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_STOP + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LEMS_ABS + USE LOGICAL_ADJ_MOD, ONLY : LITR + USE LOGICAL_ADJ_MOD, ONLY : LINVH,LINVH_BFGS + +# include "CMN_SIZE" ! Size params + + ! Local variables + CHARACTER(LEN=255) :: REMOVE_OBS_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_ADJ_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_OPT_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_FD_FILE_CMD + + !============================================================ + ! CLEAN_FILE_DIRS starts here! + !============================================================ + + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'C L E A N O U T O L D F I L E S' + + IF ( N_CALC_STOP == 0 ) THEN + + ! Clear any old .obs. files + REMOVE_OBS_FILE_CMD = 'rm ' // + & TRIM( ADJTMP_DIR ) // '*.obs.*' + + WRITE( 6, 102 ) TRIM( REMOVE_OBS_FILE_CMD ) + 102 FORMAT( ' - INVERSE: Executing: ',a ) + + CALL SYSTEM( TRIM ( REMOVE_OBS_FILE_CMD ) ) + + ! Clean out old *.gdt.*, *.ics.* and cnf.* files + REMOVE_OPT_FILE_CMD = 'rm ' // + & TRIM (OPTDATA_DIR) // '*.gdt.*' + & // ' ' // + & TRIM (OPTDATA_DIR) // '*.sf.*' + & // ' ' // + & TRIM (OPTDATA_DIR) // 'cfn.*' + + WRITE( 6, 102 ) TRIM( REMOVE_OPT_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_OPT_FILE_CMD ) ) + + + ELSE + + + ! Clean out old .chk. files + REMOVE_CHK_FILE_CMD = 'rm ' // + & TRIM (ADJTMP_DIR) // '*.chk.*' + + WRITE( 6, 102 ) TRIM( REMOVE_CHK_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_CHK_FILE_CMD ) ) + + + ! Clean out old .adj. files + ! BUG FIX: the *.adj.* files are in DAIGADJ_DIR (jk, dkh, 04/25/10) + ! Update: be more specific here so that we don't delete ems.adj.NN + ! (dkh, 02/18/11) + ! Now keep these if doing inv Hessian update (dkh, 01/12/12, adj32_012) + IF ( .not. ( LINVH .or. LINVH_BFGS ) ) THEN + + REMOVE_ADJ_FILE_CMD = 'rm ' // + & TRIM (DIAGADJ_DIR) // 'gctm.adj.*' + + WRITE( 6, 102 ) TRIM( REMOVE_ADJ_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_ADJ_FILE_CMD ) ) + + ! Remove optimization files now, as would have been done normally + ! for the "REFERENCE" run at N_CALC_STOP = 0, as the JACOBIAN test + ! run begins with N_CALC_STOP = 1. + IF ( N_CALC_STOP == 1 ) THEN + + ! Clean out old *.gdt.*, *.ics.* and cnf.* files + REMOVE_OPT_FILE_CMD = 'rm ' // + & TRIM (OPTDATA_DIR) // '*.gdt.*' + & // ' ' // + & TRIM (OPTDATA_DIR) // '*.sf.*' + & // ' ' // + & TRIM (OPTDATA_DIR) // 'cfn.*' + + WRITE( 6, 102 ) TRIM( REMOVE_OPT_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_OPT_FILE_CMD ) ) + + ! Clean out old *.fd.* files (dkh, 06/24/09) + REMOVE_FD_FILE_CMD = 'rm ' // + & TRIM (DIAGADJ_DIR) // '*.fd.*' + & // ' ' // + & TRIM (DIAGADJ_DIR) // '*.fdglob.*' + + WRITE( 6, 102 ) TRIM( REMOVE_FD_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_FD_FILE_CMD ) ) + + ! Clean out old ems.adj.* files (dkh, 02/17/11) + IF ( LEMS_ABS ) THEN + REMOVE_ADJ_FILE_CMD = 'rm ' // + & TRIM (DIAGADJ_DIR) // 'ems.adj.*' + + WRITE( 6, 102 ) TRIM( REMOVE_ADJ_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_ADJ_FILE_CMD ) ) + ENDIF + + ! Clean out old gctm.iteration file (dkh, 02/17/11) + IF ( LITR ) THEN + REMOVE_ADJ_FILE_CMD = 'rm ' // + + & TRIM (DIAGADJ_DIR) // 'gctm.iteration' + + WRITE( 6, 102 ) TRIM( REMOVE_ADJ_FILE_CMD ) + + CALL SYSTEM ( TRIM( REMOVE_ADJ_FILE_CMD ) ) + ENDIF + + ENDIF + + ENDIF ! LINV + + ENDIF + + END SUBROUTINE CLEAN_FILE_DIRS + +!----------------------------------------------------------------------------------------- + + SUBROUTINE INIT_DEP_MAPS +! +!****************************************************************************** +! Subroutine INIT_DEP_MAPS creates mapping arrays for going from tracer and +! species concentrations to deposition index. (dkh, 05/30/13) +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NOBS2NDEP + USE ADJ_ARRAYS_MOD, ONLY : NOBSCSPEC2NDEP + USE ADJ_ARRAYS_MOD, ONLY : NOBS2NWDEP + USE ADJ_ARRAYS_MOD, ONLY : NTR2NOBS + USE ADJ_ARRAYS_MOD, ONLY : TRACER_IND + USE ADJ_ARRAYS_MOD, ONLY : NOBS + USE ADJ_ARRAYS_MOD, ONLY : NOBS_CSPEC + USE ADJ_ARRAYS_MOD, ONLY : IDCSPEC_ADJ + USE DRYDEP_MOD, ONLY : NTRAIND + USE DRYDEP_MOD, ONLY : NUMDEP + USE DRYDEP_MOD, ONLY : DEPNAME + USE ERROR_MOD, ONLY : ERROR_STOP + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRACER_MOD, ONLY : N_TRACERS + USE WETSCAV_MOD, ONLY : GET_WETDEP_IDWETD + USE WETSCAV_MOD, ONLY : NSOL + +# include "CMN_SIZE" +# include "comode.h" ! IRM + + ! Local variables + INTEGER :: N + INTEGER :: NN + INTEGER :: AS + INTEGER :: JJ + INTEGER :: NK + LOGICAL :: FOUND + + !================================================================= + ! INIT_DEP_MAPS begins here! + !================================================================= + + ALLOCATE( NOBS2NDEP( NOBS ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NOBS2NDEP' ) + NOBS2NDEP = 0 + + ALLOCATE( NOBSCSPEC2NDEP( NOBS_CSPEC ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NOBSCSPEC2NDEP' ) + NOBSCSPEC2NDEP = 0 + + ALLOCATE( NOBS2NWDEP( NOBS ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NOBS2NWDEP' ) + NOBS2NWDEP = 0 + + ALLOCATE( NTR2NOBS( N_TRACERS ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NTR2NOBS' ) + NTR2NOBS = 0 + + ! NOBS2NDEP: Map from NOBS to N_DEP (drydep id) + DO N = 1, NOBS + + DO NN = 1, NUMDEP + IF ( NTRAIND(NN) == TRACER_IND(N) ) NOBS2NDEP(N) = NN + ENDDO + + ENDDO + + ! NOBSCSPEC2NDEP: Map from NOBS_CSPEC to N_DEP (drydep id) + DO N = 1, NOBS_CSPEC + + !DO NN = 1, NUMDEP + ! this may not work since CNAME would by DRYNO2 and DEPNAME NO2? or NOx? + ! IF ( DEPNAME(NN) == CNAME(N) ) NOBSCSPEC2NDEP(N) = NN + ! ENDDO + + ! Determine drydep ID that corresponds to this species + NOBSCSPEC2NDEP(N) = -999 + NCS = NCSURBAN + + DO NN = 1, NUMDEP + + NK = NTDEP(NN) + IF ( NK <= 0 ) CYCLE + JJ = IRM(NPRODLO+1,NK,NCS) + IF ( JJ == IDCSPEC_ADJ(N) ) NOBSCSPEC2NDEP(N) = NN + + ENDDO + + IF ( NOBSCSPEC2NDEP(N) < 0 ) THEN + CALL ERROR_STOP('Species not in ND44','INIT_CSPEC_ADJ.f') + ENDIF + + ENDDO + + ! NOBS2NWDEP: Map from NOBS to N_WDEP (wetdep id) + DO N = 1, NOBS + + ! Get wetdep ID number for this observed tracer + DO NN = 1, NSOL + IF ( GET_WETDEP_IDWETD(NN) == TRACER_IND(N) ) + & NOBS2NWDEP(N) = NN + ENDDO + + ENDDO + + ! NTR2NOBS: Map from tracer index to observed tracer index + DO NN = 1, N_TRACERS + + DO N = 1, NOBS + + IF ( TRACER_IND(N) == NN ) NTR2NOBS(NN) = N + + ENDDO + + ENDDO + +! ! NTR2NOBSCSPEC: Map from tracer index to observed species index +! DO NN = 1, NTRACER +! +! DO N = 1, NOBS_CSPEC +! +! IF ( TRACER_IND(N) == NN ) NTR2NOBSCSPEC(NN) = N +! +! ENDDO +! +! ENDDO + + ! Return to calling program + END SUBROUTINE INIT_DEP_MAPS + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_INPUT_ADJ +! +!****************************************************************************** +! Subroutine INIT_INPUT_ADJ initializes all variables from +! "directory_adj_mod.f" and "logical_adj_mod.f" for safety's sake. +! (adj_group, 6/07/09) +! +! NOTES: +! (1 ) Add LTES_PSO (kjw, dkh, 02/12/12, adj32_023) +! (2 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (3 ) Add LINVH_BFGS (nab, 25/03/12 ) +!****************************************************************************** +! + ! References to F90 modules + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR, ADJTMP_DIR, DIAGADJ_DIR + USE LOGICAL_ADJ_MOD, ONLY : LADJ,LADJ_TRAN, LADJ_CHEM, + & LAERO_THERM, LFD_SPOT, LFD_GLOB, + & LSENS, L4DVAR, L3DVAR, LAPSRC, + & LBKCOV,LINVH,LINVH_BFGS, + & LLINOZ, LFDTEST, LISO, + & LICS, LRXNR, LADJDIAG, LJSAVE, + & LDCOSAT, LHMOD, LHOBS, + & LHMODIFF, LADJ_FORCE, LMODBIAS, + & LOBS_COUNT, LDOFS, LADJ_EMS, + & LDEL_CHKPT, LADJ_TRAJ, LITR, + & LDEVOC, LTES_PSO, LADJ_STRAT, + & LADJ_RRATE, + & LADJ_CL, LADJ_CL_NDEP, LADJ_CL_ACID + + + !================================================================= + ! INIT_INPUT_ADJ begins here! + !================================================================= + + ! Initialize directories + OPTDATA_DIR = '' + DIAGADJ_DIR = '' + ADJTMP_DIR = '' + + ! Initialize logicals + LADJ = .FALSE. + LADJ_TRAN = .FALSE. + LADJ_CHEM = .FALSE. + LAERO_THERM = .FALSE. + LFD_SPOT = .FALSE. + LFD_GLOB = .FALSE. + LSENS = .FALSE. + L4DVAR = .FALSE. + L3DVAR = .FALSE. + LAPSRC = .FALSE. + LBKCOV = .FALSE. + LINVH = .FALSE. + LINVH_BFGS = .FALSE. + LISO = .FALSE. + !LLINOZ = .FALSE. + LFDTEST = .FALSE. + LADJ_EMS = .FALSE. + LICS = .FALSE. + LRXNR = .FALSE. + LADJDIAG = .FALSE. + LJSAVE = .FALSE. + LADJ_TRAJ = .FALSE. + LDCOSAT = .FALSE. + LHMOD = .FALSE. + LHOBS = .FALSE. + LHMODIFF = .FALSE. + LADJ_FORCE = .FALSE. + LMODBIAS = .FALSE. + LOBS_COUNT = .FALSE. + LDOFS = .FALSE. + LDEL_CHKPT = .FALSE. + LITR = .FALSE. + LDEVOC = .TRUE. + LTES_PSO = .FALSE. + LADJ_STRAT = .FALSE. + LADJ_RRATE = .FALSE. + LADJ_CL = .FALSE. + LADJ_CL_NDEP= .FALSE. + LADJ_CL_ACID= .FALSE. + + ! Initialize counters + CT1 = 0 + CT2 = 0 + CT3 = 0 + + ! Return to calling program + END SUBROUTINE INIT_INPUT_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_STRID_FILE +! +!****************************************************************************** +! Subroutine READ_STRID_FILE reads the list of stratospheric production +! and loss rates from STR_ID file in run directory. +! (hml, 05/22/13) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE ADJ_ARRAYS_MOD, ONLY : ID_PROD + USE ADJ_ARRAYS_MOD, ONLY : ID_LOSS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_PROD + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_LOSS + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : PROD_NAME + USE ADJ_ARRAYS_MOD, ONLY : LOSS_NAME + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_PROD + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_LOSS + USE ADJ_ARRAYS_MOD, ONLY : PROD_ERROR + USE ADJ_ARRAYS_MOD, ONLY : LOSS_ERROR + USE FILE_MOD, ONLY : IOERROR, IU_STR + + + ! local variables + INTEGER :: IOS + INTEGER :: T + INTEGER :: N + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + + !================================================================= + ! READ_STRID_FILE begins here! + !================================================================= + + ! Open STR_ID file containing list of 24x2 strat prod & loss + OPEN( IU_STR, FILE='STR_ID', STATUS='OLD', IOSTAT=IOS ) + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_STR,'read_input_adj_strat:1') + + READ_STR_ID = .TRUE. + + ! Read a header line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_STR_ID:1') + + DO T = 1, NSTPL + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_strat_p') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_PROD(T) + + ! Save tracer name + PROD_NAME(T) = TRIM( SUBSTRS(2) ) + + ! optimize this strat prod & loss? + READ( SUBSTRS(3), *) OPT_THIS_PROD(T) + + ! Defualt prod scaling factor for this strat tracer + READ( SUBSTRS(4), *) PROD_SF_DEFAULT(T) + + ! REG_PARAM for this strat tracer + READ( SUBSTRS(5), *) REG_PARAM_PROD(T) + + ! STR_ERROR for this strat tracer + READ( SUBSTRS(6), *) PROD_ERROR(T) + + ENDDO + + DO T = 1, NSTPL + + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1,'read_strat_l') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_LOSS(T) + + ! Save tracer name + LOSS_NAME(T) = TRIM( SUBSTRS(2) ) + + ! optimize this strat prod & loss? + READ( SUBSTRS(3), *) OPT_THIS_LOSS(T) + + ! Defualt loss scaling factor for this strat tracer + READ( SUBSTRS(4), *) LOSS_SF_DEFAULT(T) + + ! REG_PARAM for this strat tracer + READ( SUBSTRS(5), *) REG_PARAM_LOSS(T) + + ! STR_ERROR for this strat tracer + READ( SUBSTRS(6), *) LOSS_ERROR(T) + + ENDDO + + CLOSE(IU_STR) + + READ_STR_ID = .FALSE. + + ! Return to calling program + END SUBROUTINE READ_STRID_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_RXNID_FILE +! +!****************************************************************************** +! Subroutine READ_RXNID_FILE reads the list of kpp reactions +! from RXN_ID file in run directory. +! (hml, 05/22/13) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE FILE_MOD, ONLY : IOERROR, IU_RXN + USE ADJ_ARRAYS_MOD, ONLY : NRRATES + USE ADJ_ARRAYS_MOD, ONLY : ID_RRATES + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_RATE + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : RRATES_NAME + USE ADJ_ARRAYS_MOD, ONLY : REG_PARAM_RATE + USE ADJ_ARRAYS_MOD, ONLY : RATE_ERROR + + ! local variables + INTEGER :: IOS + INTEGER :: N + INTEGER :: T + CHARACTER(LEN=255) :: SUBSTRS(MAXDIM) + + + !================================================================= + ! READ_RXNID_FILE begins here! + !================================================================= + + ! Open RXN_ID file containing list of 297 reactions + OPEN( IU_RXN, FILE='RXN_ID', STATUS='OLD', IOSTAT=IOS ) + + IF ( IOS /= 0 ) CALL IOERROR( + & IOS,IU_RXN,'read_input_adj_rrate:1') + + READ_RXN_ID = .TRUE. + + ! Read a header line + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_RXN_ID:1') + + DO T = 1, NRRATES + ! Split line into substrings + CALL SPLIT_ONE_LINE( SUBSTRS, N, -1, 'read_RXN_ID:2') + + ! Save tracer number + READ( SUBSTRS(1), * ) ID_RRATES(T) + + ! Save tracer name + RRATES_NAME(T) = TRIM( SUBSTRS(2) ) + + ! Optimize this rate? + READ( SUBSTRS(3), * ) OPT_THIS_RATE(T) + + ! Default scaling factor for this rate + READ( SUBSTRS(4), * ) RATE_SF_DEFAULT(T) + + ! REG_PARAM for this rate + READ( SUBSTRS(5), * ) REG_PARAM_RATE(T) + + ! RATE_ERROR for this rate + READ( SUBSTRS(6), * ) RATE_ERROR(T) + + ENDDO + + CLOSE(IU_RXN) + + READ_RXN_ID = .FALSE. + + + ! Return to calling program + END SUBROUTINE READ_RXNID_FILE + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE INPUT_ADJ_MOD diff --git a/code/adjoint/inv_hessian_lbfgs_mod.f b/code/adjoint/inv_hessian_lbfgs_mod.f new file mode 100644 index 0000000..2f8f069 --- /dev/null +++ b/code/adjoint/inv_hessian_lbfgs_mod.f @@ -0,0 +1,1464 @@ +!$ID$ + MODULE INV_HESSIAN_LBFGS_MOD +! +!***************************************************************************** +! Module INV_HESSIAN_LBFGS_MOD contains all the subroutines that are used for +! calculating the diagonal of the approximate L-BFGS inverse Hessian. +! (nab, 03/23/12, adj32_027) +! +! Module Variables: +! ============================================================================ +! (1 ) IIMAP (INTEGER) : 4D to 1D mapping array +! (2 ) EMS_SF_OLD (REAL*8) : Scaling factors at previous iteration +! (3 ) EMS_SF_ADJ_OLD (REAL*8) : Gradients at previous iteration +! +! Module Routines +! ============================================================================ +! (1 ) LBFGS_INV_HESSIAN : Updates inv Hessian estimate +! (2 ) READ_GDT_FILE_AT : Read gradient file +! (3 ) READ_SF_FILE_AT : Read scaling factor file +! (4 ) MAKE_HESS_DIAG_FILE : Saves diagonal of inv Hessian to file +! (5 ) INIT_INV_HESSIAN : Allocates and intializes module variables +! (6 ) CLEANUP_INV_HESSIAN : Deallocates module variables +! +! NOTES: +! (1 ) Now calculate the inverse Hessian approximation for all emissions (nab) +! +! +! For any question please contact: +! Contact: Nicolas Bousserez (Nicolas.Bousserez@colorado.edu) +!****************************************************************************** +! + IMPLICIT NONE + +# include "define_adj.h" ! obs operators + + !==================================================================== + ! MODULE VARIABLES ( those that used to be program variables ) + !==================================================================== + INTEGER, ALLOCATABLE :: IIMAP(:,:,:,:) + REAL*8, ALLOCATABLE :: EMS_SF_OLD(:,:,:,:) + REAL*8, ALLOCATABLE :: EMS_SF_ADJ_OLD(:,:,:,:) + REAL*8, ALLOCATABLE :: ICS_SF_OLD(:,:,:,:) + REAL*8, ALLOCATABLE :: ICS_SF_ADJ_OLD(:,:,:,:) + + INTEGER, ALLOCATABLE :: MAPI(:), MAPJ(:), MAPL(:) + INTEGER, ALLOCATABLE :: MAPM(:), MAPN(:) + REAL*8 , ALLOCATABLE :: HINVD(:) + + !==================================================================== + ! MODULE ROUTINES + !==================================================================== + + CONTAINS + +!----------------------------------------------------------------------------- + SUBROUTINE LBFGS_INV_HESSIAN( MK ) +! +!****************************************************************************** +! Compute the diagonal terms of the posterior error covariance +! matrix using the L-BFGS formula: +! +! Byrd, R. H.; Lu, P.; Nocedal, J.; Zhu, C. (1995). "A Limited Memory Algorithm +! for Bound Constrained Optimization". SIAM Journal on Scientific Computing 16 (5): 1190 +! +! Variable as Input: +! ============================================================================ +! (1 ) MK : Number of last previous iteration used in the inverse +! Hessian L-BFGS approximation +! +! Module variables as Output: +! ============================================================================ +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF,ICS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ,ICS_SF_ADJ + USE ERROR_MOD, ONLY : ALLOC_ERR , ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE MKL95_BLAS + USE MKL95_LAPACK + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" + + ! Arguments + INTEGER, OPTIONAL, INTENT(IN) :: MK + + ! Local variables + REAL(8) :: TMPDP1, TMPDP2 + REAL(8) :: THETA,THETA_DENO,THETA_NUM + REAL(8), ALLOCATABLE :: WS(:,:) + REAL(8), ALLOCATABLE :: WY(:,:) + REAL(8), ALLOCATABLE :: RK(:,:) + REAL(8), ALLOCATABLE :: DK(:,:) + REAL(8), ALLOCATABLE :: MM(:,:) + CHARACTER(LEN=255) :: MSG + INTEGER :: KK, INFO + INTEGER :: MM1 + INTEGER :: I, J,L, M, N, II, JJ, NITR, AS + INTEGER :: HMAX + + !================================================================= + ! LBFGS_INV_HESSIAN begins here! + !================================================================= + + PRINT*,'********************************************' + PRINT*,'STARTING L-BFGS INVERSE HESSIAN CALCULATION' + PRINT*,'********************************************' + + IF ( LADJ_EMS ) THEN + HMAX = IIPAR * JJPAR * MMSCL * NNEMS + ELSEIF ( LICS ) THEN + HMAX = IIPAR * JJPAR * LLPAR * N_TRACERS + ENDIF + + ! allocate and initialize arrays + CALL INIT_INV_HESSIAN( HMAX ) + + KK = N_CALC + + MM1 = KK + IF ( PRESENT(MK) ) MM1 = MK + MM1 = MIN( KK - 1, MM1 ) + HINVD(:) = 0d0 + + IF( KK == 0 ) THEN + + HINVD(:) = 1d0 + + RETURN + + ENDIF + + ! ALLOCATIONS + ALLOCATE( WS(MM1,HMAX), STAT = AS ) + IF ( AS /= 0) CALL ALLOC_ERR( 'WS', AS ) + WS = 0d0 + + ALLOCATE(WY(HMAX,MM1),STAT=AS) + IF ( AS /= 0) CALL ALLOC_ERR( 'WY', AS ) + WY = 0d0 + + + ALLOCATE( RK(MM1,MM1), STAT = AS ) + IF ( AS /= 0) CALL ALLOC_ERR( 'RK', AS ) + RK = 0d0 + + ALLOCATE( DK(MM1,MM1), STAT = AS ) + IF ( AS /= 0) CALL ALLOC_ERR( 'DK', AS ) + DK = 0d0 + + ALLOCATE( MM(MM1,HMAX), STAT = AS ) + IF ( AS /= 0) CALL ALLOC_ERR( 'MM', AS ) + MM = 0d0 + + II = 0 + + IF ( LADJ_EMS ) THEN + + DO N = 1, NNEMS + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + !============================================== + ! Apply filters + !============================================== + + ! Only in places where emissions are nonzero + !IF ( ABS(ADJ_EMS(I,J,M,N)) < 1d-4 ) CYCLE + + ! Update vector index + II = II + 1 + + ! Save mapping arrays + IIMAP(I,J,M,N) = II + MAPI(II) = I + MAPJ(II) = J + MAPM(II) = M + MAPN(II) = N + + !ENDIF + + ENDDO + ENDDO + ENDDO + ENDDO + + + !================================================== + ! Start L-BFGS inverse Hessian diagonal elements extraction + !================================================== + + DK = 0d0 + + + DO JJ = 1, MM1 + + CALL READ_GDT_FILE_AT( JJ + ( KK - 1 - MM1 ) ) + EMS_SF_ADJ_OLD(:,:,:,:) = EMS_SF_ADJ(:,:,:,:) + CALL READ_GDT_FILE_AT( JJ + ( KK - 1 - MM1 ) + 1 ) + + CALL READ_SF_FILE_AT( JJ + ( KK - 1 - MM1 ) ) + EMS_SF_OLD(:,:,:,:) = EMS_SF(:,:,:,:) + CALL READ_SF_FILE_AT( JJ + ( KK - 1 - MM1 ) + 1 ) + + + DO II = 1, HMAX + + I = MAPI(II) + J = MAPJ(II) + M = MAPM(II) + N = MAPN(II) + + + ! s_k = f_{k+1} - f_{k} + WS(JJ,II) = EMS_SF(I,J,M,N) - EMS_SF_OLD(I,J,M,N) + + ! y_k = grad_{k+1} - grad_{k} + WY(II,JJ) = EMS_SF_ADJ(I,J,M,N) - EMS_SF_ADJ_OLD(I,J,M,N) + + ENDDO + ENDDO + + + ELSEIF ( LICS ) THEN + + DO N = 1, N_TRACERS + DO J = 1, JJPAR + DO I = 1, IIPAR + DO L = 1, LLPAR + + !============================================== + ! Apply filters + !============================================== + + ! Only in places where emissions are nonzero + !IF ( ABS(ADJ_EMS(I,J,M,N)) < 1d-4 ) CYCLE + + ! Update vector index + II = II + 1 + + ! Save mapping arrays + IIMAP(I,J,L,N) = II + MAPI(II) = I + MAPJ(II) = J + MAPN(II) = N + MAPL(II) = L + + !ENDIF + + ENDDO + ENDDO + ENDDO + ENDDO + + !================================================== + ! Start L-BFGS inverse Hessian diagonal elements extraction + !================================================== + + DK = 0d0 + + + DO JJ = 1, MM1 + + CALL READ_GDT_FILE_AT( JJ + ( KK - 1 - MM1 ) ) + ICS_SF_ADJ_OLD(:,:,:,:) = ICS_SF_ADJ(:,:,:,:) + CALL READ_GDT_FILE_AT( JJ + ( KK - 1 - MM1 ) + 1 ) + + CALL READ_SF_FILE_AT( JJ + ( KK - 1 - MM1 ) ) + ICS_SF_OLD(:,:,:,:) = ICS_SF(:,:,:,:) + CALL READ_SF_FILE_AT( JJ + ( KK - 1 - MM1 ) + 1 ) + + DO II = 1, HMAX + + I = MAPI(II) + J = MAPJ(II) + N = MAPN(II) + L = MAPL(II) + + ! s_k = f_{k+1} - f_{k} + WS(JJ,II) = ICS_SF(I,J,L,N) - ICS_SF_OLD(I,J,L,N) + + ! y_k = grad_{k+1} - grad_{k} + WY(II,JJ) = ICS_SF_ADJ(I,J,L,N) - + & ICS_SF_ADJ_OLD(I,J,L,N) + + ENDDO + ENDDO + + ENDIF + + DO JJ = 1, MM1 + DK(JJ,JJ) = DOT( WS(JJ,:), WY(:,JJ) ) + ENDDO + + + !theta = WY^T.WY/WY^T.WS + !for inverse Hessian uses 1/theta + THETA_DENO = DOT( WY(:,MM1), WY(:,MM1) ) + THETA_NUM = DOT( WY(:,MM1), WS(MM1,:) ) + THETA = THETA_NUM / THETA_DENO + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JJ , II ) + DO JJ = 1, MM1 + DO II = 1, MM1 + + IF ( II <= JJ ) THEN + RK(II,JJ) = DOT( WS(II,:), WY(:,JJ) ) + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( II ) + DO II=1, HMAX + HINVD(II) = THETA + ENDDO +!$OMP END PARALLEL DO + + ! assuming H_0=theta*I + + CALL GEMM( WY(:,1:MM1), WY(:,1:MM1), DK(1:MM1,1:MM1), + & TRANSA = 'T', ALPHA = THETA, BETA = 1d0 ) + + ! solve for R^{-1}S' -> m x n + CALL TRTRS( RK(1:MM1,1:MM1), WS(1:MM1,:), UPLO = 'U', INFO = INFO) + + IF( INFO < 0 ) THEN + WRITE(MSG,'(a,i4,a)')'the ',i, + & '-th parameter had an illegal value.' + CALL ERROR_STOP(MSG,'lbfgs_mod, get_pst_cov_diag') + ENDIF + + ! (DK+Y'H_0Y)R^{-1}S' + CALL GEMM( DK(1:MM1,1:MM1), WS(1:MM1,:), MM(1:MM1,:) ) + + ! M-Y'H_0 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JJ) + DO JJ = 1, MM1 + CALL AXPY( WY(:,JJ), MM(JJ,:), A=-THETA ) + ENDDO +!$OMP END PARALLEL DO + + !H=H_0+SR^{-T}M +! CALL gemm(WS(1:KK,:),MM(1:KK,:),HINVD,transa='T',beta=1d0) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( II ) + DO II = 1, HMAX + HINVD(II)=HINVD(II) + DOT( WS(1:MM1,II), MM(1:MM1,II) ) + ENDDO +!$OMP END PARALLEL DO + + !H=H-YH_0R^{-1}S' +! CALL gemm(WY(:,1:KK),WS(1:KK,:),HINVD,alpha=-theta,beta=1d0) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( II ) + DO II = 1, HMAX + HINVD(II)=HINVD(II) - THETA * DOT( WY(II,1:MM1), WS(1:MM1,II) ) + ENDDO +!$OMP END PARALLEL DO + + PRINT*, ' MAX HINVD = ', MAXVAL(HINVD(:)) + PRINT*, ' MIN HINVD = ', MINVAL(HINVD(:)) + + NITR = N_CALC + + PRINT*,'************************************' + PRINT*,'NOW MAKING HESSIAN DIAGONAL BINARY FILE' + PRINT*,'************************************' + + CALL MAKE_HESS_DIAG_FILE( HINVD,HMAX, NITR ) + + + IF(ALLOCATED(WS))DEALLOCATE(WS) + IF(ALLOCATED(WY))DEALLOCATE(WY) + IF(ALLOCATED(RK))DEALLOCATE(RK) + IF(ALLOCATED(DK))DEALLOCATE(DK) + IF(ALLOCATED(MM))DEALLOCATE(MM) + + + CONTAINS + + FUNCTION SAFE_DIV( A, B ) RESULT( ANS ) + IMPLICIT NONE + REAL*8, INTENT(IN) :: A, B + REAL*8 :: ANS + + ANS = A * B / ( B * B + 1d-20 ) + + RETURN + + END FUNCTION SAFE_DIV + + + END SUBROUTINE LBFGS_INV_HESSIAN +!------------------------------------------------------------------------------ + + SUBROUTINE READ_GDT_FILE_AT ( ITE ) +! +!****************************************************************************** +! Subroutine READ_GDT_FILE_AT reads the gctm.gdt file for a given iteration number +! into ADJ_xxx +! (DKh, 9/17/04) + +! +! Module Variable as Input: +! ============================================================================ +! (1 ) ITE : iteration number +! +! Notes +! (1 ) now CALLed GDT instead of ADJ +! (2 ) Added ACTIVE_VARS == 'EMISSIONS' case. (DKh, 11/27/04) +! (3 ) Added ACTIVE_VARS == 'FDTEST' case. (DKh, 02/17/05) +! (4 ) Now use CATEGORY = 'IJ-GDE-$' for EMISSIONS case. (DKh, 03/29/05) +! (5 ) No longer pass COST_FUNC in the header; use cnf.* files. (DKh, 02/13/06) +! (6 ) Now support strat fluxes LADJ_STRAT (hml, DKh, 02/20/12, adj32 _025) +! (7) Modified to read gctm.gdt files at a specific iteration number +! (nab, 03/24/12, adj32_027) ! + +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, MMSCL, N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ,LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_MOD, ONLY : LPRT + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Local Variables + INTEGER , INTENT(IN) :: ITE + INTEGER :: I, IOS, J, L, M, N + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) + REAL*4 :: PROD_3D(IIPAR,JJPAR,MMSCL) + REAL*4 :: LOSS_3D(IIPAR,JJPAR,MMSCL) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + CHARACTER(LEN=20) :: INPUT_GDT_FILE + + !================================================================= + ! READ_GDT_FILE begins here! + !================================================================= + + ! Hardwire output file for now + INPUT_GDT_FILE = 'gctm.gdt.NN' + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open gradient file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_GDT_FILE ) + + ! Replace NN tokens in FILENAME w/ actual values + CALL EXPAND_NAME( FILENAME, ITE ) + + ! Add OPTDATA_DIR prefix to FILENAME + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'G D T F I L E I N P U T' + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_GDT_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + + IF ( LICS ) THEN + !================================================================= + ! Read adjoints -- store in the TRACER array + !================================================================= + DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES , LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a REAL I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:6') + + !============================================================== + ! Assign data from the TRACER array to the ADJ_STT array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-GDT-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ICS_SF_ADJ(I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ENDIF + IF ( LADJ_EMS ) THEN + + !================================================================= + ! Read adjoints -- store in the TRACER array + !================================================================= + DO N = 1, NNEMS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a REAL I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:5') +! debug (nab) + ! PRINT*,'MMSCL: ',MMSCL +!! + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( EMS_3D(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:7') + + !============================================================== + ! Assign data from the TRACER array to the ADJ_STT array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-GDE-$' ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + EMS_SF_ADJ(I,J,M,N) = EMS_3D(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + IF ( LADJ_STRAT ) THEN + !============================================================== + ! Read adjoints -- store in the TRACER array + !============================================================== + DO N = 1, NSTPL + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES , LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a REAL I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR + & ( IOS,IU_RST,'read_gdt_file:8' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR + & ( IOS,IU_RST,'read_gdt_file:9') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( PROD_3D(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + IF ( IOS /= 0 ) CALL IOERROR + & ( IOS,IU_RST,'read_gdt_file:10') + + + !=========================================================== + ! Assign data from the TRACER array to the ADJ_STT array. + !=========================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-GDP-$' ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + PROD_SF_ADJ(I,J,M,N) = PROD_3D(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDDO + + DO N = 1, NSTPL + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES , LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a REAL I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR + & ( IOS,IU_RST,'read_gdt_file:8b') + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR + & ( IOS,IU_RST,'read_gdt_file:9b') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( LOSS_3D(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + IF ( IOS /= 0 ) CALL IOERROR + & (IOS,IU_RST,'read_gdt_file:10b') + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-GDL-$' ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + LOSS_SF_ADJ(I,J,M,N) = LOSS_3D(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDDO + ENDIF + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_GDT_FILE: read file' ) + + ! Return to CALLing program + END SUBROUTINE READ_GDT_FILE_AT + + +!!------------------------------------------------------------------------------ +! + SUBROUTINE READ_SF_FILE_AT ( ITE ) +! +!****************************************************************************** +! Subroutine READ_SF_FILE_AT reads the gctm.sf file for a given iteration number +! into ADJ_xxx +! (DKh, 9/17/04) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) ITE : iteration number +! +! Notes +! (1 ) Add support for ACTIVE_VARS == 'EMISSIONS' case (DKh, 11/27/04) +! (2 ) Add support for ACTIVE_VARS == 'FDTEST' case (DKh, 02/17/05) +! (3 ) Now use CATEGORY = 'IJ-EMS-$' for ACTIVE_VARS == 'EMISSIONS' case. +! (DKh, 03/28/05) +! (4 ) Change name from ICS to SF, replace CMN_ADJ (DKh, ks, mak, cs 06/08/09) +! (5 ) Now support strat fluxes LADJ_STRAT (hml, DKh, 02/20/12, adj32_025) +! (4) Modified to read gctm.sf files at a specific iteration number +! (nab, 03/24/12, adj32_027) ! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, ICS_SF + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_MOD, ONLY : LPRT + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! LPRT + + ! Local Variables + INTEGER, INTENT(IN) :: ITE + INTEGER :: I, IOS, J, L, M, N + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + CHARACTER(LEN=20) :: INPUT_SF_FILE + + !================================================================= + ! READ_SF_FILE begins here! + !================================================================= + + ! Hardwire output file for now + INPUT_SF_FILE = 'gctm.sf.NN' + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open SF file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_SF_FILE ) + + ! Replace NN token w/ actual value + CALL EXPAND_NAME( FILENAME, ITE ) + + ! Add OPTDATA_DIR prefix to FILENAME + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + ! can hardwire this to read a specific file from another run: + !FILENAME = TRIM( 'opt_ics/ADJv27fi04r10/gctm.ics.16' ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'S F F I L E I N P U T' + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_SF_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + IF ( LICS ) THEN + + !================================================================= + ! Read initial conditions -- store in the TRACER array + !================================================================= + DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a REAL I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:6') + + !============================================================== + ! Assign data from the TRACER array to the xxx_IC array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-ICS-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ICS_SF (I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ENDIF + + IF ( LADJ_EMS ) THEN + + !================================================================= + ! Read emission scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NNEMS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a REAL I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:6') + + !============================================================== + ! Assign data from the TRACER array to the xxx_IC array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-EMS-$' ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + EMS_SF(I,J,M,N) = TRACER(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + !================================================================= + ! Read strat prod & loss scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NSTPL + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a REAL I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:6') + + !============================================================== + ! Assign data from the TRACER array to the xxx_STR array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + + IF ( CATEGORY(1:8) == 'IJ-STRP$' ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + PROD_SF(I,J,M,N) = TRACER(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDDO + + !================================================================= + ! Read strat prod & loss scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NSTPL + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a REAL I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:6') + + IF ( CATEGORY(1:8) == 'IJ-STRL$' ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + LOSS_SF(I,J,M,N) = TRACER(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDDO + ENDIF + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_SF_FILE: read file' ) + + ! Return to CALLing program + END SUBROUTINE READ_SF_FILE_AT +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_HESS_DIAG_FILE ( HINV,HMAX,NITR ) +! +!****************************************************************************** +! Subroutine MAKE_HESS_DIAG_FILE creates a binary file of selected elements +! of the approximate inverse hessian. (DKh, 05/15/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) HINV : Current estimate of diagonal of inverse hessian +! (2 ) HMAX : Dimension +! (3 ) NITR : Current iteration +! +! Module Variable as Input: +! ============================================================================ +! (1 ) IIMAP : 3D to 1D mappying array +! +! NOTES: +! (1 ) Just like MAKE_GDT_FILE except +! - pass NITR as an argument +! (2 ) Updated for adj32 (DKh, 01/11/12) +! (3 ) Updated for adj32_027 as HINV has now dimension (HMAX) (nab, 25/03/12) +! (4 ) Updated to include calculation of the DFS +! and to filter out model pixels with no emissions (nab, 8/17/2012) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE TRACER_MOD , ONLY : N_TRACERS + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : EMS_ERROR, ICS_ERROR + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST,IU_FILE,IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LICS,LADJ_STRAT + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE LOGICAL_ADJ_MOD, ONLY : LICS, L4DVAR, LADJ_EMS + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ,ICS_SF_ADJ + +# include "CMN_SIZE" ! Size parameters + + + ! Arguments + INTEGER :: HMAX + REAL*8 :: HINV(HMAX) + INTEGER :: NITR + REAL*8 :: DFS, S2_INV,INFL + + ! Local Variables + INTEGER :: I, I0, IOS, J + INTEGER :: J0, L, M, N, II, JJ + INTEGER :: YYYY, MM, DD, HH, SS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) + REAL*4 :: ICS_3D(IIPAR,JJPAR,LLPAR) + + CHARACTER(LEN=255) :: FILENAME1,FILENAME2 + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: OUTPUT_GDT_FILE1,OUTPUT_GDT_FILE2 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_HESS_FILE begins here! + !================================================================= + + ! Clear intermediate arrays + EMS_3D(:,:,:) = 0d0 + ICS_3D(:,:,:) = 0d0 + + ! Hardwire output file for now + OUTPUT_GDT_FILE1 = 'gctm.posterror.NN' + OUTPUT_GDT_FILE2 = 'gctm.diagmrm.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM Adjoint File: ' // + & 'Inverse hessian ' + UNIT = 'none' + CATEGORY = 'IJ-GDE-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! CALL GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME1 = TRIM( OUTPUT_GDT_FILE1 ) + FILENAME2 = TRIM( OUTPUT_GDT_FILE2 ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME1, NITR ) + CALL EXPAND_NAME( FILENAME2, NITR ) + + ! Add the OPT_DATA_DIR prefix to the file name + FILENAME1 = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME1 ) + FILENAME2 = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME2 ) + + WRITE( 6, 100 ) TRIM( FILENAME1 ) + WRITE( 6, 100 ) TRIM( FILENAME2 ) + 100 FORMAT( ' - MAKE_HESS_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME1, TITLE ) + CALL OPEN_BPCH2_FOR_WRITE( IU_FILE, FILENAME2, TITLE ) + + + DFS = 0d0 + + IF ( LADJ_STRAT ) THEN + CALL ERROR_STOP( 'inverse hessian not supported ', + & ' MAKE_HESS_FILE, inverse_mod.f') + ELSEIF ( LICS ) THEN + + DO N = 1, N_TRACERS + ICS_3D(:,:,:) = 0d0 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J,L, II ) + DO J = 1, JJPAR + DO I = 1, IIPAR + DO L = 1 , LLPAR + + II = IIMAP(I,J,L,N) + IF ( II == 0 ) CYCLE +#if defined ( LOG_OPT ) + + S2_INV = 1d0 / (2 * LOG( ICS_ERROR(MAPN(II)) ) ) +#else + + S2_INV = 1d0 / (ICS_ERROR(MAPN(II)) )**2 +#endif + + IF ( ABS( ICS_SF_ADJ(I,J,L,N) + & /MAXVAL(ICS_SF_ADJ(:,:,L,N)) ) < 0.01 ) THEN + HINV(II) = 1/S2_INV + ENDIF + + IF ( HINV(II) > 0 ) THEN + ICS_3D(I,J,L) = REAL(SQRT(HINV(II))) + DFS = DFS + HINV(II)*S2_INV + ELSE + print*, I, J, M, N, II + print*,'non positive hess diagonal:' + print*,HINV(II) + CALL ERROR_STOP('non positive hessian diagonal ', + & 'inverse_mod.f') + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, ICS_3D ) + + + ENDDO + + ELSEIF ( LADJ_EMS ) THEN + + !================================================================= + ! WRITE the standard error of each optimized scaling factor + !================================================================= + DO N = 1, NNEMS + + !Temporarily store quantities in the TRACER array + EMS_3D(:,:,:) = 0d0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, II,S2_INV ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + II = IIMAP(I,J,M,N) + IF ( II == 0 ) CYCLE +#if defined ( LOG_OPT ) + + S2_INV = 1d0 / (2 * LOG( EMS_ERROR(MAPN(II)) ) ) +#else + + S2_INV = 1d0 / ( EMS_ERROR(MAPN(II)) )**2 +#endif + + IF ( ABS( EMS_SF_ADJ(I,J,M,N) + & /MAXVAL(EMS_SF_ADJ(:,:,M,N)) ) < 0.01 ) THEN + HINV(II) = 1/S2_INV + ENDIF + + IF ( HINV(II) > 0 ) THEN + EMS_3D(I,J,M) = REAL(SQRT(HINV(II))) + DFS = DFS + HINV(II)*S2_INV + ELSE + print*, I, J, M, N, II + print*,'non positive hess diagonal:' + print*,HINV(II) + CALL ERROR_STOP('non positive hessian diagonal ', + & 'inverse_mod.f') + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, EMS_3D ) + + ENDDO + +! ! Reset CATEGORY as labeling in gamap is dIFferent +! CATEGORY = 'IJ-COREL' +! +! !================================================================= +! ! WRITE correlation of optimized scale factors with a particular + ! target cell, selected manually below. +! !================================================================= +! DO N = 1, NNEMS +! +! ! target cell +! JJ = IIMAP(13,33,1,IDADJEMS_ENH3_an) +! +! !Temporarily store quantities in the TRACER array +! EMS_3D(I,J,M) = 0d0 +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M, II ) +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! +! II = IIMAP(I,J,M,N) +! !IF ( II == 0 ) CYCLE +! IF ( II == 0 ) THEN +! EMS_3D(I,J,M) = 0d0 +! ELSE +! EMS_3D(I,J,M) = REAL(HINV(II,JJ)/(SQRT(HINV(II,II)) +! & * SQRT(HINV(JJ,JJ)))) +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ENDDO + ELSE + CALL ERROR_STOP( 'simulation type not defined!', + & 'MAKE_HESS_FILE' ) + ENDIF + ! Close file + CLOSE( IU_RST ) + CLOSE( IU_FILE ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_HESS_FILE: wrote file' ) + + DFS = HMAX - DFS + INFL = DFS/HMAX + + PRINT*,'' + PRINT*,'==============================================' + PRINT*,'Degree of Freedom for Signal (DFS): ',DFS + PRINT*,'Dimension (N): ',HMAX + PRINT*,'Global average influence: DFS/N = ',INFL + PRINT*,'==============================================' + + + ! Return to CALLing program + END SUBROUTINE MAKE_HESS_DIAG_FILE + +!----------------------------------------------------------------------------- + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_INV_HESSIAN(HMAX) +! +!****************************************************************************** +! Subroutine INIT_INV_HESSIAN initializes and zeros all ALLOCATABLE arrays +! +! NOTES: +!****************************************************************************** + + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NNEMS,MMSCL + USE TRACER_MOD , ONLY : N_TRACERS + USE ERROR_MOD, ONLY : ALLOC_ERR + USE LOGICAL_ADJ_MOD, ONLY : LICS,LADJ_EMS + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: AS, I, HMAX + + !================================================================= + ! INIT_INV_HESSIAN begins here! + !================================================================= + + IF ( LADJ_EMS) THEN + ALLOCATE( IIMAP(IIPAR,JJPAR,MMSCL,NNEMS), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'IIMAP' ) + IIMAP = 0 + ENDIF + + IF ( LICS ) THEN + ALLOCATE( IIMAP(IIPAR,JJPAR,LLPAR,N_TRACERS), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'IIMAP' ) + IIMAP = 0 + ENDIF + + ALLOCATE (MAPI(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAPI' ) + MAPI = 0 + + + ALLOCATE (MAPJ(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAPJ' ) + MAPJ = 0 + + ALLOCATE (MAPM(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAPM' ) + MAPM = 0 + + ALLOCATE (MAPN(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAPN' ) + MAPN = 0 + + ALLOCATE (MAPL(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAPL' ) + MAPL = 0 + + ALLOCATE (HINVD(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'HINVD' ) + HINVD = 0d0 + + ALLOCATE( EMS_SF_OLD(IIPAR,JJPAR,MMSCL,NNEMS), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF_OLD' ) + EMS_SF_OLD = 0d0 + + ALLOCATE( EMS_SF_ADJ_OLD(IIPAR,JJPAR,MMSCL,NNEMS), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF_ADJ_OLD' ) + EMS_SF_ADJ_OLD = 0d0 + + ALLOCATE( ICS_SF_OLD(IIPAR,JJPAR,LLPAR,N_TRACERS), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_SF_OLD' ) + ICS_SF_OLD = 0d0 + + ALLOCATE( ICS_SF_ADJ_OLD(IIPAR,JJPAR,LLPAR,N_TRACERS), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ICS_SF_ADJ_OLD' ) + ICS_SF_ADJ_OLD = 0d0 + + + + END SUBROUTINE INIT_INV_HESSIAN + +!------------------------------------------------------------------------------ + + ! Return to CALLing program + SUBROUTINE CLEANUP_INV_HESSIAN +! +!****************************************************************************** +! Subroutine CLEANUP_INV_HESSIAN deALLOCATEs all previously ALLOCATEd arrays +! for inverse_mod -- CALL at the end of the program (DKh, 01/11/12) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_INV_HESSIAN begins here! + !================================================================= + IF ( ALLOCATED( IIMAP ) ) DEALLOCATE( IIMAP ) + IF ( ALLOCATED( ICS_SF_OLD ) ) DEALLOCATE( ICS_SF_OLD ) + IF ( ALLOCATED( ICS_SF_ADJ_OLD ) ) DEALLOCATE( ICS_SF_ADJ_OLD ) + IF ( ALLOCATED( EMS_SF_OLD ) ) DEALLOCATE( EMS_SF_OLD ) + IF ( ALLOCATED( EMS_SF_ADJ_OLD ) ) DEALLOCATE( EMS_SF_ADJ_OLD ) + IF ( ALLOCATED( MAPI ) ) DEALLOCATE( MAPI ) + IF ( ALLOCATED( MAPJ ) ) DEALLOCATE( MAPJ ) + IF ( ALLOCATED( MAPM ) ) DEALLOCATE( MAPM ) + IF ( ALLOCATED( MAPL ) ) DEALLOCATE( MAPL ) + IF ( ALLOCATED( MAPN ) ) DEALLOCATE( MAPN ) + IF ( ALLOCATED( HINVD ) ) DEALLOCATE( HINVD ) + + + ! Return to CALLing program + END SUBROUTINE CLEANUP_INV_HESSIAN + +!------------------------------------------------------------------------------ + + + END MODULE INV_HESSIAN_LBFGS_MOD diff --git a/code/adjoint/inv_hessian_mod.f b/code/adjoint/inv_hessian_mod.f new file mode 100644 index 0000000..4f6eb03 --- /dev/null +++ b/code/adjoint/inv_hessian_mod.f @@ -0,0 +1,799 @@ + MODULE INV_HESSIAN_MOD +! +!***************************************************************************** +! Module INV_HESSIAN_MOD contains all the subroutines that are used for +! calculating the approximate inverse Hessian. (dkh, 05/15/07, adj32_012) +! +! Module Variables: +! ============================================================================ +! (1 ) IIMAP (INTEGER) : 4D to 1D mapping array +! (2 ) EMS_SF_OLD (REAL*8) : Scaling factors at previous iteration +! (2 ) EMS_SF_ADJ_OLD (REAL*8) : Gradients at previous iteration +! +! Module Routines +! ============================================================================ +! (1 ) UPDATE_HESSIAN : Updates inv Hessian estimate +! (2 ) MAKE_HESS_FILE : Saves inv Hessian to file +! (3 ) INIT_INV_HESSIAN : Allocates and intializes module variables +! (3 ) CLEANUP_INV_HESSIAN : Deallocates module variables +! +! NOTES: +! (1 ) Now make the working arrays allocatable (nb, dkh, 08/02/12, adj33g) +!***************************************************************************** +! + IMPLICIT NONE + +# include "define_adj.h" ! obs operators + + !==================================================================== + ! MODULE VARIABLES ( those that used to be program variables ) + !==================================================================== + INTEGER, ALLOCATABLE :: IIMAP(:,:,:,:) + REAL*8, ALLOCATABLE :: EMS_SF_OLD(:,:,:,:) + REAL*8, ALLOCATABLE :: EMS_SF_ADJ_OLD(:,:,:,:) + INTEGER, ALLOCATABLE :: MAPI(:), MAPJ(:) + INTEGER, ALLOCATABLE :: MAPM(:), MAPN(:) + REAL*8, ALLOCATABLE :: HINV(:,:) + REAL*8, ALLOCATABLE :: Y(:) + REAL*8, ALLOCATABLE :: S(:) + REAL*8, ALLOCATABLE :: SST(:,:) + REAL*8, ALLOCATABLE :: HINVY(:) + REAL*8, ALLOCATABLE :: YTHINV(:) + REAL*8, ALLOCATABLE :: HINVYYTHINV(:,:) + REAL*8, ALLOCATABLE :: FILTER(:,:) + + !==================================================================== + ! MODULE ROUTINES + !==================================================================== + + CONTAINS + +!----------------------------------------------------------------------------- + + SUBROUTINE UPDATE_HESSIAN( ) +! +!****************************************************************************** +! Subroutine UPDATE_HESSIAN constructs an approximation of the inverse +! Hessian using the DFP formula (see Muller and Stavrakou, 2005, eqn 18). +! (dkh, 05/15/07) +! +! This routine is set up to be used offline so that the Hessian is +! only approximated after the results from a completed optimization have +! been obtained. + +! To implement, first do a normal optimization with LINVH = .FALSE., and +! keep the cost function, scaling factor and gradient files in OptData. +! +! Next, set the LINVH flag in input.gcadj to TRUE and rerun from X=1 to +! XSTOP=z, where z is the final number of optimization steps previously +! completed. Now execute the run script. The outputs are in diagadj +! directory. +! +! The routine will label the output files according to function evaluation +! number (X), although it will only includ the accepted iterations in the +! calculation, not the line search evaluations. +! +! The initial estimate of HINV can be identiy matrix or an initial +! estimate of uncertainty. At the moment it is hardwired into the +! intial definition of HINV in the code below. +! +! WARNING: It is easy to max the dimension of the inverse Hessian so large +! that your code will crash. It may not even compile (error like +! "relocation truncated to fit: R_X86_64_32S against..."). +! +! For example, the inverse Hessian will require y Mb of memory, where +! y = 3 * HMAX ^ 2 * 8 / 10^6 +! HMAX = IPAR * JJPAR * MMSCL * NNEMS +! +! The 8 comes from 8 bits/byte (could be half this if used REAL*4), and the 3 +! comes from the fact that we have 3 arrays that are size(HMAX,HMAX). Thus, +! at 4x5 resolution with 33 emissions sectors (NNEMS) and 1 time group (MMSCL), +! the memory requirements in double precision are nearly 300 Gb! Or > 4 Gb for +! NNEMS = 1 at 2x2.5. +! +! Thus, if it takes too long, or too much memory, to consider all possible correlations, +! one can apply a filter when developing the mapping array, and then set HMAX +! to an appropriate value (a dry run may be necessary to see what value HMAX +! should be). But this is cheating with bad math, so you feel ashamed. +! +! If you need to compile with arrays that are larger than the available memory, +! utlizile swap space instead (warning: could get slow) with the -mcmodel compile +! flag (ifort). +! +! Module Variable as Input: +! ============================================================================ +! (1 ) EMS_SF : Emissions scaling factors at the current iteration +! (2 ) EMS_SF_ADJ : Emissions gradients at the current iteration +! (3 ) N_CALC : Current interation number +! +! NOTES: +! (1 ) Updated for adj32 (dkh, 01/11/12). +! (2 ) Now initialize inv Hess to y^T s / y^T y (nb, dkh, 08/02/12, adj33g) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" + + ! Local variables + ! Here I've hardwired this to IIPAR * JJPAR, as we filter for just NNEMS = 1 + ! below, and MMSCL = 1. + !INTEGER, PARAMETER :: HMAX = 72 * 46 + + !Now HMAX is a variable (nab, 7/16/12) + !HMAX = IIPAR * JJPAR * MMSCL * NNEMS + + INTEGER :: HMAX + + + INTEGER :: I, J, M, N, II, JJ, NITR + + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL, SAVE :: SECOND = .TRUE. + + + REAL*8 :: YTS_INV, YTHINVY,YTS,YTY + REAL*8 :: YTHINVY_INV + + + !================================================================= + ! UPDATE_HESSIAN begins here! + !================================================================= + + HMAX = IIPAR * JJPAR * MMSCL * NNEMS + + + PRINT*, ' UPDATE HESSIAN AT ITERATE ', N_CALC + + IF ( FIRST ) THEN + + ! allocate and initialize arrays + CALL INIT_INV_HESSIAN( HMAX ) + + print*, ' FILTER sum = ', sum(FILTER) + + ! Initialize HINV to the identity matrix (or initial unc. est) + HINV(:,:) = 0d0 + + DO JJ = 1, HMAX + DO II = 1, HMAX + + ! for example, 30% uncertainty + IF ( II == JJ ) HINV(II,II) = 1d0 + + ENDDO + ENDDO + + II = 0 + + DO N = 1, NNEMS + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + !============================================== + ! Apply filters + !============================================== + + ! Only in places where emissions are nonzero + !IF ( ABS(ADJ_EMS(I,J,M,N)) < 1d-4 ) CYCLE + !IF ( ABS(EMS_SF_ADJ(I,J,M,N)) < 1d-5 ) CYCLE + !IF ( FILTER(I,J) < 0.99 ) CYCLE + + ! Only correlation of the first emissions sector with itself + !IF ( N /= 1 ) CYCLE + + ! Update vector index + II = II + 1 + + ! Save mapping arrays + IIMAP(I,J,M,N) = II + MAPI(II) = I + MAPJ(II) = J + MAPM(II) = M + MAPN(II) = N + + !ENDIF + + ENDDO + ENDDO + ENDDO + ENDDO + + + EMS_SF_OLD(:,:,:,:) = EMS_SF(:,:,:,:) + EMS_SF_ADJ_OLD(:,:,:,:) = EMS_SF_ADJ(:,:,:,:) + + print*, ' UPDATE HESSIAN, pts founds = ', II + + CALL MAKE_HESS_FILE( HINV, HMAX, 1 ) + + FIRST = .FALSE. + + RETURN + ENDIF + + + DO II = 1, HMAX + + I = MAPI(II) + J = MAPJ(II) + M = MAPM(II) + N = MAPN(II) + + ! find s_k = f_{k+1} - f_{k} + S(II) = EMS_SF(I,J,M,N) - EMS_SF_OLD(I,J,M,N) + + ! find y_k = grad_{k+1} - grad_{k} + Y(II) = EMS_SF_ADJ(I,J,M,N) - EMS_SF_ADJ_OLD(I,J,M,N) + + ENDDO + + print*, ' UPDATE HESSIAN, pts founds = ', II + + ! Rotate + EMS_SF_OLD(:,:,:,:) = EMS_SF(:,:,:,:) + EMS_SF_ADJ_OLD(:,:,:,:) = EMS_SF_ADJ(:,:,:,:) + + !---------------------------------------------------------- + ! Update inverse Hessian + !---------------------------------------------------------- + + ! y^T*s + YTS = 0d0 + DO II = 1, HMAX + + YTS = YTS + Y(II) * S(II) + + ENDDO + + print*, ' YTS = ', YTS , N_CALC + + ! Initialize inv Hessian to y^T s / y^T y + IF ( SECOND ) THEN + + print*, ' Initialize inv Hessian to y^T s / y^T y = ',YTS/YTY + + ! y^T * y + YTY = 0d0 + DO II = 1, HMAX + YTY = YTY + Y(II) * Y(II) + ENDDO + + IF ( YTY < 1D-38 ) THEN + CALL ERROR_STOP('underflow','inv_hessian') + ENDIF + + DO II = 1, HMAX + HINV(II,II) = YTS / YTY + ENDDO + + SECOND = .FALSE. + + ENDIF + + ! s * s^T / YTS + DO II = 1, HMAX + DO JJ = 1, HMAX + + SST(II,JJ) = S(II) * S(JJ) + + ENDDO + ENDDO + + ! HINV * y + DO II = 1, HMAX + + HINVY(II) = 0D0 + + DO JJ = 1, HMAX + + HINVY(II) = HINVY(II) + HINV(II,JJ) * Y(JJ) + + ENDDO + ENDDO + + ! y^T * HINV + DO JJ = 1, HMAX + + YTHINV(JJ) = 0d0 + + DO II = 1, HMAX + + YTHINV(JJ) = YTHINV(JJ) + Y(II) * HINV(II,JJ) + + ENDDO + ENDDO + + + ! HINVY * YTHINV + DO JJ = 1, HMAX + DO II = 1, HMAX + + HINVYYTHINV(II,JJ) = HINVY(II) * YTHINV(JJ) + + ENDDO + ENDDO + + + ! YT * HINVY + YTHINVY = 0d0 + DO II = 1, HMAX + YTHINVY = YTHINVY + Y(II) * HINVY(II) + ENDDO + print*, 'YTHINVY = ', YTHINVY + + ! HINV = HINV + SST * (1/YTS) - HINVYYTHINV * (1/YTHINVY) + YTS_INV = 1 / YTS + YTHINVY_INV = 1 / YTHINVY + DO JJ = 1, HMAX + DO II = 1, HMAX + + HINV(II,JJ) = HINV(II,JJ) + & + SST(II,JJ) * YTS_INV + & - HINVYYTHINV(II,JJ) * YTHINVY_INV + + ENDDO + ENDDO + + print*, ' MAX HINV = ', MAXVAL(HINV(:,:)) + print*, ' MIN HINV = ', MINVAL(HINV(:,:)) + + NITR = N_CALC + + CALL MAKE_HESS_FILE( HINV, HMAX, NITR ) + + ! Return to calling program + END SUBROUTINE UPDATE_HESSIAN +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_HESS_FILE( HINV, HMAX, NITR ) +! +!****************************************************************************** +! Subroutine MAKE_HESS_FILE creates a binary file of selected elements +! of the approximate inverse hessian. (dkh, 05/15/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) HINV : Current estimate of inverse hessian +! (2 ) HMAX : Dimension +! (3 ) NITR : Current iteration +! +! Module Variable as Input: +! ============================================================================ +! (1 ) IIMAP : 3D to 1D mappying array +! +! NOTES: +! (1 ) Just like MAKE_GDT_FILE except +! - pass NITR as an argument +! (2 ) Updated for adj32 (dkh, 01/11/12) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LICS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + +# include "CMN_SIZE" ! Size parameters + + + ! Arguments + INTEGER :: HMAX + REAL*8 :: HINV(HMAX,HMAX) + INTEGER :: NITR + + ! Local Variables + INTEGER :: I, I0, IOS, J + INTEGER :: J0, L, M, N, II, JJ + INTEGER :: YYYY, MM, DD, HH, SS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: OUTPUT_GDT_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_HESS_FILE begins here! + !================================================================= + + ! Clear intermediate arrays + EMS_3D(:,:,:) = 0d0 + + ! Hardwire output file for now + OUTPUT_GDT_FILE = 'gctm.invhess.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM Adjoint File: ' // + & 'Inverse hessian ' + UNIT = 'none' + CATEGORY = 'IJ-GDE-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_GDT_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, NITR ) + + ! Add the OPT_DATA_DIR prefix to the file name + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_HESS_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + IF ( LICS ) THEN + + CALL ERROR_STOP( 'inverse hessian not supported ', + & ' MAKE_HESS_FILE, inverse_mod.f') + + ELSEIF ( LADJ_EMS ) THEN + + !================================================================= + ! Write the standard error of each optimized scaling factor + !================================================================= + DO N = 1, NNEMS + + !Temporarily store quantities in the TRACER array + EMS_3D(:,:,:) = 0d0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, II ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + + II = IIMAP(I,J,M,N) + IF ( II == 0 ) CYCLE + + IF ( HINV(II,II) > 0 ) THEN + EMS_3D(I,J,M) = REAL(SQRT(HINV(II,II))) + ELSE + print*, I, J, M, N, II + CALL ERROR_STOP('non positive hessian diagonal ', + & 'inverse_mod.f') + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, EMS_3D ) + + ENDDO + +! ! Reset CATEGORY as labeling in gamap is different +! CATEGORY = 'IJ-COREL' +! +! !================================================================= +! ! Write correlation of optimized scale factors with a particular + ! target cell, selected manually below. +! !================================================================= +! DO N = 1, NNEMS +! +! ! target cell +! JJ = IIMAP(13,33,1,IDADJEMS_ENH3_an) +! +! !Temporarily store quantities in the TRACER array +! EMS_3D(I,J,M) = 0d0 +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M, II ) +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! +! II = IIMAP(I,J,M,N) +! !IF ( II == 0 ) CYCLE +! IF ( II == 0 ) THEN +! EMS_3D(I,J,M) = 0d0 +! ELSE +! EMS_3D(I,J,M) = REAL(HINV(II,JJ)/(SQRT(HINV(II,II)) +! & * SQRT(HINV(JJ,JJ)))) +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ENDDO + ELSE + CALL ERROR_STOP( 'simulation type not defined!', + & 'MAKE_HESS_FILE' ) + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_HESS_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_HESS_FILE + +!----------------------------------------------------------------------------- + + SUBROUTINE INIT_INV_HESSIAN(HMAX) +! +!****************************************************************************** +! Subroutine INIT_INV_HESSIAN initializes and zeros all allocatable arrays +! +! NOTES: +!****************************************************************************** + + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, MMSCL + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: AS, I,HMAX + + !================================================================= + ! INIT_INV_HESSIAN begins here! + !================================================================= + + ALLOCATE( IIMAP(IIPAR,JJPAR,MMSCL,NNEMS), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'IIMAP' ) + IIMAP = 0 + + ALLOCATE( EMS_SF_OLD(IIPAR,JJPAR,MMSCL,NNEMS), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF_OLD' ) + EMS_SF_OLD = 0d0 + + ALLOCATE( EMS_SF_ADJ_OLD(IIPAR,JJPAR,MMSCL,NNEMS), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMS_SF_ADJ_OLD' ) + EMS_SF_ADJ_OLD = 0d0 + + ALLOCATE (MAPI(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAPI' ) + MAPI = 0 + + ALLOCATE (MAPJ(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAPJ' ) + MAPJ = 0 + + ALLOCATE (MAPM(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAPM' ) + MAPM = 0 + + ALLOCATE (MAPN(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAPN' ) + MAPN = 0 + + ALLOCATE (HINV(HMAX,HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'HINV' ) + HINV = 0 + + ALLOCATE (HINVYYTHINV(HMAX,HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'HINVYYTHINV' ) + HINVYYTHINV = 0 + + ALLOCATE (S(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'S' ) + S = 0 + + ALLOCATE (Y(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'Y' ) + Y = 0 + + ALLOCATE (SST(HMAX,HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SST' ) + SST = 0 + + ALLOCATE (HINVY(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'HINVY' ) + HINVY = 0 + + ALLOCATE (YTHINV(HMAX), STAT = AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'YTHINV' ) + YTHINV = 0 + + ALLOCATE( FILTER(IIPAR,JJPAR), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'FILTER' ) + FILTER = 0d0 + + !CALL READ_FILTER() + + END SUBROUTINE INIT_INV_HESSIAN + +!------------------------------------------------------------------------------ + + ! Return to calling program + SUBROUTINE CLEANUP_INV_HESSIAN +! +!****************************************************************************** +! Subroutine CLEANUP_INV_HESSIAN deallocates all previously allocated arrays +! for inverse_mod -- call at the end of the program (dkh, 01/11/12) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_INV_HESSIAN begins here! + !================================================================= + IF ( ALLOCATED( IIMAP ) ) DEALLOCATE( IIMAP ) + IF ( ALLOCATED( EMS_SF_OLD ) ) DEALLOCATE( EMS_SF_OLD ) + IF ( ALLOCATED( EMS_SF_ADJ_OLD ) ) DEALLOCATE( EMS_SF_ADJ_OLD ) + + ! Return to calling program + END SUBROUTINE CLEANUP_INV_HESSIAN + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + + SUBROUTINE READ_FILTER( ) +! +!****************************************************************************** +! + ! References to F90 modules + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS + USE ADJ_ARRAYS_MOD, ONLY : NNEMS + +# include "CMN_SIZE" ! Size parameters + + ! Local Variables + INTEGER :: I, IOS, J, L, N + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,1) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: UNZIP_FILE_CMD + CHARACTER(LEN=255) :: ZIP_FILE_CMD + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_OBS_FILE begins here! + !================================================================= + + ! Hardwire output file for now + FILENAME = TRIM('gctm.filter.3293') + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open observation file and read top-of-file header + !================================================================= + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'F I L T E R F I L E I N P U T' + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_FILTER: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read concentrations -- store in the TRACER array + !================================================================= + !DO N = 1, NOBS + DO N = 1, NNEMS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_obs_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_obs_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_obs_file:6') + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( N == 3 ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + FILTER(I,J) = TRACER(I,J,1) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_FILTER: read file' ) + + ! Return to calling program + END SUBROUTINE READ_FILTER +!------------------------------------------ + END MODULE INV_HESSIAN_MOD + + diff --git a/code/adjoint/inverse_driver.f b/code/adjoint/inverse_driver.f new file mode 100644 index 0000000..42bb740 --- /dev/null +++ b/code/adjoint/inverse_driver.f @@ -0,0 +1,1389 @@ +!$Id: inverse_driver.f,v 1.33 2012/08/10 22:08:22 nicolas Exp $ +!$Log: inverse_driver.f,v $ +!Revision 1.33 2012/08/10 22:08:22 nicolas +!Update v33g: - Implementation of the L-BFGS inverse Hessian calculation +! - New cost function formulation for pseudo-obs optimization test +! (nab, 8/10/2012) +! +!Revision 1.32 2012/03/01 22:00:26 daven +!Submit beta_v32_026 for testing (dkh, 03/01/12) +! +!Revision 1.31 2011/02/23 00:08:47 daven +!UPDATES in forward model: +! - add diag59 (lz, 11/18/10) +! - GCv8-02-04: add EPA/NEI05. +! - completely update scale_anthro_mod.f to GCv9-01-01 +! - completely update epa_nei_mod.f to GCv9-01-01 +! - add nei2005_anthro_mod.f to GCv9-01-01 +! - completely update error_mod.f to GCv9-01-01 +! +!BUG FIXES in forward model: +! - GCv8-02-03: Corrected_Bond_et_al_BC.2FOC_emissions +! - GCv8-02-04: Bug_fix_in_emfossil.f_for_0.5_x_0.666_nested_grid_tagged-CO_option +! - GCv8-03-02: Fix_for_EPA.2FNEI_2005_emissions +! - GCv8-03-02: Minor_fixes_in_gamap_mod.f +! - GCv9-01-01: Bug_fix_for_biofuels_in_EPA.2FNEI05 +! - GCv?-??-??: Add scaling of aromatic emissions over the US. (hotp, 11/23/09) +! - GCv9-01-01: Important_bug_fixes_for_ship_emissions +! - GCv9-01-01: Fix_to_prevent_div-by-zero_in_sulfate_mod.f +! - GCv9-01-02: Double_counting_of_biofuel_emissions_over_Asia +! - GCv9-01-02: fix SET_TINDEX for ND17, 18, 38, 39 so that all wet diagnostics get written out (dkh, 02/16/11) +! +!UPDATES in adjoint model: +! - add LITR for iteration diagnostics (zhe, dkh, 02/04/11) +! - Make sure ITS_A_NEW_MONTH is true only once per month during adjoint, +! which minimized i/o. (dbm, 02/10/11) +! - now make run script copy the executable rather than move it, thus +! avoiding exessive recompilation (dbm, 02/10/11) +! - update MOPITT obs operators to support v3 and v4 (zhe, 02/04/11) +! - now add support for nested grid with offline CO (zhe, 02/04/11) +! - now emit biomass burning emissions for offline CO throughout +! the boundary layer (dbm, 02/10/11) +! - updated input.gcadj (dkh, 02/10/11) +! - better distinction between tracers and species +! - better distinction between observations and control parameters +! - additional input flags and parameters to replace hard wired options +! - ICS_SF_DEFAULT, EMS_SF_DEFAULT, EMS_ERROR, ICS_ERROR +! - LTRAJ_SCALE, LITR, NSPAN, LMAX_OBS, LEMS_ABS +! - replace OPT_THIS_SPECIES with OPT_THIS_TRACER (dkh, 02/10/11) +! - allow for flux filling during adjoint advection LFILL_ADJ (jkoo, dkh, 02/11/11) +! - add TES_BLVRM flag for tes NH3 observation (dkh, 02/14/11) +! - in lidort_mod (dkh, 01/27/11) +! - use dry diameter of BC to estimate number concentration +! - add BC mass absorption enhancement factor ABS_FAC +! - use growth curve for sulfate wet size rather than H2O from rpmares +! - implent LEMS_ABS option to output sensitivities w.r.t emissions +! rather than emissions scaling factors (dkh, 02/17/11) +! - enforce LMAX_OBS = T and NSPAN = 1 for FD_GLOB (dkh, 02/21/11) +! +!BUG FIXES in adjoint model: +! - Missing a factor of 1d6 for the cspec_ppb case in CALC_ADJ_FORCE_FOR_SENSE (fgap, dkh, 02/03/11) +! - LVARTROP treated correctly (dkh, 01/26/11) +! - For LUNZIP = T, don't delete met files during forward run (zj, dkh, 07/30/10) +! - Convert units before and after transport to account for discrete <--> continuous +! adjoint (jkoo, dkh, 02/14/11) +! - Set the min value of CSPEC checkpt arrays to be SMAL2 (dkh, 02/19/11) +! - update sulfate_adj_mod to account for Fix_to_prevent_div-by-zero_in_sulfate_mod.f (dkh, 02/19/11) +! - fix the FD_SPOT test (dkh, 02/21/11) +! - now only make fdglob files if FD_GLOB, not if FD_SPOT +! - now evaluate the adjoint on 1st and 2nd iterations, and halt model if users +! asks for a third iteration in MAYBE_DO_GEOS_CHEM_ADJ +! - Force DAYS to be at least 1 to allow for simulations less than 1 day. (dkh, 02/22/11) +! +!Revision 1.30 2010/11/19 07:05:24 daven +!BUG FIXES: +! - fix use of ICSFD and EMSFD in SET_SF and SET_LOG_SF (lz, dkh) +! - add 0.001 to diag of S_OER in tes_o3_mod before inverting (ks,mm,dkh) +! - fix bug with concnox in partition_adj.f (jkoo) +! - implement SDFLAG flag in inverse_mod.f (zhe) +!UPDATES: +! - update run script to run on prospero by default (dkh) +! - no backup +! - append iteration to ctm.bpch +! - use echo instead of ex. * +! - make sure that if LADJ = F, FD_GLOB = F (dkh) +! - update tes_nh3_mod.f (dkh) +! - update CALC_APRIORI to include option for TES_NH3_OBS (dkh) +! - update comments in adj_arrays about units of EMS_SF_ADJ and ICS_SF_ADJ (ajt) +! - add GOSAT co2 obs operator. gosat_co2_mod.f, Makefile.ifort.netcdf, adj_arrays_mod.f, +! geos_chem_adj_mod.f, input_adj_mod.f, define_adj.h (dkh) +! +!Revision 1.29 2010/07/30 23:47:04 daven +!Patch several bugs: +! - BUG FIX: update co2 fwd model, see Ray's email 5/18 +! - BUG FIX: enforce defualt scaling factors before using SF_tmp +! - BUF FIX: declare QTMP and FTMP thread private in fvdas_convect_adj_mod.f +! - BUG FIX: if an obs operator is defined, don't crash with No observations! +! - BUG FIX: use CHK_STT in MAKE_ADJ_FILE for scale factor instead of STT +! - BUF FIX: now declare BL_FRAC thread private in subroutine CHEM_OCPI_ADJ +! - BUF FIXES from Zhe Jiang, see email 5/17 +! - tagged_co_adj-mod.f (STT(I,J,L,1)) +! - define_adj.h (MOPITT_IR_CO_OBS) +! - mopitt_obs_mod.f (MOP_COL_GRID) +! - don't deleted unzipped met fields (geos_chem_mod) +! - reset EMS_SF_ADJ each iteration to prevent buildup +!Cleanup and enhancements +! - don't need to call MAKE_PRESSURE_CHKFILE - +! - Replace CSPEC_O3_FORCE with CSPEC_ADJ_FORCE +! - remove 'ddd fwd' debug printout +! - change format line 112 in tes_nh3_mod.f to match that in tes_o3_mod.f +! - now allocate CHK_STT_BEFCHEM for LCHEM or LWETD +! - add define.h to checkpoint_mod.f in dep list makefiles +!New features +! - add online LIDORT and MIE code +! +!Revision 1.28 2010/05/07 20:39:47 daven +!General cleanup and streamining +! - update checkpoint_mod.f to be cleaner, remove files after used +! - remove unused directories (code_adj_emis, changsub, monika) +! - update comments at top of geos_chem_adj_mod +!Add stratospheric chemistry adjoint +! - add schem_adj.f and CO_strat_pl_adj.f +! - reinstate call to SCHEM in fwd model +!Add CO2 adjoint +! - implement fwd model updates from Ray: +! - co2_mod.f +! - dag04_mod.f +! - gamap_mod.f +! - input_mod.f +! - logical_mod.f +! - move co2_mod to code/modified +! - update makefiles +! - add CO2 emissions IDs to adj_arrays_mod +! - add 'ppm_free_trop' as sensitivity option +! - add normalized gradients, IJ-GDEN$ +!Add TES O3 obs operator +! - update Makefile.ifort.netcdf +! - add tes_o3_mod.f +! - link to LAPACK libraries +! - save strat O3 profile from SET_PROF in O3_PROF_SAV +! - always call SET_PROF in photoj.f +!Update TES NH3 obs operator +! +!Revision 1.27 2010/04/28 21:00:00 daven +!Now support adjoint runs spanning multiple months / years (dkh, 04/28/10) +! - update ITS_A_NEW_MONTH and ITS_A_NEW_YEAR +! - move DIRECTION to time_mod.f +! +!Revision 1.26 2010/04/25 17:18:58 daven +!BUG FIX: correctly reset adjoints in GEOS-5 convection (dkh, 04/21/10) +!BUG FIX: fix directory for cleaning *.adj.* files (jk, dkh, 04/24/10) +!Now updated support for LADJ = F (dkh, 04/25/10) +! - works with X=0 and XSTOP=0 +! - updated input_adj_mod and soilnox_mod to check for LADJ +! - now use HSAVE from commode_mod instead of checkpt_mod +!Now make running with LINOZE and UPBD on as the default +! +!Revision 1.25 2010/04/01 07:09:43 daven +!Add adjoint of deposition and emissions in gas solver (dkh, 04/01/10) +! - add calcrate_adj.f, setemis_adj.f +! - apply emission scaling factors in setemis.f, move to code/modified +! - update Makefiles * +! - add to adj_arrays_mod.f: DEPSAV_ADJ, REMIS_ADJ +! - for KPP, create DMAP to speed up calculation of V_R. Saves > 10% time. +! +!Revision 1.24 2010/03/09 15:03:46 daven +!General updates and fixes +! - add define.h to dep list for inverse_mod.f in Makefiles +! - GFED2 2008 monthly data is now available (gfed2_biomass_mod) +! - upgrade to the newer bpch2_mod.f from v8-02-04 +! - now only checkpt XYLAI if LCHEM in checkpt_mod (for read and write) +! - BUG FIX: correct typo in thread private pramas in SRCNH3_ADJ +! - remove obsolete 4dvar_driver.f, and references to +! - MAKE_IMIX_CHKFILE, READ_IMIX_CHKFILE +! - MAKE_FPBL_CHKFILE, READ_FPBL_CHKFILE +!Now include adjoint of acetone oceean sink +! - now call OCEAN_ACET_SINK in chemistry_mod +! - now call OCEAN_ACET_SINK (self-adjoint) in chemistry_adj_mod +! - update the forward model OCEAN_ACET_SINK to be more stable and +! more precisely self-adjoint. +!Now include adjoint of UPBDFLX_NOY +! - reinstate fluxes in forward model +! - add routine UPBDFLX_NOY_ADJ +!Correct the following fwd model BUG FIXES from v8-02-04 +! - update reactions in sulfate_mod.f +! - Bug fix for EMEP ship emissions +! - Minor bug fix in gamap_mod.f +! - Fixes and updates in seasalt_mod.f +! - Add EFLUX to ND67 (this actually from an earlier code update) +! - Bug fix in DIAG20 (diag_pl_mod.f) +! - Div-by-zero error encountered in arsl1k.f (just update the whole file) +! - Fix for diagnostic arrays in TPCORE +!Correct the following fwd model BUG FIXES from v8-02-05 +! - make STREETS thread private in READ_ANTHRO_NH3 +! - Fix for initialization of EMEP ship emissions +!Now support LADJ_TRAJ diagnostic option +! - update MAKE_ADJ_FILE +! - update gamap_mod to include IJ-ADJ-$ +!Now support Tagged Ox simulation (Lin Zhang et al., GRL 2009) +! - update chemistry_adj_mod.f, geos_chem_adj_mod.f, adj_arrays_mod.f, +! input_adj_mod.f, tagged_ox_mod.f, add tagged_ox_adj_mod.f +! - update Makefiles +! - treat it as an LADJ_EMS options as the sensitivities are w.r.t. sources +! - works OK but not exact yet. Still needs some debugging. +! +!Revision 1.23 2010/02/10 06:25:03 daven +!Updates for additional features (dkh, 02/09/10) +! - update lightning NOx with patches from 7/10/09 from v8-02-03 +! - update SO2 emissions adjoints +! - comment out IDADJ_ENOxso in adj_arrays_mod.f for now +! - now include adjoint output in tracerinfor.dat, diaginfo.dat +! - move gama_mod.f to code/modified and update makefiles +! +!Revision 1.22 2010/01/28 17:37:21 daven +!Update for additional emissions and a few bug fixes (dkh, 01/28/10) +!- Add checkpointing to support use of MEGAN emissions +! - checkpoint T_15_AVG and T_DAY +! - move megan_mod.f to modified/ +!- Add checkpointing to support use of lightning NOx emissions +! - move lightning_mod.f to modified +! - now checkpoint SLBASE +! - move lightning_mod.o to after checkpt_mod.f in Makefiles +! - take out the temp hack by Lee Murray to use specieal reprocessed OTD fields +!- Turn on all the standard emissions in geos5 input.geos +!- move ITS_TIME_FOR_(some met field)_ADJ functions to time_mod.f +!- BUG FIX: now use NSECb from geos_chem_mod +! - always readin in met files, even if in the 'turn around' zone. +!- To be safe, add some constraints on the KPP <--> SMVGEAR mapping +! of active species following recomendations of Claire Carouge +!- make geos5 benchmark use Makefile.ifort instead of Makefile.ifort.netcdf +!- update use of DIRECTION in chemdr_adj and chemdr.f +!- decrease bufsize to 4000 in gckpp_adj_Integrator.f90 +! +!Revision 1.21 2010/01/06 23:05:04 daven +!Several small bug fixes and updates (dkh, 01/06/10) +!- fix hardwiring of QC_SO2 allocation, should be NSTEP (mak, 11/19/09) +!- read/wring XYLAI in checkpt_mod.f -- only do this for fullchem (mak, 11/19/09) +!- reinstate OMP pragmas in fvdas_convect_adj_mod (mak, 12/09) +!- added a prior constraint for full chem LOG_OPT (dkh, 12/14/09) +!- decrease bufsize to 4000 in gckpp_adj_Integrator (dkh, 01/06/10) +!- add define.h to dep list for adj_arrays_mod.f in all the Makefiles* (dkh, 01/06/10) +! +!Revision 1.20 2009/11/18 07:09:33 daven +!Fix several bugs in the forward model that have been found since +! the release of v8-02-01 (dkh, 11/17/09) +!- apply patch for forward model bug in +! biomass_mod.f (mak, 11/17/09) +!From the list of bugs fixed in v8-02-02, +!http://wiki.seas.harvard.edu/geos-chem/index.php/Bugs_and_fixes +!- Bug with ND52 diagnostic +!- EPA/NEI inventory: reset other species to zero +!- Scale factor for oceanic acetone for GEOS5 2x2.5 +!- Bug with PRIVATE declaration in sulfate_mod.f +!- Bug with online 2ndary aerosol (this was already fixed) +!- Bug for dust in ND48 +!From the list of bugs fixed in v8-02-03 +!http://wiki.seas.harvard.edu/geos-chem/index.php/GEOS-Chem_v8-02-03 +!- Several bug fixes in sulfate_mod.f +!- Missing NOx data in S.E.-Asia +!- ( Mis-calculation of Courant numbers in tpcore_fvdas_mod.f90 was +! fixed in a previous update to adjoint code ) +!- Format problem in planeflight_mod.f +!- Minor fixes in wet deposition +!- Minor fixes for IBM XLF compiler +!- Don't apply 'Minor fixes in gamap_mod.f' becuase I think they +! got it wrong (switched ALD2 with PRPE) +!- Avoiding the "Too many levels in photolysis code" error +!Implement newer BC/OC emissions from v8-02-02. +!- add USE_BOND_BIOBURN to carbon_mod.f +!- add LCOOKE to input_mod.f, logical_mod.f and switch in input.geos +! +!Revision 1.19 2009/11/12 00:45:48 daven +!Updates to emissions adjoints and general performance (dkh, 11/11/09) +! - Update TES NH3 +! - change to 4D Var mode instead of sensitivity forcing +! - switch to TES_v4 +! - skip a few more NT +! - now read in QFLAG, DFLAG +! - switch to TES(NT)%VAR from TES%VAR(NT) format +! - more diagnostic output, including doubled NH3 +! - Adjoint of NH3 emissions +! - Now include emission scaling factors in SRCNH3 +! - Add EMSSULFATE_ADJ +! - Add SRCNH3_ADJ +! - Update emissions adjoint IDs to ADJ_ARRAYS_MOD for fullchem +! and get rid of old hard-coded IDs. +! - BUG FIX: OBJSc should be OBJSe in Makefile.ifort and Makefile.ifort.netcdf +! - Update SET_LOG_SF to use ICS_SF_tmp and EMS_SF_tmp for PSEUDO_OBS +! - Update input_adj_mod.f to stop if using unsupported option LBKCOV (mak) +! - Cleanup and update the RESCALE and LOG_RESCALE routines. Now move +! all regularization / apriori / penalty stuff elsewhere. +! - Print NSECb to prevent corruption in LOG_OPT +! - Adjoint of BC and OC emissions +! - define ID #'s in adj_arrays_mod +! - update carbon_mod.f to include scaling factors +! - update carbon_adj_mod.f to include EMISSCARBON_ADJ and +! EMITHIGH_ADJ +! - Now include Soil NOx +! - modify soilnoxems.f to checkpt emissions and include +! scaling factors for adjoint. +! - add IDADJ_ENOxso to adj_arrays_mod.f +! - move soilnoxems.f to modified/ and update Makefiles * +! - Make DIRECTION a module variable in ADJ_ARRAYS_MOD and +! add new routines GET_DIRECTION and SET_DIRECTION +! - Add counting of active emissions for groups of species +! - Now include N_CARB_EMS_ADJ and N_SULF_EMS_ADJ +! - Now include IS_CARB_EMS_ADJ and IS_SULF_EMS_ADJ +! +!Revision 1.18 2009/10/26 18:54:15 daven +!BUG FIX: recalculation of isoprene emissions (dkh, 10/26/09) +! - change conditions in geos_chem_mod for determining NEW_DAY +! - now checkpoint XYLAI -- it is tricky to recalculate +! TURN CHEM BACK ON +!Update TES NH3 operater (dkh, 10/26/09) +! - Add Makefile.ifort.netcdf +! - add new i/o diagnostics +! - update to v3 retrievals +! - BUG FIX: need to include define_adj.h at the top of +! geos_chem_mod.f +! - move EXPAND_NAME to adj_arrays_mod.f so that it is +! more widely accessible +! - add CMN_DEP to checkpt_mod.f in Makefiles +! - when use LIBS, take out the *.o before the -o +! - now move tes_nh3_mod to after checkpt_mod in compile list +! +!Revision 1.17 2009/10/12 18:08:52 daven +!Add TES NH3 operator (dkh, 10/12/09) +! - add to project and Makefiles +! - add GET_IJ to grid_mod.f +!Debug and test WETDEP adjoint (dkh, 10/12/09) +! - update AD_WASHOUT to match GCv8 +! - BUG FIX: recalculate ALPHA correctly +! - BUG FIX: checkpoint MCHK values correclty at L = 1 +! - update loops in adj wetdep routines to be parallel +! - now make RAINFRAC_0 and WASHFRAC_0 local variable in +! soubroutine ADJ_SO2_WETDEP +! - declare SO2_MCHK as THREADPRIVATE in ADJ_SO2_WETDEP +! - Reset STT(SO2) and STT(SO4) at the end of DO_WETDEP_ADJ +! +!Revision 1.16 2009/10/05 01:25:15 daven +!Several imporant updates and fixes (dkh, mak 10/04/09) +! - Update Makefile (mak) +! - move HDF pieces to new file, Makefile.ifort.hdf +! - add ErrorModule and sciabr_co_obs_mod to Makefile.ifort +! - Now include sulfate chemistry (dkh) +! - add sulfate_adj_mod.f +! - move sulfate_mod.f to modified/ +! - remove sea salt interaction with SO4, NIT +! - add checkpointing +! - call INIT_WETSCAV_ADJ in geos_chem_adj if +! LSULF and LCHEM to allocate SO2s_ADJ and H2O2s_ADJ +! - Now include full chem wet deposition (dkh, but not tested!) +! - move wetscav_mod to /modified +! - add wetscav_adj_mod to Makefile.ifort +! - update adjoint routines +! - change ADJ_STT --> STT_ADJ +! - ADJ_SO2s, ADJ_H2O2s --> SO2s_ADJ, H2O2s_ADJ +! - change IDADJxxx --> IDTxxx +! - now just cyle past N = IDTSO2 for adjoint +! of wetdep for non-SO2 species (old method +! was to set RAINFRAC, WASHFRAC for SO2 = 0 ) +! - change LINUX_EFC --> SGI_MIPS for preproc +! directtives around the parallel do +! - BUG FIX: apply tpcore_fvdas patch, no longer need +! to set va = 0d0 (dkh) +! - keep LFILL as an argument so that we can set it to +! .FALSE. for adjoint transport. +! - Add CALC_APRIORI (mak) +! - Now get first guess of scaling factors from input.gcadj (mak) +! - Update input_adj_mod and input.gcadj to input guesses +! - Add ICS_SF_tmp and EMS_SF_tmp to ADJ_ARRAYS_MOD +! - Update SET_SF in inverse_mod +! - only apply to EMSFD or ICSFD +! - Update and fix SET_LOG_SF similarly (dkh) +! - Update the default GEOS-4 tagged CO simulation +! - 50% error for MOPITT +! - LAERO_THEM = F +! - turn on anthro emissions +! - EMEP, BRAVO, STREETS, NEI99, CAC +! +!Revision 1.15 2009/09/21 01:54:19 daven +!Debug GEOS-4 convection adjoint (dkh, 09/20/09) +! - remove obsolete MAKE_CONVECTION_CHKFILE from geos_chem_mod +! - BUG FIX: now use CHK_STT_CON in DO_GEOS4_CONVECT_ADJ instead of STT +! - and make the Q array REAL*4 in fvdas_convect_adj_mod +! - kludge: set N_SPEC = 1 for TAGCO sim at the top of gfed2_biomass_mod +!Debug GEOS-5 advection adjoint +! - BUG FIX. During the adjoint call to GEOS-5 transport, the array "va" sometimes +! ends up with random values, say in locations like va(71,2), which are never +! inititialized or explicitly defined. Shouldn't they be defined somewhere? +! That could be a bug in fwd model... but initializing va to 0d0 at the +! start of TPCORE fixes the problem. Note that the symptom is: +! forrtl: severe (408): fort: (3): Subscript #2 of the array QQUWK has +! value -2 which is less than the lower bound of -1 +!General +! - now only call DO_EMISSIONS_ADJ if LADJ_EMS +! - cleanup inverse_mod.f a bit +! - make the repository geos4 simulation a tagged CO inverse ICS test, +! while the geos5 simulation is full chem global FD test. +! - simplify INIT_WEIGHT to prevent it from crashing +! +!Revision 1.14 2009/09/15 16:10:28 daven +!Update input.gcadj (mak, dkh, 09/15/09) +! - now can specify IFD, JFD directly +! +!Revision 1.13 2009/09/15 05:33:02 daven +!Implement het chem adjoints (dkh, 09/14/09) +! - turnon CHEMCARBON in chemistry_mod.f +! - turnon CHEMCARBON_ADJ in chemistry_adj_mod.f +! - add carbon_adj_mod.f +! - move carbon_mod.f to code/modified/ and update Makefile +! - make DRYxxx public in carbon_mod +!Add adjoint of aerosol thermodynamics (dkh, 09/09/09) +! - implement LAERO_THERM flag in do_chemistry and do_chemistry_adj +! - make RECOMP_RPMARES for recalculating intermediate values +! - make rpamres_adj_mod +! - make the following routine in rpmares_mod public so that +! they can be used in rpmares_adj_mod: +! - POLY4, POLY6, CUBIC, AWATER, ACTCOF +!Unrelated +! - Don't stop the simulation if VAR in fwd is 1.0003d-99 and +! the recalculated value is 1.0000d-99 in CINSPECT +! +!Revision 1.12 2009/09/08 04:18:25 daven +!Update CO emissions adjoint (mak, dkh, 09/07/09) +! - rename tagged_adj_co_mod --> tagged_co_adj_mod +! * ( did this in Makefile, need to actually do it ) * +! - add emissions_adj_mod +! - don't recalculate forward emissions during adjoint if +! its a tagged co simulation +! - BUG_FIX: now set initial guess scaling factors to perturbed +! value every time passing through N_CALC = 1 +!Add aerosol thermodynamics to forward code (dkh, 09/07/09) +! - move rmpares_mod.f to code/modified/ +! - reinstate CALL RPMARES in chemistry_mod +! - make RPAMRES_FORADJ +! +!Revision 1.11 2009/09/07 20:12:47 daven +!Updated convection adjoint (dkh, 08/25/09) +! - modify convection_mod.f to checkpoint arrays +! - move convection_mod.f to modified/convection_mod.f +! - delete extra copy of wetscav_mod.f in code/ +! - updated NFCLDMX_ADJ to support GEOS-5 +! +!Revision 1.10 2009/08/17 03:59:52 daven +!Turn on chemistry for tagged CO (dkh, 07/27/09) +! - Remove the tagged_co_mod.f file from /code, as we +! use the one in /code/modified NEED TO DO THIS +! - Remove the bpch2_mod.f file from /code, as we +! use the one in /code/modified NEED TO DO THIS +! - GEOS-5 tagged CO with chemistry turned on will +! crash if not using 72 vertical levels because the +! geos5 OH file in GEOS_MEAN hasn't been reduced +! to 30 vertical levels. So as a temporary hack, +! force the simulation to use the GEOS_4 OH fields. +! - same for GEOS-5 P/L fields +! - Add export OMP_NUM_THREADS=8 to run script +! - Add more informative printout to run script +! - Now run script checks for gctm.sf.* at the +! end of each iteration +! - Fix line overflow on 1225 of input_adj_mod.f +! - Only print out the optimizaiton header if +! ITERATE = T +! - Move call to CLEAN_FILE_DIRS to input_adj_mod +! to avoid deleting *.obs.* files for pseudo tests +! and to remove old gctm.sf.* files before calling +! ARE_FLAGS_VALID (helps inform run script of crash) +! - Now check to ensure that 1 < N_CALC < 3 for FDTEST +! in subroutine ARE_FLAGS_VALID +! - Verified FDTEST using LOG_OPT +! - implemented LOG_RESCALE for LOG_OPT, LICS +! - implemented LOG_OPT in APPLY_IC_SCALING, +! adding include define_adj.h +! - make sure call SET_LOG_SF when +! N_CALC == N_CALC_STOP == 1 +! - Use STT_ORIG in RESCALE_ADJOINT and LOG_RESCALE_ADJOINT +! rather than reading the restart file again. +! +!Implement the full chem simulation (dkh, 08/16/09) +! - Update input.geos and input.gcadj +! - Update INIT_CHECKPT (use N_TRACERS instead of NOBS) +! - Remove chemistry_mod.f and chemdr.f from /code, as they +! are in /code/modified +! - Remove restart_mod.f from /code; it is in /code/modified +! - Remove physproc.f from /code; it is in /code/modified +! - Use GCKPP_ADJ_DRIVER from dkh GCv6 adjoint for both +! forward and backward integration. +! - Loop N up to N_TRACERS instead of NOBS in INIT_WEIGHT +! - Pass back the value of IERR into ISTATUS in gckpp_adj_Integartor.f90 +! - Minimal rescaling for LFDTEST or LSENS +! - IMPLEMENT OMP -- change the makefile to use parallel F90 +! compile command. +! - Take out USE GCKPP_ADJ_Model in GCKPP_ADJ_DRIVER, so reference +! everything explicitly from GCKPP_ADJ_GLOBAL +! - Add gckpp_* files to dependency list for chemistry_mod.f +! and chemistry_adj_mod.f in the Makefile.ifort +! - Update dependancy list for all gckpp_adj_* files in Makefile.ifort +! - Declare THREADPRIVATE in gckpp_adj_Global: +! - JLOOP, C, VAR, VAR_ADJ, FIX, V_CSPEC, V_CSPEC_ADJ, TIME, +! VAR_R_ADJ, RCONST +! - stack_ptr (moved here from gckpp_adj_Integrator.f90) +! - Declare THREADPRIVATE in gckpp_adj_Function: +! - A +! - Remove EQIVALENCE statment for C, VAR, FIX +! in gckpp_adj_Global. To compensate, define C +! from VAR and FIX in gckpp_adj_Initialize +! - SET VAR(15) (LISOPOH) to 1d-99. +! - Manually set VAR(13) and VAR(14) (CO2 and DRYDEP) to be zero as well. +! - Add to Makefile.ifort and CVS +! - chemdr_adj.f +! - lump_adj.f +! - partition_adj.f +! - Add INIT_KPP to gckpp_adj_Util.f90 to initialize JCOEFF. +! - Move partition.f to modified/partition.f, add PART_CASE +! - Remove CSPEC_ADJ_FOR_KPP and CSPEC_FOR_KPP_ADJ. Just use CSPEC_ADJ. +! The reason we have CSPEC_FOR_KPP is so that +! you can run KPP and SMVGEAR side-by-side in the forward model. Since +! KPP is the only way to calculate CSPEC_ADJ, don't need to make an +! extra copy. +! - Reset NEMIS and NNADDV before calling READCHEM when FIRSTCHEM in +! chemrd_adj.f. Otherwise these will get double counted, causing +! segfault crashes in calcrate. Same for NNADDA, NNADDN, NNADDC, +! NNADDD, NNADDF, NNADDH, NNADDG +! - Now use NTLOOP instead of ITLOOP when checkpointing CSPEC arrays +! - Call SAVE_FULL_TROP before GASCONC in CHEMDR_ADJ. Otherwise, CSPEC +! could get overwritten with old values in CSPEC_FULL +! - Use HSAVE (dkh) instead of HSAVE_KPP (ks) as HSAVE is set up to +! rotate and checkpt properly. +! - Now call DO_DRYDEP and DO_EMISSIONS in GEOS_CHEM_ADJ right +! before the call to adjoint of chemistry +! - Now call CINSPECT to check for consistancy between the forward +! and backward values of RCONST and VAR +! - Now save CHECK_STT_BEFCHEM before DO_EMISSIONS so that SO2, SO4 +! and DMS are correct in the adjoint gas-phase chemistry. May +! want to change this once the adjoint of the emissions +! and sulfate chemistry are in place. +! - Now call DO_PBL_MIX(.FALSE.) up top in geos_chem_adj in +! order for FPBL to be calculated for subsequent processes +! - Now save CSPEC_PRIOR the first time through gasconc so +! that partition_adj works at NHMSb (otherwise CSPEC_PRIOR +! will be zero). Make IX, IY, IZ threadprivate. +! - Can' run with soil NOx on yet until we make it recalculate +! emissions in adj mode. Disable it for now. +! - Reinstate CALL OPTDEPTH in DO_CHEMISTRY_ADJ so that +! photolysis rates get recalculated correctly +! +!Revision 1.9 2009/07/14 23:51:27 daven +!Updated to run with GEOS-5 and PBL mixing (dkh, 07/14/09) +! - add support for GEOS-5 +! - if using GEOS-5, make sure that IN_CLOUD_OD is defined in define.h +! - update GET_A3_TIME_ADJ to treat GEOS_5 the same as GEOS_4 +! - implement printout for GEOS_5 in DISPLAY_MET +! - turn on LNEI99 (or else the code bombs when trying to access USA_MASK +! which is not allocated). This is a bug in the standard forward code. +! - move call to CALC_ADJ_FORCE to after interpolation of the I-6 fields +! - add constraint for FDTEST in ITS_TIME_FOR_OBS that it must be a TS_CHEM +! - implement TURBDAY_ADJ, now recalculate IMIX and FPBL rather than checkpoint +! - this means atting GET_IMIX and GET_FPBL to pbs_mix_mod +! - modify adjoint code to reference these routines +! - remove unused stuff for checkpointing +! - remove old CLEANUP_PBL_MIX_ADJ from cleanup and cleanup_adj +! - apply FD diff to ICSFD in SET_SF_FORFD, FD_SPOT, LICS +! - ensure that UNITS of COST_FUNC are the default for FD_GLOB +! +!Revision 1.8 2009/06/26 03:57:58 daven +!Updated, CO FD_GLOB LICS now works w/o any processes (dkh, 06/25/09) +! - remove ctm.bpch and geos from repository to speedup +! checkout +! - have gctm.model.* gctm.costfn* and gctm.obs* be written +! to DIAGADJ_DIR instead of OPT_DIR +! - Take out the LADJ_TRAN flag. Would this ever +! differ from LTRAN? +! - Now for FDTEST force FLAG to TRUE on the first attempt during +! the adjoint integration and false otherwise. +! - clean out old *.fd.* files on N_CALC == 1 +! - replace restart file with Monikas from 20040501 +! - add ICSFD. This selects the denominator of the sensitivities +! for an initial conditions finite difference test independently +! of the species being included in the numerator. +! - add more comments to FD menu in input.gcadj, swap order of +! NFD and MFD. move FD_SPOT and FD_GLOB to FD menu, and +! move definition of MMSCL to control variables menu +! - uypdate ARE_FLAGS_VALID to be more rigorous +! - make sure LADJ_CHEM and LCHEM match +! - make sure 1 and only 1 type of simulation selected +! - make sure some obs are selected for 3D or 4DVar +! - make sure no obs are selected for FDTEST +! - make sure that 1 and only 1 of LADJ_EMS and LICS +! is included for FDTEST +! - Re-reading the restart file gave negative STT values. Instead, +! let's go back to using STT_ORIG. +! - fixed inconsistancies in lots of preprocessor tags: +! MOPITT_OBS --> MOPITT_IR_CO_OBS +! O3_ATTAINMENT --> SOMO35_ATTAINMENT +! CASTNET_OBS --> CASTNET_NH4_OBS +! IMPROVE_OBS --> IMPROVE_SO4_NIT_OBS +! - don't leave PSEUDO_OBS on by default, as it can mess up an FD test +! - add define_adj.h to dep list in Makefile.ifort for +! - adj_arrays_mod.o +! - input_adj_mod.o +! - inverse_driver.o +! - geos_chem_mod.o +! - in input_mod.f, make sure that TS_DYN always stays the same +! value regardless of which processes are turned on or off. +! Move this file to code/modified and update Makefile accordingly +! +!Revision 1.7 2009/06/23 06:47:07 daven +!Updates (mak, dkh, 06/23/09) +! - move tagged_co_mod from code/modified/monika to +! code/modified (mak) +! - add background error (mak, untested) +! - reinstate LDEL_CHKPT flag (dkh) +! - update CO obs operator defs in define_adj.h (mak) +! - distinguish between LEMS and LADJ_EMS (mak) +! - added CO diagnostics (mak) +! - updated Makefile, but still mostly commented out (mak) +! +!Revision 1.6 2009/06/19 07:05:23 daven +!Updates (mak, dkh, 06/19/09) +! - switch the test simulation to +! - 4DVar +! - use a real restart file +! - not LOG_OPT in define_adj.h +! - 30 levels (in define.h +! - change flags in input.gcadj +! - turn off biogenic emissions in input.geos +! - add LADJ_EMS flag to many places +! - add RESCALE routine in geos_chem_adj_mod +! - now call INIT_WEIGHT at the beginning of +! geos_chem_adj_mod +! +!Revision 1.5 2009/06/17 07:39:04 daven +!Update met field i/o for GEOS_4 adj integration (dkh, 06/17/09) +! - decrement adjoint time before reading checkpt files +! - update routines in i6_read_mod, dao_mod +! - add SLP_TMP, LWI_TMP, TO3_TMP and TTO3_TMP +! - test w/ and /wo transport on. Adjust call to INTERP +! accordingly. +! - add dependencies to geos_chem_mod in Makefile +! - move get_read_mod.f to modified/ +! +!Revision 1.4 2009/06/15 06:44:12 daven +!Updates (dkh, 06/15/09) +! - New Makefile layout with folders and dependency (ks) +! - move calcrate.f to modified (ks) +! - update transport_mod (ks) +! - add run script to run directory (dkh) +! +! + PROGRAM INVERSE +! +!***************************************************************************************** +! Program inverse is the master driver for the inverse and adjoint modeling capabilities +! of the GEOS-Chem chemical transport model. (dkh, ks, mak, cs 06/07/09) +! +! NOTES +! (1 ) Add support for inverse Hessian LINVH (dkh, 01/13/12, adj32_012) +! (2 ) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/15/12, adj32_055) +! (3 ) Add support for inverse Hessian LINVH_BFGS (nab, 03/25/12 ) +! (4 ) Add support for weak constraint 4D-Var (mkeller, 06/15) +!***************************************************************************************** +! + +# include "define_adj.h" + + ! Reference to f90 modules + USE A3_READ_MOD, ONLY : UNZIP_A3_FIELDS + USE A6_READ_MOD, ONLY : UNZIP_A6_FIELDS + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_TOTAL + USE ADJ_ARRAYS_MOD, ONLY : NOPT, IFD, JFD, LFD, MFD + USE ADJ_ARRAYS_MOD, ONLY : NFD,EMSFD + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ_FD, EMS_SF_ADJ,ICS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : INIT_ADJ_ARRAYS + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC_SAV + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : STRFD + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : RATFD + USE CHECKPT_MOD, ONLY : MAKE_EMS_ADJ_FILE + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : CLOSE_FILES + USE GEOS_CHEM_MOD, ONLY : DO_GEOS_CHEM + USE GEOS_CHEM_ADJ_MOD, ONLY : DO_GEOS_CHEM_ADJ + USE GWET_READ_MOD, ONLY : UNZIP_GWET_FIELDS + USE I6_READ_MOD, ONLY : UNZIP_I6_FIELDS + USE INPUT_MOD, ONLY : READ_INPUT_FILE + USE INPUT_ADJ_MOD, ONLY : READ_INPUT_ADJ_FILE + USE INV_HESSIAN_MOD, ONLY : UPDATE_HESSIAN + USE INVERSE_MOD, ONLY : SET_SF, SET_LOG_SF + USE INVERSE_MOD, ONLY : SET_SF_FORFD + USE INVERSE_MOD, ONLY : MAKE_SF_FILE + USE INVERSE_MOD, ONLY : MAKE_GDT_FILE + USE INVERSE_MOD, ONLY : MAKE_CFN_FILE + USE INVERSE_MOD, ONLY : READ_GDT_FILE + USE INVERSE_MOD, ONLY : READ_CFN_FILE + USE INVERSE_MOD, ONLY : SET_OPT_RANGE + USE INVERSE_MOD, ONLY : INIT_INVERSE + USE INVERSE_MOD, ONLY : GET_X_FROM_SF + USE INVERSE_MOD, ONLY : GET_SF_FROM_X + USE INVERSE_MOD, ONLY : GET_GRADNT_FROM_ADJ + USE INVERSE_MOD, ONLY : X + USE INVERSE_MOD, ONLY : GRADNT + USE INVERSE_MOD, ONLY : CALC_NOPT + USE INVERSE_MOD, ONLY : DISPLAY_STUFF + USE INVERSE_MOD, ONLY : MAKE_SAT_DIAG_FILE + USE INVERSE_MOD, ONLY : ITER_CONDITION + USE INVERSE_MOD, ONLY : MAYBE_DO_GEOS_CHEM_ADJ + USE INVERSE_MOD, ONLY : DO_SAT_DIAGS + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_MOD, ONLY : LUNZIP + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST + USE LOGICAL_ADJ_MOD, ONLY : LINVH,LINVH_BFGS + USE LOGICAL_ADJ_MOD, ONLY : LADJ + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LICS + USE LOGICAL_ADJ_MOD, ONLY : LDCOSAT + USE LOGICAL_ADJ_MOD, ONLY : LSAT_HDF_L2, LSAT_HDF_L3 + USE LOGICAL_ADJ_MOD, ONLY : LATF + USE LOGICAL_ADJ_MOD, ONLY : LITR + USE LOGICAL_ADJ_MOD, ONLY : LEMS_ABS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + + ! mkeller: variables for weak constraint 4D-Var + USE WEAK_CONSTRAINT_MOD, ONLY : INIT_WEAK_CONSTRAINT + USE WEAK_CONSTRAINT_MOD, ONLY : CLEAN_WEAK_CONSTRAINT + USE WEAK_CONSTRAINT_MOD, ONLY : CT_SUB_U + USE WEAK_CONSTRAINT_MOD, ONLY : CALC_GRADNT_U + USE WEAK_CONSTRAINT_MOD, ONLY : READ_GDT_U_FILE + USE WEAK_CONSTRAINT_MOD, ONLY : MAKE_GDT_U_FILE + USE WEAK_CONSTRAINT_MOD, ONLY : DO_WEAK_CONSTRAINT + USE WEAK_CONSTRAINT_MOD, ONLY : SET_CT_U + USE WEAK_CONSTRAINT_MOD, ONLY : PERTURB_STT_U + USE WEAK_CONSTRAINT_MOD, ONLY : X_U + USE WEAK_CONSTRAINT_MOD, ONLY : X_GRADNT_U + USE WEAK_CONSTRAINT_MOD, ONLY : NOPT_U + USE WEAK_CONSTRAINT_MOD, ONLY : N_TIMESTEPS_U + + !USE PHIS_READ_MOD, ONLY : UNZIP_PHIS_FIELD + +#if defined ( LBFGS_INV ) + USE INV_HESSIAN_LBFGS_MOD, ONLY : LBFGS_INV_HESSIAN +#endif + + ! Force all variables to be declared explicitly + IMPLICIT NONE + + ! Program variables + LOGICAL :: ITERATE = .TRUE. + + ! Variables and parameters for optimization -- see setulb.f for + ! definitions of these. + INTEGER :: iprint, isave(44) + CHARACTER*60 :: task, csave + DOUBLE PRECISION :: factr, pgtol, dsave(29) + DOUBLE PRECISION :: F + LOGICAL :: lsave(4) + INTEGER, PARAMETER :: MMAX = 17 + INTEGER :: LENWA + INTEGER, ALLOCATABLE :: nbd(:) + INTEGER, ALLOCATABLE :: iwa(:) + REAL*8, ALLOCATABLE :: llim(:) + REAL*8, ALLOCATABLE :: u(:) + REAL*8, ALLOCATABLE :: wa(:) + INTEGER :: IOPT,MM + + !mkeller: variables needed for weak constraint 4D-Var + INTEGER :: NOPT_WEAK_CONSTRAINT + REAL*8, ALLOCATABLE :: X_WEAK_CONSTRAINT(:) + REAL*8, ALLOCATABLE :: X_GRADNT_WEAK_CONSTRAINT(:) + + !================================================================= + ! INVERSE starts here! + !================================================================= + + ! Read forward model input file and call init routines from + ! other modules + CALL READ_INPUT_FILE + IF ( LPRT ) CALL DEBUG_MSG( '### INVERSE: a READ_INPUT_FILE' ) + + ! Read final iteration number from file + OPEN( 65, file = 'ITER' ) + READ( 65,*) N_CALC_STOP + READ ( 65,*) N_CALC_TOTAL + CLOSE( 65 ) + + ! Number of previous iterations used in the Hessian approximation + ! Here it was set to the total number of iteration + ! =>Memory problem for big control vector so set back to MM = 5 +! MM = N_CALC_TOTAL + MM = 5 + + ! Read input file for adjoint model + CALL READ_INPUT_ADJ_FILE + + ! For weak constraint 4D-Var (mkeller, 06/15) + IF ( DO_WEAK_CONSTRAINT ) CALL INIT_WEAK_CONSTRAINT + + ! Initialize arrays for optimization + IF (LADJ) CALL INIT_SETULB + + ! Initialize inverse modeling module + CALL INIT_INVERSE + + ! Curent iteration + N_CALC = 0 + + ! Initialize adjoint arrays + ! some arrays still need to be initialized + CALL INIT_ADJ_ARRAYS + IF ( LPRT ) CALL DEBUG_MSG( '### INVERSE: a INIT_ADJ_ARRAYS' ) + + ! Now do this in input_adj_mod.f (dkh, 07/28/09) + !! Clean out file directories (rm *.chk.* , *.adj.* , *.ics.* and + !! *.gdt.* files ) + !CALL CLEAN_FILE_DIRS + + ! For weak constraint 4D-Var (mkeller, 06/15) + IF ( DO_WEAK_CONSTRAINT ) PERTURB_STT_U = .FALSE. + + !================================================================= + ! ***** R E F E R E N C E C A L C U L A T I O N ***** + ! for generating pseudo observations + !================================================================= + IF ( N_CALC_STOP == 0 ) THEN + + ! Now only call this once above (dkh, 07/27/09) + !! Remove files from previous runs + !CALL CLEAN_FILE_DIRS + + ! For weak constraint 4D-Var (mkeller, 06/15) + IF ( DO_WEAK_CONSTRAINT ) PERTURB_STT_U = .TRUE. + + ! Set IC's to their reference values +#if defined ( LOG_OPT ) + CALL SET_LOG_SF +#else + CALL SET_SF +#endif + + ! Call GEOS-CHEM + CALL DO_GEOS_CHEM + + ! Make SF file + CALL MAKE_SF_FILE + + ! EXIT + ITERATE = .FALSE. + + ENDIF + + + ! Allow for use of this driver to run only the forward model as + ! a reference calculation. + IF ( .not. LADJ ) ITERATE = .FALSE. + + + !================================================================= + ! ***** S E T S C A L I N G F A C T O R S ***** + !================================================================= + + ! Now only call this once above (dkh, 07/27/09) + !! this call was deleting obs files! need to either delete it or + !! replace some options inside (mak, 6/18/09) + !CALL CLEAN_FILE_DIRS + + ! Perturb the initial conditions + IF ( ITERATE ) THEN +#if defined ( LOG_OPT ) + CALL SET_LOG_SF +#else + CALL SET_SF +#endif + ENDIF + + ! if LINVH_BFGS directly compute the L-BFGS inverse Hessian (nab, 03/27/12) +#if defined ( LBFGS_INV ) + IF ( .NOT. ( LINVH_BFGS ) ) THEN +#endif + + !================================================================= + ! ***** O P T I M I Z A T I O N ***** + !================================================================= + + ! Set parameters for optimization. See setulb.f for definitions. + ! Let PGTOL be very small for FDTEST, as we're not actually doing + ! an optimization in this case. + IPRINT = 1 + FACTR = 1.0D01 + IF ( LFDTEST ) THEN + PGTOL = 1.0D-12 + ELSE + PGTOL = 1.0D-05 + ENDIF +#if defined ( LOG_OPT ) + DO IOPT = 1, NOPT + NBD(IOPT) = 0 ! 0 = no bounds + ENDDO +#else + ! For weak constraint 4D-Var (mkeller, 06/15) + IF (DO_WEAK_CONSTRAINT) NBD(NOPT+1:NOPT_WEAK_CONSTRAINT) = 0 + + DO IOPT = 1, NOPT + NBD(IOPT) = 1 + LLIM(IOPT) = 0.0D0 + ENDDO +#endif + + task = 'START' + + ! Mare array of scaling factors into a vector for optimization + CALL GET_X_FROM_SF + + !================================================================= + ! OPTIMIZATION loop starts here! + !================================================================= + + IF ( ITERATE ) THEN + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'S T A R T O P T I M I Z A T I O N' + WRITE (6,16) + 16 format(/ 5x, 'Solving GEOS-Chem Adjoint.' + + / 5x, ' (f = 0.0 at the optimal solution.)' /) + ENDIF + + ! Beginning of the loop + DO WHILE( ITERATE ) + + IF ( DO_WEAK_CONSTRAINT ) THEN + + CALL GET_WEAK_CONSTRAINT_FIELDS + + print*, ' do setulb ' + ! Call the L-BFGS-code + CALL SETULB( NOPT_WEAK_CONSTRAINT, MM, X_WEAK_CONSTRAINT, + & LLIM, U, NBD, F, X_GRADNT_WEAK_CONSTRAINT, FACTR, + & PGTOL, WA, IWA, TASK, IPRINT, CSAVE, + & LSAVE, ISAVE, DSAVE ) + + print*, ' done setulb ' , TASK + + CALL SAVE_WEAK_CONSTRAINT_FIELDS + + ELSE + + + print*, ' do setulb ' + + ! Call the L-BFGS-code + CALL SETULB( NOPT, MM, X, LLIM, U, NBD, + & F, GRADNT, FACTR, PGTOL, WA, IWA, + & TASK, IPRINT, CSAVE, LSAVE, ISAVE, DSAVE ) + + print*, ' done setulb ' , TASK(1:2) + + ENDIF + + ! Force it to continue for FD tests, as cost func or gradients + ! may be very small or zero (dkh, 02/11/11) + IF ( LFDTEST ) TASK(1:2) = 'FG' + + IF ( TASK(1:2) == 'FG' ) THEN + + ! Iteration diagnostics (zhe 11/28/10) + IF ( LITR ) THEN + IF ( N_CALC .GT. 0 ) CALL ITER_CONDITION( N_CALC ) + LATF = .FALSE. + ENDIF + + ! The minimization routine has returned to request the + ! function f and gradient g values at the current x + + ! Update iteration count + N_CALC = N_CALC + 1 + + ! Resent cost function for this iteration + COST_FUNC = 0.D0 + + IF ( N_CALC < N_CALC_STOP ) THEN + + WRITE(6,*) 'READING SAVED DATA for N_CALC = ', N_CALC + + ! Read scaling factor values from disk + CALL GET_SF_FROM_X + + CALL DISPLAY_STUFF( 1 ) + + ! Read gradients from disk + CALL READ_GDT_FILE + + ! Read cost function from disk + CALL READ_CFN_FILE + + ! Put adjoints into GRADNT vector + CALL GET_GRADNT_FROM_ADJ + + !mkeller: read gradients with respect to forcing terms + IF ( DO_WEAK_CONSTRAINT ) CALL READ_GDT_U_FILE + + !Save the current adjoint in the finite difference test cell + ! Initial conditions test + IF ( LFDTEST .AND. LICS .AND. LADJ_EMS) THEN + + PRINT*, 'WE HAVE A PROBLEM WITH STT_ADJ_FD when LICS & + & LADJ_EMS are both TRUE' + + ELSEIF ( LFDTEST .AND. LICS ) THEN + + STT_ADJ_FD(N_CALC) = ICS_SF_ADJ(IFD,JFD,LFD,NFD) + + ELSEIF ( LFDTEST .AND. LADJ_EMS ) THEN + + + ! Emissions test + IF ( .NOT. LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + + STT_ADJ_FD(N_CALC) = EMS_SF_ADJ(IFD,JFD,MFD,EMSFD) + + ! Strat prod and loss sense (hml, adj32_025) + !ELSEIF ( LADJ_STRAT ) THEN + ELSEIF ( LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + + STT_ADJ_FD(N_CALC) = LOSS_SF_ADJ + & (IFD,JFD,MFD,STRFD) + + ! Reaction rate (tww, 05/15/12) + ELSEIF ( LADJ_RRATE ) THEN + + STT_ADJ_FD(N_CALC) = RATE_SF_ADJ + & (IFD,JFD,LFD,RATFD) + + ENDIF + + ENDIF + + ! Copy value of COST_FUNC to the optimization variable F + F = COST_FUNC + + ! Save current cost function + COST_FUNC_SAV(N_CALC) = COST_FUNC + + CALL DISPLAY_STUFF( 2 ) + + ! to estimate inverse Hessian (offline) (dkh, 01/12/12, adj32_012) + IF ( N_CALC == 1 .and. LINVH ) CALL UPDATE_HESSIAN + + ! Return to beginning of loop + + ELSEIF ( N_CALC == N_CALC_STOP ) THEN + + ! Done if we are just estimating inverse Hessian (dkh, 01/12/12, adj32_012) + IF ( LINVH ) THEN + WRITE(6,*) ' Force quit' + STOP + ENDIF + + ! UPDATE THE INITIAL CONDITIONS + + ! If we're doing a finite difference test, reset to the orginal + ! SF and augment by amount FD_DIFF. Don't use X in this case. + ! old: + !IF ( ACTIVE_VARS == 'FDTEST' .AND. N_CALC == 2 ) THEN + ! new: now support 2nd order FDTEST (MAKE_SAVE_FILE_2) + IF ( LFDTEST .AND. N_CALC > 1 ) THEN + + CALL SET_SF_FORFD + + ELSEIF ( N_CALC == 1 ) THEN + + ! don't need to call this again ?? + !CALL SET_SF +#if defined ( LOG_OPT ) + CALL SET_LOG_SF +#else + CALL SET_SF +#endif + + ELSE + + ! Update the scaling factors to the current X + CALL GET_SF_FROM_X + + ENDIF + + CALL DISPLAY_STUFF( 3 ) + + + !============================================================== + ! OPTIONAL: uncomment to use scaling factors from another run + !============================================================== + !CALL READ_SF_FILE + + !============================================================== + ! FORWARD RUN + !============================================================== + CALL DO_GEOS_CHEM + + !============================================================== + ! ADJOINT CALCULATION + !============================================================== + + ! For weak constraint 4D-Var (mkeller, 06/15) + IF ( DO_WEAK_CONSTRAINT ) X_GRADNT_U = 0d0 + + IF ( .not. LFDTEST ) THEN + + CALL DO_GEOS_CHEM_ADJ + + ! For finite difference test, we may or may not do adjoint + ELSE + + CALL MAYBE_DO_GEOS_CHEM_ADJ + + ENDIF + + !============================================================== + ! SAVE RESULTS TO DISK and EXIT OPTIMIZATION LOOP + !============================================================== + + ! Zero the gradients of the species that we do not wish to optimize + ! or in places that you don't want optimized + CALL SET_OPT_RANGE + ! Add to this Kumaresh's spatial filter + + ! Write gradients + CALL MAKE_GDT_FILE + + ! Write scaling factors + CALL MAKE_SF_FILE + + ! Write cost function + CALL MAKE_CFN_FILE + + ! For weak constraint 4D-Var (mkeller, 06/15) + IF ( DO_WEAK_CONSTRAINT ) CALL MAKE_GDT_U_FILE + + ! mkeller: create HDF5 file for satellite diagnostics output + IF ( LSAT_HDF_L2 .OR. LSAT_HDF_L3 .OR. LDCOSAT ) + & CALL DO_SAT_DIAGS() + + IF ( LEMS_ABS ) CALL MAKE_EMS_ADJ_FILE + + ! Write results to screen + CALL DISPLAY_STUFF( 4 ) + + ! Exit loop + ITERATE = .FALSE. + + ENDIF + + + ELSEIF ( TASK(1:5) == 'NEW_X' ) THEN + + ! The minimization routine has returned with a new iterate, + ! and we have opted to continue the interation + + ! Update the inverse hessian approximation (dkh, 01/12/12, adj32_012) + IF ( LINVH ) THEN + CALL UPDATE_HESSIAN + ENDIF + + ELSE + + ! We terminate execution when TASK is neither FG nor NEW_X. + ! We print the information contained in the string TASK + ! if the default output is not used and the execution is + ! not stopped intentionally by the user. + IF ( IPRINT == -1 .AND. TASK(1:4) /= 'STOP' ) + & WRITE(6,*) TASK + + WRITE(6,*) TASK + + ! Exit loop + ITERATE = .FALSE. + + ENDIF + + !================================================================= + ! OPTIMIZATION loop ends here! + !================================================================= + ENDDO + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'F I N I S H I T E R A T I O N ' + +#if defined ( LBFGS_INV ) + ENDIF ! end Hessian BFGS condition (nab) + + ! Calculate the (diagonal) inverse Hessian approximation + ! Using the L-BFGS algorithm ( nab, 24/03/12 ) + + + IF ( ( LINVH_BFGS ) + & .AND. ( N_CALC_TOTAL .GE. 2 ) ) THEN + + N_CALC = N_CALC_TOTAL + + PRINT*,'***********************************************' + PRINT*,'C O M P U T E E S T I M A T I O N E R R O R' + PRINT*,'***********************************************' + + + CALL LBFGS_INV_HESSIAN(MM) + ENDIF +#endif + + ! Clean up and quit + CALL CLOSE_FILES + CALL CLEANUP + CALL CLEANUP_ADJ + + ! For weak constraint 4D-Var (mkeller, 06/15) + IF ( DO_WEAK_CONSTRAINT ) CALL CLEAN_WEAK_CONSTRAINT + + ! Remove all met files from temporary directory + IF ( LUNZIP ) THEN + CALL UNZIP_A3_FIELDS( 'remove all' ) + CALL UNZIP_A6_FIELDS( 'remove all' ) + CALL UNZIP_I6_FIELDS( 'remove all' ) + !CALL UNZIP_PHIS_FIELD( 'remove all' ) + +#if defined( GEOS_3 ) + ! We only need to remove the GWET fields if we are + ! using the online dust simulation (bmy, 4/1/04) + IF ( LDUST ) THEN + CALL UNZIP_GWET_FIELDS( 'remove all' ) + ENDIF +#endif + + ENDIF + + ! Write the final iteration number for the next iteration to file + OPEN( 65, file = 'ITER' ) + WRITE( 65,*) N_CALC_STOP + 1 + CLOSE( 65 ) + + + WRITE( 6, '(a,/)' ) 'D O N E' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + CONTAINS +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_SETULB( ) +! +!****************************************************************************** +! Subroutine INIT_SETULB initializes arrays used by the optimization routine, +! setulb, whose size depends upon the model simulation type and resolution. +! (dkh, 06/07/09) +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : NOPT + USE ERROR_MOD, ONLY : ALLOC_ERR + USE INVERSE_MOD, ONLY : CALC_NOPT + + !MK-WEAK_CONSTRAINT: + USE WEAK_CONSTRAINT_MOD, ONLY : DO_WEAK_CONSTRAINT + USE WEAK_CONSTRAINT_MOD, ONLY : NOPT_U + USE WEAK_CONSTRAINT_MOD, ONLY : N_TIMESTEPS_U + + ! Local variables + INTEGER :: AS + + !================================================================= + ! INIT_SETULB begins here! + !================================================================= + + ! Calculate the maximum number of control parameters that could + ! be optimized, NOPT + CALL CALC_NOPT + + !MK-WEAK_CONSTRAINT: + IF ( DO_WEAK_CONSTRAINT ) THEN + + !mkeller: assume that forcing is only computed for one tracer + + NOPT_WEAK_CONSTRAINT = NOPT + NOPT_U*N_TIMESTEPS_U + PRINT *,"NOPT: ", NOPT + PRINT *,"NOPT_U: ", NOPT_U + PRINT *,"NOPT_WEAK_CONSTRAINT: ", NOPT_WEAK_CONSTRAINT + + ALLOCATE(X_WEAK_CONSTRAINT(NOPT_WEAK_CONSTRAINT)) + ALLOCATE(X_GRADNT_WEAK_CONSTRAINT(NOPT_WEAK_CONSTRAINT)) + + + LENWA = 2 * MM * NOPT_WEAK_CONSTRAINT + + & 4 * NOPT_WEAK_CONSTRAINT + 11 * MM * MM + 8 * MM + + ALLOCATE( NBD( NOPT_WEAK_CONSTRAINT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NBD' ) + !NBD = 0 + + ALLOCATE( IWA( 3*NOPT_WEAK_CONSTRAINT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'IWA' ) + IWA = 0 + + ALLOCATE( LLIM( NOPT_WEAK_CONSTRAINT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LLIM' ) + ! Don't set default bounds (dkh, 11/07/09) + !LLIM = 0 + + ALLOCATE( U( NOPT_WEAK_CONSTRAINT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LLIM' ) + ! Don't set default bounds (dkh, 11/07/09) + !U = 0 + + ALLOCATE( WA( LENWA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'WA' ) + WA = 0 + + ELSE + + LENWA = 2 * MM * NOPT + 5 * NOPT + 11 * MM * MM + 8 * MM + + ALLOCATE( NBD( NOPT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NBD' ) + !NBD = 0 + + ALLOCATE( IWA( 3*NOPT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'IWA' ) + IWA = 0 + + ALLOCATE( LLIM( NOPT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LLIM' ) + ! Don't set default bounds (dkh, 11/07/09) + !LLIM = 0 + + ALLOCATE( U( NOPT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LLIM' ) + ! Don't set default bounds (dkh, 11/07/09) + !U = 0 + + ALLOCATE( WA( LENWA ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'WA' ) + WA = 0 + + ENDIF + + ! Return to calling program + END SUBROUTINE INIT_SETULB + + !MK-WEAK_CONSTRAINT: + SUBROUTINE GET_WEAK_CONSTRAINT_FIELDS() + + USE WEAK_CONSTRAINT_MOD, ONLY : SCALE_FACTOR_U + + INTEGER :: I + + X_WEAK_CONSTRAINT(1:NOPT) = X + X_GRADNT_WEAK_CONSTRAINT(1:NOPT) = GRADNT + + DO I = 1, N_TIMESTEPS_U + X_WEAK_CONSTRAINT( NOPT + NOPT_U*(I-1)+1:NOPT + NOPT_U*(I) ) + & = X_U(:,I) / SCALE_FACTOR_U + X_GRADNT_WEAK_CONSTRAINT( NOPT + NOPT_U*(I-1)+1: + & NOPT+ NOPT_U*(I) ) = X_GRADNT_U(:,I) * SCALE_FACTOR_U + ENDDO + + END SUBROUTINE GET_WEAK_CONSTRAINT_FIELDS + + !MK-WEAK_CONSTRAINT: + SUBROUTINE SAVE_WEAK_CONSTRAINT_FIELDS() + + USE WEAK_CONSTRAINT_MOD, ONLY : SCALE_FACTOR_U + + INTEGER :: I + + X = X_WEAK_CONSTRAINT(1:NOPT) + GRADNT = X_GRADNT_WEAK_CONSTRAINT(1:NOPT) + + DO I = 1, N_TIMESTEPS_U + X_U(:,I) = X_WEAK_CONSTRAINT( NOPT+NOPT_U*(I-1)+1: + & NOPT+NOPT_U*(I)) * SCALE_FACTOR_U + X_GRADNT_U(:,I) = X_GRADNT_WEAK_CONSTRAINT( NOPT + + & NOPT_U*(I-1)+1:NOPT+NOPT_U*(I)) / SCALE_FACTOR_U + ENDDO + + END SUBROUTINE SAVE_WEAK_CONSTRAINT_FIELDS + +!------------------------------------------------------------------------------ + + END PROGRAM INVERSE + diff --git a/code/adjoint/inverse_mod.f b/code/adjoint/inverse_mod.f new file mode 100644 index 0000000..d2657db --- /dev/null +++ b/code/adjoint/inverse_mod.f @@ -0,0 +1,5958 @@ +!$Id: inverse_mod.f,v 1.20 2012/03/04 19:34:15 daven Exp $ + MODULE INVERSE_MOD +! +!***************************************************************************** +! Module INVERSE_MOD contains all the subroutines that used to be in +! inverse.f. While having these routines in the top most program file worked +! on SGI, it didn't work on Linux, so had to move all to a module. +! (dkh, 02/05)! +! Module Variables: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Value of cost function +! (2 ) N_CALC (INTEGER) : Optimization iteration number +! (3 ) N_CALC_STOP (INTEGER) : Maximum optimization iteration number +! (4 ) F (DOUBLE) : For optimization routine +! (5 ) X (DOUBLE, ALLOC): Vector of active varialbes +! (6 ) GRADNT (DOUBLE, ALLOC): Vector of adjoint gradients +! (7 ) XP (DOUBLE, ALLOC): Vector of active strat prod varialbes +! (8 ) GRADNT_P (DOUBLE, ALLOC): Vector of strat prod adjoint gradients +! (9 ) XL (DOUBLE, ALLOC): Vector of active strat loss varialbes +! (10) GRADNT_L (DOUBLE, ALLOC): Vector of adjoint strat loss gradients +! +! Module Routines +! ============================================================================ +! (1 ) SET_SF : Initializes ICS_SF and EMS_SF +! (2 ) SET_LOG_SF : Initializes ICS_SF and EMS_SF for log scaling +! (3 ) GET_X_FROM_SF : Turns SF array into a vector X for optimization +! (4 ) GET_SF_FROM X : Turns vector X into array SF after optimization +! (5 ) GET_GRADNT_FROM_ADJ : Turns ADJ_STT array into vector GRADNT for opt. +! (6 ) MAKE_GDT_FILE : Save GRADNT values at iteration N_CALC to adjtmp/*gdt* +! (7 ) READ_GDT_FILE : Reads saved GRADNT values from previous iterations +! (8 ) MAKE_SF_FILE : Saves SF at iteration N_CALC to adjtmp/*sf* +! (9 ) READ_SF_FILE : Reads saved SF from previous iterations +! (10) EXPAND_NAME : Adds iteration number to file names +! (11) DISPLAY_STUFF : Echo various things at each iteration +! (12) SET_SF_FORFD : Set the scaling factors for finite difference test. +! (13) MAKE_CFN_FILE : Save cost function to cnf.* file +! (14) READ_CFN_FILE : Read cost function from cnf.* file +! (15) SET_OPT_RANGE : Set range of parameters to optimize +! (16) CALC_NOPT : Set range of parameters to optimize +! (17) ITER_CONDITION : Write out iteration diagnostics to gctm.iteration +! (18) MAYBE_DO_GEOS_CHEM_ADJ: For FDTEST determine if need to call adjoint +! (19) DO_SAT_DAIGS : Make satellite diagnostic files +! (20) INIT_INVERSE : Initialize allocatable arrays +! (21) CLEANUP_INVERSE : Deallocatte arrays +! +! Modules referenced by "inverse_mod.f" +! ============================================================================ +! (1 ) bpch2_mod.f : Module containing routines for binary pch file I/O +! (2 ) charpak_mod.f : Module containing string handling routines +! (3 ) error_mod.f : Module containing NaN and other error check routines +! (4 ) file_mod.f : Module containing file unit numbers & error checks +! (5 ) grid_mod.f : Module containing horizontal grid information +! (6 ) restart_mod.f : Module containing CHECK_DIMENSIONS +! (7 ) time_mod.f : Module containing routines to compute time & date +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added subroutine INIT_REGIONAL_ICS (dkh, 02/12/05) +! (3 ) Now use IDADJxxx (03/03/05) +! (4 ) Don't zero the adjoints of NO3, NIT, and NH4 +! (5 ) Now save EMS_ICS from reference run to EMS_ICS_orig, a mod variable +! Also update MAKE_GDT and MAKE_ICS to handle all emissions. +! (dkh, 03/29/05) +! (6 ) Remove all duplicate declarations of N_CALC and N_CALC_STOP. Now this +! is always treated as a module variable. (dkh, 02/15/06) +! (7 ) Update MAKE_ICS_FILE to support writing initial NOx emisions. (dkh, 08/27/06) +! (8 ) Bug fix: change N to 1 in TRACER(I,J,1) while writing scaled +! emissions. (dkh, 10/26/06) +! (9 ) BUG FIX: make ADJ_STT_FD allocatable. (dkh, 03/21/07) +! (10) Update to support LOG_OPT pre-processor option. +! (11) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! (12 ) Add / move satellite diagnostic output here (dkh, 06/25/15) +!***************************************************************************** +! + IMPLICIT NONE + +# include "define_adj.h" ! obs operators + + !==================================================================== + ! MODULE VARIABLES ( those that used to be program variables ) + !==================================================================== + !REAL*8, ALLOCATABLE :: EMS_ICS_orig(:,:,:,:) + REAL*8, ALLOCATABLE :: X(:) + REAL*8, ALLOCATABLE :: GRADNT(:) + + !For strat prod & loss SF (hml, 08/11/14) + REAL*8, ALLOCATABLE :: XP(:) + REAL*8, ALLOCATABLE :: GRADNT_P(:) + REAL*8, ALLOCATABLE :: XL(:) + REAL*8, ALLOCATABLE :: GRADNT_L(:) + + !==================================================================== + ! MODULE ROUTINES + !==================================================================== + CONTAINS + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_SF +! +!***************************************************************************** +! Subroutine SET_SF sets the intial conditions used for a GEOS_CHEM run +! (dkh, 9/16/04). +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (3 ) Switch to using IDADJxxx (dkh, 03/03/05) +! (4 ) Rename to SET_SF, replace CMN_ADJ with adjoint_array_mod +! (dkh, ks, mak, cs 06/07/09) +! (5 ) Now get first guesses from input.gcadj file (mak, 9/23/09) +! (6 ) Now use ICS_SF_DEFAULT and ICS_SF_DEFAULT instad of ICS_SF_tmp +! and EMS_SF_tmp. (dkh, 02/09/11) +! (7 ) Now support strat fluxes LADJ_STRAT and add flags to avoid accessing +! unallocated arrays (hml, dkh, 02/20/12, adj32_025) +! +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, ICS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + USE ADJ_ARRAYS_MOD, ONLY : ADCOEMS + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE ADJ_ARRAYS_MOD, ONLY : NFD, MFD, EMSFD + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + !USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_tmp, EMS_SF_tmp + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, PROD_SF0 + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF, LOSS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF, RATE_SF0 + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_DEFAULT + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE TRACERID_MOD, ONLY : IDTOX, IDTNOX + +# include "CMN_SIZE" ! Size params +# include "define_adj.h" ! obs operators + + ! local variables + INTEGER :: I + INTEGER :: J + INTEGER :: L + INTEGER :: M + + !================================================================= + ! SET_SF begins here! + !================================================================= + + + ! Set to defaults or user defined values + IF ( N_CALC_STOP .EQ. 0) THEN + + ! Set default scaling factors to 1d0 everywhere for reference run + ! (perfect model generating pseudo observations) + ICS_SF(:,:,:,:) = 1.d0 + + IF ( LADJ_EMS ) EMS_SF(:,:,:,:) = 1.d0 + + IF ( LADJ_STRAT ) THEN + PROD_SF(:,:,:,:) = 1.d0 + LOSS_SF(:,:,:,:) = 1.d0 + ENDIF + + IF ( LADJ_RRATE ) THEN + RATE_SF(:,:,:,:) = 1.d0 + ENDIF + + ELSE + + ! Now define defaults for all in input.gcadj (dkh, 02/09/11) + !EMS_SF(:,:,:,:) = 1.d0 + !ICS_SF(:,:,:,:) = 1.d0 + !! otherwise, use values from input.gcadj file for ICSFD and EMSFD + !EMS_SF(:,:,:,EMSFD) = EMS_SF_tmp + !ICS_SF(:,:,:,ICSFD) = ICS_SF_tmp +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ICS_SF (I,J,L,:) = ICS_SF_DEFAULT (:) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF ( LADJ_EMS ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + EMS_SF(I,J,M,:) = EMS_SF_DEFAULT(:) + + IF ( LADJ_STRAT ) THEN + PROD_SF(I,J,M,:) = PROD_SF_DEFAULT(:) + LOSS_SF(I,J,M,:) = LOSS_SF_DEFAULT(:) + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Added for reaction rates (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + RATE_SF(I,J,L,:) = RATE_SF_DEFAULT(:) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDIF + ENDIF + + ! the following options for PSEUDO_OBS should not become obsolete + ! We don't even have to remember to change initial SF between pseudo obs + ! and perturbed run, since the adjustment will be made automaticlally above + ! the following #if statement can be removed. + ! one thing we can add is NFD selection to EMS_SF, so that we don't have to + ! perturb all emissions, but only one. not sure if this would be good or + ! would just complicate things... + ! (mak, 9/23/09) + +#if defined ( PSEUDO_OBS ) + + ! Make the initial guess for iteration N_CALC == 1 + ! BUG FIX: make sure this happens every time the optimization + ! cycles through N_CALC = 1 as well. (mak, dkh, 09/08/09) + !IF ( N_CALC == 1 ) THEN +! IF ( N_CALC == 1 +! & .or. ( N_CALC == 0 .and. N_CALC_STOP > 1 ) ) THEN + IF ( N_CALC == 1 .or. + & ( N_CALC == 0 .and. N_CALC_STOP > 0 ) ) THEN + + ! For control parameters = initial conditions + IF ( LICS ) THEN + + ! Now enforce defaults for all set in input.gcadj (dkh, 02/09/11) + !! BUG FIX: enforce defualt scaling factors before using SF_tmp + !! (dkh, 07/30/10) + !ICS_SF(:,:,:,:) = 1.d0 + ! + !print*, 'set ICS_SF to', ICS_SF_tmp + !! Start with an initial guess for ICS_SF that is wrong + !! Let's set the default to perturb everything to avoid + !! hardwiring (mak, 6/18/09) + !! now this is done via input.gcadj file (mak, 9/23/09) + !ICS_SF(:,:,:,ICSFD) = ICS_SF_tmp !0.5d0 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ICS_SF(I,J,L,:) = ICS_SF_DEFAULT(:) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ELSEIF ( LADJ_EMS ) THEN + + ! Now enforce defaults for all set in input.gcadj (dkh, 02/09/11) + !!! BUG FIX: enforce defualt scaling factors before using SF_tmp + !! (dkh, 07/30/10) + !EMS_SF(:,:,:,:) = 1.d0 + ! + !! Start with an initial guess for EMS_SF that is wrong + !EMS_SF(:,:,1,EMSFD) = EMS_SF_tmp +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + EMS_SF(I,J,M,:) = EMS_SF_DEFAULT(:) + + IF ( LADJ_STRAT ) THEN + PROD_SF(I,J,M,:) = PROD_SF_DEFAULT(:) + LOSS_SF(I,J,M,:) = LOSS_SF_DEFAULT(:) + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Added for reaction rates (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + RATE_SF(I,J,L,:) = RATE_SF_DEFAULT(:) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ENDIF + + ENDIF + +#endif + + ! Save a copy of the initial guess of the scaling factors + ! for use later in calculating the a priori penalty term + ICS_SF0 (:,:,:,:) = ICS_SF (:,:,:,:) + + ! Add flags (hml, 02/23/12) + IF ( LADJ_EMS ) EMS_SF0 (:,:,:,:) = EMS_SF (:,:,:,:) + + IF ( LADJ_STRAT ) THEN + PROD_SF0(:,:,:,:) = PROD_SF(:,:,:,:) + LOSS_SF0(:,:,:,:) = LOSS_SF(:,:,:,:) + ENDIF + + IF ( LADJ_RRATE ) THEN + RATE_SF0(:,:,:,:) = RATE_SF(:,:,:,:) + ENDIF + + ! Return to calling program + END SUBROUTINE SET_SF +!----------------------------------------------------------------------------- + + SUBROUTINE SET_LOG_SF +! +!***************************************************************************** +! Subroutine SET_LOG_SF sets the intial conditions used for a GEOS_CHEM run +! (dkh, 9/16/04). +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (3 ) Switch to using IDADJxxx (dkh, 03/03/05) +! (4 ) Rename to SET_LOG_SF, replace CMN_ADJ with adjoint_array_mod +! (dkh, ks, mak, cs 06/07/09) +! (5 ) Now use ICS_SF_DEFAULT and ICS_SF_DEFAULT instad of ICS_SF_tmp +! and EMS_SF_tmp. (dkh, 02/09/11) +! (6 ) Add flags to avoid accessing unallocated arrays +! (hml, dkh, 02/27/12, adj32_025) +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, ICS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE ADJ_ARRAYS_MOD, ONLY : NFD, MFD, EMSFD + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + !USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_tmp, EMS_SF_tmp + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE TRACERID_MOD, ONLY : IDTOX + +# include "CMN_SIZE" ! Size params + + ! Internal varaibles + INTEGER :: I + INTEGER :: J + INTEGER :: L + INTEGER :: M + + + !================================================================= + ! SET_LOG_SF begins here! + !================================================================= + + IF ( LADJ_STRAT ) THEN + CALL ERROR_STOP(' LADJ_STRAT not yet implemented for LOG_OPT', + & ' subroutine SET_LOG_SF, inverse_mod.f ' ) + ENDIF + + IF ( LADJ_RRATE ) THEN + CALL ERROR_STOP(' LADJ_RRATE not yet implemented for LOG_OPT', + & ' subroutine SET_LOG_SF, inverse_mod.f ' ) + ENDIF + + ! Set to defaults or user defined values + ! Add flags (hml, 02/23/12) + IF ( N_CALC_STOP .EQ. 0) THEN + ! Set default scaling factors to 0d0 everywhere for reference run + ! (perfect model generating pseudo observations) + ICS_SF(:,:,:,:) = 0.d0 + IF ( LADJ_EMS ) EMS_SF(:,:,:,:) = 0.d0 + ELSE + + + ! Now define defaults for all in input.gcadj (dkh, 02/09/11) + !EMS_SF(:,:,:,:) = 0.d0 + !ICS_SF(:,:,:,:) = 0.d0 + !! otherwise, use values from input.gcadj file for ICSFD and EMSFD + !EMS_SF(:,:,:,EMSFD) = LOG(EMS_SF_tmp) + !ICS_SF(:,:,:,ICSFD) = LOG(ICS_SF_tmp) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ICS_SF(I,J,L,:) = LOG(ICS_SF_DEFAULT(:)) + + ENDDO + ENDDO + ENDDO + + ! Add flags (hml, 02/23/12) + IF ( LADJ_EMS ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + EMS_SF(I,J,M,:) = LOG(EMS_SF_DEFAULT(:)) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDIF + + +#if defined ( PSEUDO_OBS ) + + ! BUG FIX: make sure this happens every time the optimization + ! cycles through N_CALC = 1 as well. (mak, dkh, 09/08/09) + !IF ( N_CALC == 1 ) THEN +! IF ( N_CALC == 1 +! & .or. ( N_CALC == 0 .and. N_CALC_STOP > 1 ) ) THEN + IF ( N_CALC == 1 .or. + & ( N_CALC == 0 .and. N_CALC_STOP > 0 ) ) THEN + + + ! For control parameters = initial conditions + IF ( LICS ) THEN + + ! Now define defaults for all in input.gcadj (dkh, 02/09/11) + !! BUG FIX: enforce defualt scaling factors before using SF_tmp + !! (dkh, 07/30/10) + !ICS_SF(:,:,:,:) = 0.d0 + ! + !! Start with an initial guess for ICS_SF that is wrong + !ICS_SF(:,:,:,ICSFD) = LOG(ICS_SF_tmp) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ICS_SF(I,J,L,:) = LOG(ICS_SF_DEFAULT(:)) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ENDIF + IF ( LADJ_EMS ) THEN + + ! Now define defaults for all in input.gcadj (dkh, 02/09/11) + !! BUG FIX: enforce defualt scaling factors before using SF_tmp + !!! (dkh, 07/30/10) + !EMS_SF(:,:,:,:) = 0.d0 + ! + !! Start with an initial guess for EMS_SF that is wrong + !EMS_SF(:,:,1,EMSFD) = LOG(EMS_SF_tmp) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + EMS_SF(I,J,M,:) = LOG(EMS_SF_DEFAULT(:)) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ENDIF + +#endif + + ! Save a copy of the initial guess of ICS_SF for regularization + ICS_SF0(:,:,:,:) = ICS_SF(:,:,:,:) + + ! Save a copy of the initial guess of EMS_SF for regularization + ! Add flags (hml, 02/23/12) + IF ( LADJ_EMS ) EMS_SF0(:,:,:,:) = EMS_SF(:,:,:,:) + + + ! Return to calling program + END SUBROUTINE SET_LOG_SF + +!----------------------------------------------------------------------------- + + SUBROUTINE GET_X_FROM_SF +! +!***************************************************************************** +! Subroutine GET_X_FROM_ICS compiles the vector X of initial conditions from +! the array STT_IC. (dkh, 9/16/04) +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (3 ) Rename to SET_LOG_SF, replace CMN_ADJ with adjoint_array_mod +! (dkh, ks, mak, cs 06/07/09) +! (4 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, EMS_SF, MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, NFD + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size params + + ! Local variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + INTEGER :: OFFSET + + !================================================================= + ! GET_X_FROM_SF begins here! + !================================================================= + IF ( LICS ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( L - 1 ) ) + & + ( IIPAR * JJPAR * LLPAR * ( N - 1 ) ) + + ! Load X from active tracer concentrations + X(I_DUM) = ICS_SF(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + !mkeller: + ENDIF + + + !ELSEIF ( LADJ_EMS ) THEN + IF ( LADJ_EMS ) THEN + + IF ( ITS_A_TAGCO_SIM() ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, 1 + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + ! Load X from active tracer concentrations + X(I_DUM) = EMS_SF(I,J,M,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF ( NNEMS == 2 ) THEN + N = 2 + print*, IIPAR*JJPAR*MMSCL,'adding backgnd component to X' + X(IIPAR*JJPAR*MMSCL+1) = EMS_SF(1,1,1,N) + ENDIF + + ELSE +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NNEMS + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + !mkeller: get proper offset for I_DUM + IF ( LICS ) I_DUM = + & I_DUM + IIPAR * JJPAR * LLPAR * N_TRACERS + + ! Load X from active tracer concentrations + X(I_DUM) = EMS_SF(I,J,M,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + OFFSET = IIPAR * JJPAR * MMSCL * NNEMS + + IF ( LADJ_STRAT ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NSTPL + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + ! Load X from active tracer concentrations + XP(I_DUM) = PROD_SF(I,J,M,N) + XL(I_DUM) = LOSS_SF(I,J,M,N) + IF ( I == IFD.and.J == JFD.and.N == NFD )THEN + print*, 'inverse_0: I_DUM = ' , + & I_DUM + print*, 'inverse_0: XL(I_DUM) = ' , + & XL(I_DUM) + print*, 'inverse_0: LOSS_SF = ' , + & LOSS_SF(I,J,M,N) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + X( IIPAR*JJPAR*MMSCL*NNEMS + 1 : + & IIPAR*JJPAR*MMSCL*(NSTPL+NNEMS)) = XP(:) + X( IIPAR*JJPAR*MMSCL*(NSTPL+NNEMS) + 1 : + & IIPAR*JJPAR*MMSCL*(2*NSTPL+NNEMS)) = XL(:) + + ! make OFFSET total number of emissions + strat PL scale factors + OFFSET = IIPAR*JJPAR*MMSCL*(2*NSTPL+NNEMS) + + ENDIF + + ! Reaction rates (tww) + IF ( LADJ_RRATE ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM ) + DO N = 1, NRRATES + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + I_DUM = I + ( IIPAR * (J - 1) ) + & + ( IIPAR * JJPAR * (L - 1) ) + & + ( IIPAR * JJPAR * LLPAR * (N - 1) ) + & + OFFSET + !I_DUM = I_DUM + IIPAR * JJPAR * MMSCL * NNEMS + ! Combine to the I_DUM equation (hml, 06/10/13) + !I_DUM = I_DUM + OFFSET + + ! Load X from active variables + X(I_DUM) = RATE_SF(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ENDIF + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_X_FROM_SF + +!----------------------------------------------------------------------------- + + SUBROUTINE GET_SF_FROM_X +! +!***************************************************************************** +! Subroutine GET_SF_FROM_X compiles the array of scaling factors from +! the vector X. (dkh, 9/16/04) +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (3 ) Rename to SET_LOG_SF, replace CMN_ADJ with adjoint_array_mod +! (dkh, ks, mak, cs 06/07/09) +! (4 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, EMS_SF, NNEMS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, NFD + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size params + + ! Local Variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + INTEGER :: OFFSET + + !================================================================= + ! GET_SF_FROM_X begins here! + !================================================================= + IF ( LICS ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( L - 1 ) ) + & + ( IIPAR * JJPAR * LLPAR * ( N - 1 ) ) + + ! Update the tracer concentrations from X + ICS_SF(I,J,L,N) = X(I_DUM) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + !ELSEIF ( LADJ_EMS ) THEN +!mkeller: + IF ( LADJ_EMS ) THEN + IF ( ITS_A_TAGCO_SIM() ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, 1 + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + ! Update the tracer concentrations from X + EMS_SF(I,J,M,N) = X(I_DUM) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF ( NNEMS == 2 ) THEN + N = 2 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Update the tracer concentrations from X + EMS_SF(I,J,M,N) = X(IIPAR*JJPAR*MMSCL+1) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ELSE + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NNEMS + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + !mkeller: get proper offset for I_DUM + IF ( LICS ) I_DUM = + & I_DUM + IIPAR * JJPAR * LLPAR * N_TRACERS + + ! Update the tracer concentrations from X + EMS_SF(I,J,M,N) = X(I_DUM) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + OFFSET = IIPAR * JJPAR * MMSCL * NNEMS + + ! For strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + XP(:) = X(IIPAR*JJPAR*MMSCL*NNEMS+1: + & IIPAR*JJPAR*MMSCL*(NNEMS+NSTPL)) + XL(:) = X(IIPAR*JJPAR*MMSCL*(NNEMS+NSTPL)+1: + & IIPAR*JJPAR*MMSCL*(NNEMS+2*NSTPL)) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NSTPL + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + + ! Update the tracer concentrations from X + PROD_SF(I,J,M,N) = XP(I_DUM) + LOSS_SF(I,J,M,N) = XL(I_DUM) + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + OFFSET = IIPAR*JJPAR*MMSCL*(NNEMS+2*NSTPL) + + ENDIF + + ! Reaction rates (tww) + IF ( LADJ_RRATE ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM ) + DO N = 1, NRRATES + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + I_DUM = I + ( IIPAR * (J - 1) ) + & + ( IIPAR * JJPAR * (L - 1 ) ) + & + ( IIPAR * JJPAR * LLPAR * (N - 1) ) + !I_DUM = I_DUM + IIPAR * JJPAR * MMSCL * NNEMS + ! Combine to the I_DUM equation (hml, 06/10/13) + I_DUM = I_DUM + OFFSET + + ! Update active variables from X + RATE_SF(I,J,L,N) = X(I_DUM) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ENDIF + ENDIF + + ! Return to calling program + END SUBROUTINE GET_SF_FROM_X + +!----------------------------------------------------------------------------- + + SUBROUTINE GET_GRADNT_FROM_ADJ +! +!***************************************************************************** +! Subroutine GET_GRADNT_FROM_ADJ compiles the gradient vector from the array +! of adjoint values. (dkh, 9/16/04) +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (3 ) Don't zero the NIT, NH4 and NO3 gradnts (dkh, 03/03/05) +! (4 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ, LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size params + + ! Local Variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + INTEGER :: I_DUM_TMP + INTEGER :: OFFSET + + !================================================================= + ! GET_GRADNT_FROM_ADJ begins here! + !================================================================= + + IF ( LICS ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( L - 1 ) ) + & + ( IIPAR * JJPAR * LLPAR * ( N - 1 ) ) + + GRADNT(I_DUM) = ICS_SF_ADJ(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !ELSEIF( LADJ_EMS ) THEN +!mkeller: + ENDIF + IF ( LADJ_EMS ) THEN + + IF ( ITS_A_TAGCO_SIM() ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, 1 + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + GRADNT(I_DUM) = EMS_SF_ADJ(I,J,M,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF( NNEMS == 2 ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 2, 2 !NNEMS=2, but get zonal average for bkg + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = (IIPAR*JJPAR*MMSCL) + 1 + + ! KLUDGE: Ask MAK about this. + ! sum zonally + GRADNT(I_DUM) = GRADNT(I_DUM) + EMS_SF_ADJ(I,J,M,N) + + ENDDO + ENDDO + ENDDO + + ! Update to include CH4 oxidation (zhej, 01/16/12, adj32_017) + ! OLD: + !! KLUDGE: Ask MAK about this. + !! average zonally and per layer + !GRADNT(I_DUM) = GRADNT(I_DUM) + & ! / ( IIPAR * JJPAR * LLPAR * MMSCL) + ! NEW: + GRADNT(I_DUM) = GRADNT(I_DUM) / + & ( IIPAR * JJPAR * MMSCL) + + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ELSE + !mkeller: for now don't account for stratospheric production + IF ( .NOT. LADJ_STRAT ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NNEMS + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) +! mkeller: get proper offset for I_DUM + IF ( LICS ) I_DUM = + & I_DUM + IIPAR * JJPAR * LLPAR * N_TRACERS + + GRADNT(I_DUM) = EMS_SF_ADJ(I,J,M,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + OFFSET = IIPAR * JJPAR * MMSCL * NNEMS + + ELSEIF ( LADJ_STRAT ) THEN + + ! For strat prod & loss (hml, 08/29/11) + I_DUM_TMP = IIPAR * JJPAR * MMSCL * NNEMS + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NSTPL + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + GRADNT_P(I_DUM) = PROD_SF_ADJ(I,J,M,N) + GRADNT_L(I_DUM) = LOSS_SF_ADJ(I,J,M,N) + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + GRADNT( I_DUM_TMP + 1 : + & I_DUM_TMP + IIPAR * JJPAR * MMSCL * NSTPL ) + & = GRADNT_P(:) + GRADNT( I_DUM_TMP + IIPAR * JJPAR * MMSCL * NSTPL + 1 : + & IIPAR * JJPAR * MMSCL * 2 * NSTPL ) + & = GRADNT_L(:) + + !OFFSET = # of emissions + # of strat prod loss + OFFSET = IIPAR * JJPAR * MMSCL * ( 2 * NSTPL + NNEMS ) + + ENDIF + + !ELSEIF ( LADJ_RRATE ) THEN + IF ( LADJ_RRATE ) THEN + + ! For reaction rates (tww, 05/15/12) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM ) + DO N = 1, NRRATES + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + I_DUM = I + ( IIPAR * (J - 1) ) + & + ( IIPAR * JJPAR * (L - 1) ) + & + ( IIPAR * JJPAR * LLPAR * (N - 1) ) + & + OFFSET + !I_DUM = I_DUM + IIPAR*JJPAR*MMSCL*NNEMS + ! Combine to the I_DUM equation (hml, 06/10/13) + !I_DUM = I_DUM + OFFSET + GRADNT(I_DUM) = RATE_SF_ADJ(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDIF + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_GRADNT_FROM_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_GDT_FILE( ) +! +!****************************************************************************** +! Subroutine MAKE_GDT_FILE creates a binary file of ADJ_xxx +! (dkh, 9/17/04) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! (2 ) ICS_SF_ADJ : Array of adjoint gradients to be written +! (3 ) EMS_SF_ADJ : Array of adjoint gradients to be written +! +! NOTES: +! (1 ) Just like MAKE_OBS_FILE except +! - write to .adj. file +! (2 ) Changed name to MAKE_GDT_FILE. Now the .adj. files are trajectories, +! and the .gdt. files are final gradients (dkh, 10/03/04) +! (3 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (4 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (5 ) Now use CATEGORY = 'IJ-GDE-$' for 'EMISSIONS' case. (dkh, 03/29/05) +! (6 ) No longer pass COST_FUNC in the header; use cnf.* files. (dkh, 02/13/06) +! (7 ) Rename everything, replace CMN_ADJ, move nonessential stuff +! to diagnostic files (dkh, ks, mak, cs 06/07/09) +! (8 ) Add normalized gradients IJ-GDEN$ (dkh, 05/06/10) +! (9 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ, LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ID_PROD, ID_LOSS + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + ! Added for reaction rate sensitivities (tww, 05/08/12) + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ, ID_RRATES + USE GCKPP_ADJ_GLOBAL, ONLY : NCOEFF, NCOEFF_EM, JCOEFF + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NEMIS(NCS) + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, M, N, NK + INTEGER :: NP, NL + INTEGER :: YYYY, MM, DD, HH, SS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) + CHARACTER(LEN=255) :: FILENAME + REAL*4 :: PROD_3D(IIPAR,JJPAR,MMSCL) + REAL*4 :: LOSS_3D(IIPAR,JJPAR,MMSCL) + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + ! Added for reaction rate sensitivity (tww, 05/08/12) + REAL*4 :: RATE_3D(IIPAR,JJPAR,LLPAR) + + CHARACTER(LEN=20) :: OUTPUT_GDT_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_GDT_FILE begins here! + !================================================================= + + ! Clear intermediate arrays + EMS_3D (:,:,:) = 0d0 + PROD_3D(:,:,:) = 0d0 + LOSS_3D(:,:,:) = 0d0 + + ! Hardwire output file for now + OUTPUT_GDT_FILE = 'gctm.gdt.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM GDT File: ' // + & 'Final gradient values ' + UNIT = 'none' + CATEGORY = 'IJ-GDT-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_GDT_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the OPTDATA_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_GDT_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + IF ( LICS ) THEN + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = 1, N_TRACERS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + TRACER(I,J,L) = ICS_SF_ADJ (I,J,L,N) + ELSE + TRACER(I,J,L) = 0d0 + ENDIF + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + ENDIF + IF ( LADJ_EMS ) THEN + + ! Reset CATEGORY as labeling in gamap is different + CATEGORY = 'IJ-GDE-$' + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = 1, NNEMS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + EMS_3D(I,J,M) = REAL(EMS_SF_ADJ(I,J,M,N)) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, EMS_3D ) + ENDDO + +! Reset CATEGORY as labeling in gamap is different + CATEGORY = 'IJ-GDEN$' + UNIT = 'none' + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = 1, NNEMS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + EMS_3D(I,J,M) = REAL(EMS_SF_ADJ(I,J,M,N)) + & / COST_FUNC + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, EMS_3D ) + ENDDO + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + + !============================================================== + ! Write each observed quantity to the observation file + !============================================================== + DO N = 1, NSTPL + NP = ID_PROD(N) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + PROD_3D(I,J,M) = REAL(PROD_SF_ADJ(I,J,M,N)) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !Temporarily store quantities in the PROD_3D, LOSS_3D array + CATEGORY = 'IJ-GDP-$' + UNIT = 'J' + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NP, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, PROD_3D ) + + ENDDO + + ! Strat loss + DO N = 1, NSTPL + NL = ID_LOSS(N) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + LOSS_3D(I,J,M) = REAL(LOSS_SF_ADJ(I,J,M,N)) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CATEGORY = 'IJ-GDL-$' + UNIT = 'J' + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NL, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, LOSS_3D ) + + + ENDDO + ENDIF + ENDIF + + ! Added block for reaction rate sensitivity output (tww, 05/08/12) + IF ( LADJ_RRATE ) THEN + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = NCOEFF_EM+1, NCOEFF + + ! Temporarily store quantities in the TRACER array + CATEGORY = 'IJ-RATE$' + ! Before it is normalized (hml, 06/11/13) + !UNIT = 'none' + UNIT = 'J' + + NK = ID_RRATES(N-NCOEFF_EM) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + RATE_3D(I,J,L) = REAL(RATE_SF_ADJ(I,J,L,N-NCOEFF_EM)) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NK, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, RATE_3D ) + ENDDO + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_GDT_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_GDT_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_GDT_FILE ( ) +! +!****************************************************************************** +! Subroutine READ_GDT_FILE reads the gctm.gdt file into ADJ_xxx +! (dkh, 9/17/04) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! +! Notes +! (1 ) now called GDT instead of ADJ +! (2 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (3 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (4 ) Now use CATEGORY = 'IJ-GDE-$' for EMISSIONS case. (dkh, 03/29/05) +! (5 ) No longer pass COST_FUNC in the header; use cnf.* files. (dkh, 02/13/06) +! (6 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ,LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + USE ADJ_ARRAYS_MOD, ONLY : ID_RRATES + + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_MOD, ONLY : LPRT + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Local Variables + INTEGER :: I, IOS, J, L, M, N, XX + REAL*4, ALLOCATABLE :: TEMP(:,:,:) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: N_LICS, N_EMS, N_RATE + INTEGER :: N_STRAT_PROD, N_STRAT_LOSS + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + CHARACTER(LEN=20) :: INPUT_GDT_FILE + + !================================================================= + ! READ_GDT_FILE begins here! + !================================================================= + + ! Hardwire output file for now + INPUT_GDT_FILE = 'gctm.gdt.NN' + + ! Initialize some variables + N_LICS = 1 + N_EMS = 1 + N_STRAT_PROD = 1 + N_STRAT_LOSS = 1 + N_RATE = 1 + IOS = 0 + + IF ( LLPAR > MMSCL ) THEN + XX = LLPAR + ELSE + XX = MMSCL + ENDIF + + ALLOCATE(TEMP(IIPAR,JJPAR,XX)) + TEMP(:,:,:) = 0e0 + + !================================================================= + ! Open gradient file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_GDT_FILE ) + + ! Replace NN tokens in FILENAME w/ actual values + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add OPTDATA_DIR prefix to FILENAME + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'G D T F I L E I N P U T' + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_GDT_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read adjoints -- store in the TRACER array + !================================================================= + DO WHILE ( .NOT. IOS < 0 ) + + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES , LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TEMP(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:6') + + !============================================================== + ! Assign data from the TRACER array to the ADJ_STT array. + !============================================================== + + SELECT CASE ( CATEGORY(1:8) ) + + ! Only process observation data (i.e. aerosol and precursors) + CASE ( 'IJ-GDT-$' ) + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + + ICS_SF_ADJ(:,:,:,N_LICS) = TEMP(:,:,1:LLPAR) + + N_LICS = N_LICS + 1 + + ! Only process observation data (i.e. aerosol and precursors) + CASE ( 'IJ-GDE-$' ) + + EMS_SF_ADJ(:,:,:,N_EMS) = TEMP(:,:,1:MMSCL) + + N_EMS = N_EMS + 1 + + ! Only process observation data (i.e. aerosol and precursors) + CASE ( 'IJ-GDP-$' ) + + PROD_SF_ADJ(:,:,:,N_STRAT_PROD) = TEMP(:,:,1:MMSCL) + + N_STRAT_PROD = N_STRAT_PROD + 1 + + ! Only process observation data (i.e. aerosol and precursors) + CASE ( 'IJ-GDL-$' ) + + LOSS_SF_ADJ(:,:,:,N_STRAT_LOSS) = TEMP(:,:,1:MMSCL) + + N_STRAT_LOSS = N_STRAT_LOSS + 1 + + CASE ( 'IJ-RATE$' ) + + RATE_SF_ADJ(:,:,:,N_RATE) = TEMP(:,:,1:LLPAR) + + N_RATE = N_RATE + 1 + + END SELECT + ENDDO + + IF ( LICS ) THEN + + IF ( N_TRACERS .NE. N_LICS - 1 ) CALL ERROR_STOP( + & ' Invalid number LICS found ' , 'READ_GDT_FILE' ) + + ENDIF + + IF ( LADJ_EMS ) THEN + + IF ( NNEMS .NE. N_EMS - 1 ) CALL ERROR_STOP( + & ' Invalid number EMS found ' , 'READ_GDT_FILE' ) + + ENDIF + + IF ( LADJ_STRAT ) THEN + + IF ( NSTPL .NE. N_STRAT_PROD - 1 ) CALL ERROR_STOP( + & ' Invalid number STRAT_PROD found ' , 'READ_GDT_FILE' ) + + IF ( NSTPL .NE. N_STRAT_LOSS - 1 ) CALL ERROR_STOP( + & ' Invalid number STRAT_LOSS found ' , 'READ_GDT_FILE' ) + + ENDIF + + IF ( LADJ_RRATE ) THEN + + IF ( NRRATES .NE. N_RATE - 1 ) CALL ERROR_STOP( + & ' Invalid number RRATES found ' , 'READ_GDT_FILE' ) + + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_GDT_FILE: read file' ) + + ! Return to calling program + END SUBROUTINE READ_GDT_FILE + +! needs to be updated +!----------------------------------------------------------------------- +! +! SUBROUTINE MAKE_GDT_DIAG_FILE( ) +!! +!!****************************************************************************** +!! Subroutine MAKE_GDT_DIAG_FILE creates a binary file of daignostics +!! relatied to the adjoint gradients. (dkh, 06/07/09) +!! (dkh, 9/17/04) +!! +!! Module Variable as Input: +!! ============================================================================ +!! (1 ) N_CALC : Current iteration number +!! (2 ) ICS_SF_ADJ : Array of adjoint gradients to be written +!! (3 ) EMS_SF_ADJ : Array of adjoint gradients to be written +!! (4 ) ADJ_BURNEMIS : Array of biomass burning sensitivities +!! (5 ) ADJ_BIOFUEL : Array of biofuel sensitivities +!! (6 ) ADJ_EMISRR : +!! (7 ) ADJ_EMISRRB : +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! References to F90 modules +! USE ADJ_ARRAYS_MOD, ONLY : ADJ_BURNEMIS +! USE ADJ_ARRAYS_MOD, ONLY : ADJ_BIOFUEL +! USE ADJ_ARRAYS_MOD, ONLY : ADJ_EMISRR +! USE ADJ_ARRAYS_MOD, ONLY : ADJ_EMISRRB +! USE BPCH2_MOD +! USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR +! USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU +! USE BIOMASS_MOD, ONLY : NBIOTRCE +! USE BIOFUEL_MOD, ONLY : NBFTRACE +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN" ! LPRT +!# include "comode.h" ! NEMIS(NCS) +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, M, N +! INTEGER :: YYYY, MM, DD, HH, SS +! REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +! REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) +! CHARACTER(LEN=255) :: FILENAME +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! CHARACTER(LEN=20) :: OUTPUT_GDT_FILE +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! +! !================================================================= +! ! MAKE_GDT_FILE begins here! +! !================================================================= +! +! ! Clear intermediate arrays +! EMS_3D(:,:,:) = 0d0 +! +! ! Hardwire output file for now +! OUTPUT_GDT_FILE = 'gctm.gdt.diag.NN' +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM GDT File: ' // +! & 'Gradient diagnostics ' +! LONRES = DISIZE +! LATRES = DJSIZE +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the adjoint file for output -- binary punch format +! !================================================================= +! +! ! Copy the output observation file name into a local variable +! FILENAME = TRIM( OUTPUT_GDT_FILE ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! +! ! Add the OPTDATA_DIR prefix to the file name +! FILENAME = TRIM( DIAGADJTMP_DIR ) // TRIM( FILENAME ) +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_GDT_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +! !================================================================= +! ! Normalized sensitivies +! !================================================================= +! +! ! Reset CATEGORY as labeling in gamap is different +! CATEGORY = 'IJ-GDEN$' +! UNIT = '%' +! +! !================================================================= +! ! Write each observed quantity to the observation file +! !================================================================= +! DO N = 1, NNEMS +! +! ! Temporarily store quantities in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M ) +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! EMS_3D(I,J,M) = REAL(ADJ_EMS(I,J,M,N)) / COST_FUNC +! & * 100d0 +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N + NNEMS, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ENDDO +! +! +! !================================================================= +! ! Normalized VOC sensitivies - EMISRR (anthro hydrocarbons) +! !================================================================= +! CATEGORY = 'DEMISRR' +! DO N = 1, NEMIS(NCS) +! +! ! Temporarily store quantities in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! EMS_3D(I,J,1) = REAL(ADJ_EMISRR(I,J,N)) / COST_FUNC +! & * 100d0 +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! dkh debug +! print*, ' ADJ EMISRR = ', maxval(adj_emisrr(:,:,n)), n +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! ENDDO +! +! +! !================================================================= +! ! Normalized VOC sensitivies - EMISRRB (biogenic hydrocarbons) +! !================================================================= +! CATEGORY = 'DEMISRRB' +! DO N = 1, NEMIS(NCS) +! +! ! Temporarily store quantities in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! EMS_3D(I,J,1) = REAL(ADJ_EMISRRB(I,J,N)) / COST_FUNC +! & * 100d0 +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! dkh debug +! print*, ' ADJ EMISRRB = ', maxval(adj_emisrrb(:,:,n)), n +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! ENDDO +! +! !================================================================= +! ! Normalized VOC sensitivies - BOIFUEL +! !================================================================= +! CATEGORY = 'DBIOFUEL' +! DO N = 1, NBFTRACE +! +! ! Temporarily store quantities in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! EMS_3D(I,J,1) = REAL(ADJ_BIOFUEL(I,J,N)) / COST_FUNC +! & * 100d0 +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ! dkh debug +! print*, ' ADJ BIOFUEL= ', maxval(ADJ_BIOFUEL(:,:,n)), n +! +! ENDDO +! +! +! !================================================================= +! ! Normalized VOC sensitivies - BURNEMIS +! !================================================================= +! CATEGORY = 'DBURNEMIS' +! DO N = 1, NBIOTRCE +! +! ! Temporarily store quantities in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! EMS_3D(I,J,1) = REAL(ADJ_BURNEMIS(I,J,N)) / COST_FUNC +! & * 100d0 +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ! dkh debug +! print*, ' ADJ BURNEMIS= ', maxval(ADJ_BURNEMIS(:,:,n)), n +! +! ENDDO +! +! ! Close file +! CLOSE( IU_RST ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_GDT_DIAG_FILE: wrote file' ) +! +! ! Return to calling program +! END SUBROUTINE MAKE_GDT_DIAG_FILE +! +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_SF_FILE ( ) +! +!****************************************************************************** +! Subroutine MAKE_SF_FILE creates a binary file of STT_IC or EMS_ICS +! (dkh, 9/17/04) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! (2 ) ICS_SF : Initial conditions scaling factors +! (3 ) EMS_SF : Emissions scaling factors +! +! NOTES: +! (1 ) Just like MAKE_ADJ_FILE except +! - write to .ics. file +! (2 ) Add support for ACTIVE_VARS == 'EMISSIONS' case (dkh, 11/27/04) +! (3 ) Add support for ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (4 ) Change UNIT to unitless and change title to Scale factors (dkh, 03/06/05) +! (5 ) Change output for ACTIVE_VARS == 'EMISSIONS' case. +! Now use label IJ-EMS-$, and update gamap code accordingly. +! First write the scaling factors, in consecutive species. Temporal +! varations in the emissions, if any, will be in the L direction. +! Next, write out the optimized emissions themselves. +! Finally, write out the difference between orig and optimized emissions. +! (dkh, 03/28/05) +! (6 ) Use EMS_orig instead of ESO4_an_orig so that we can loop over N. +! (7 ) Update to add support for writing NOx emissions. (dkh, 08/27/06) +! (8 ) Only write the value of the scaling facotr in locations where the +! actual emission is greater than zero. Also include the current +! scale emissions themselves in every *ics* file. (dkh, 09/22/06) +! (9 ) Add suppport for LOG_OPT +! (10) Standardize units for saving emissions. (dkh, 06/16/07) +! (11) Add option to print prior and posterior emissions totals. (dkh, 06/16/07) +! (12) Change names, replace CMN_ADJ. (dkh, ks, mak, cs 06/08/09) +! (13) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, ICS_SF, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_TOTAL, EMS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : ID_PROD, ID_LOSS + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF, ID_RRATES + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + USE GCKPP_ADJ_GLOBAL, ONLY : NCOEFF, NCOEFF_EM, JCOEFF + + USE BPCH2_MOD + USE DIRECTORY_MOD, ONLY : TEMP_DIR + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TIME_MOD, ONLY : GET_TS_EMIS + USE TIME_MOD, ONLY : GET_TAUb, GET_TAUe + USE TRACER_MOD, ONLY : N_TRACERS + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! EMISRN +# include "comode.h" ! NEMIS(NCS) + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, M, N, NK + INTEGER :: NP, NL + INTEGER :: YYYY, MM, DD, HH, SS + INTEGER :: NOFFSET + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + CHARACTER(LEN=255) :: FILENAME + REAL*8 :: TEMP + REAL*8 :: NEMIS_DT + REAL*8 :: USA_MASK(IIPAR,JJPAR) + REAL*8 :: EMS_TOTAL(NNEMS) + REAL*4 :: EMS_PERCENT(IIPAR,JJPAR,NNEMS) + LOGICAL, PARAMETER :: LPRINT_TOTAL = .TRUE. + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: OUTPUT_SF_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + ! Parameters + REAL*8, PARAMETER :: SEC_PER_YEAR = 3.1536d7 + REAL*8, PARAMETER :: MIN_PER_YEAR = 5.2560d5 + REAL*8, PARAMETER :: TG_PER_KG = 1d-09 + + !================================================================= + ! MAKE_SF_FILE begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_SF_FILE = 'gctm.sf.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM SF File: ' // + & 'Scale Factors' + UNIT = 'unitless' + CATEGORY = 'IJ-ICS-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_SF_FILE ) + + ! Replace NN token w/ actual value + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add OPTDATA_DIR prefix to FILENAME + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_SF_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + IF ( LICS ) THEN + + CATEGORY = 'IJ-ICS-$' + + !================================================================= + ! Write each observed quantity to the ics file + !================================================================= + DO N = 1, N_TRACERS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + IF ( ITS_IN_THE_TROP(I,J,L) ) THEN + TRACER(I,J,L) = ICS_SF(I,J,L,N) + ELSE + TRACER(I,J,L) = 1d0 + ENDIF + ENDDO + ENDDO + ENDDO + +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + ENDIF + + IF ( LADJ_EMS ) THEN + + CATEGORY = 'IJ-EMS-$' + UNIT = 'unitless' + + !================================================================= + ! Write each observed quantity to the ics file + !================================================================= + DO N = 1, NNEMS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M , TEMP ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + TRACER(I,J,M) = EMS_SF(I,J,M,N) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + IF ( LADJ_STRAT ) THEN + + !============================================================== + ! Write each observed quantity to the ics file + !============================================================== + DO N = 1, NSTPL + NP = ID_PROD(N) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,M) = PROD_SF(I,J,M,N) + ENDDO + ENDDO + ENDDO + +!$OMP END PARALLEL DO + + !Temporarily store quantities in the TRACER array + CATEGORY = 'IJ-STRP$' + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NP, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + DO N = 1, NSTPL + NP = ID_LOSS(N) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,M) = LOSS_SF(I,J,M,N) + ENDDO + ENDDO + ENDDO + +!$OMP END PARALLEL DO + + CATEGORY = 'IJ-STRL$' + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NL, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, TRACER ) + + ENDDO + ENDIF + + IF ( LADJ_RRATE ) THEN + + !============================================================== + ! Write each observed quantity to the ics file + !============================================================== + DO N = NCOEFF_EM+1, NCOEFF + + NK = ID_RRATES(N-NCOEFF_EM) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,L) = RATE_SF(I,J,L,N-NCOEFF_EM) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + CATEGORY = 'IJ-RATSF' + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NK, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + ENDIF + + ENDIF + + + !### Debug + + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_SF_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_SF_FILE +! needs to be updated: +!!------------------------------------------------------------------------------ +! +! SUBROUTINE MAKE_SF_DIAG_FILE ( ) +!! +!!****************************************************************************** +!! Subroutine MAKE_SF_DIAG_FILE creates a binary file of diagnostics +!! related to scaling factor values. (dkh, 06/08/09) +!! +!! Module Variable as Input: +!! ============================================================================ +!! (1 ) N_CALC : Current iteration number +!! (2 ) ICS_SF : Initial conditions scaling factors +!! (3 ) EMS_SF : Emissions scaling factors +!! +!! NOTES: +!! (1) Split this off from MAKE_ICS_FILE (dkh, ks, mak, cs 06/08/09) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, ICS_SF +! USE BPCH2_MOD +! USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP +! USE DIRECTORY_MOD, ONLY : TEMP_DIR +! USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJTMP_DIR +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET, GET_AREA_CM2 +! USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU +! USE TIME_MOD, ONLY : GET_TS_CHEM +! USE TIME_MOD, ONLY : GET_TS_EMIS +! USE TIME_MOD, ONLY : GET_TAUb, GET_TAUe +! USE TRACERID_MOD, ONLY : IDTNH3, IDTNOX, IDTBCPI, IDTSO2 +! USE SULFATE_MOD, ONLY : EMS_orig +! USE LIGHTNING_NOX_MOD, ONLY : EMS_orig_li +! USE EMISSIONS_MOD, ONLY : BIOFUEL_orig +! USE EMISSIONS_MOD, ONLY : BURNEMIS_orig +! USE EMISSIONS_MOD, ONLY : EMISRR_orig +! USE EMISSIONS_MOD, ONLY : EMISRRB_orig +! USE BIOMASS_MOD, ONLY : NBIOTRCE +! USE BIOFUEL_MOD, ONLY : NBFTRACE +! USE DAO_MOD, ONLY : BXHEIGHT +! +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN" ! LPRT, LLIGHTNOX +!# include "CMN_O3" ! EMISRN +!# include "comode.h" ! NEMIS(NCS) +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, M, N +! INTEGER :: YYYY, MM, DD, HH, SS +! INTEGER :: NOFFSET +! REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +! REAL*4 :: TRACER_VOC(IIPAR,JJPAR,20) +! REAL*4 :: TRACER_US(IIPAR,JJPAR,LLPAR) +! CHARACTER(LEN=255) :: FILENAME +! REAL*8 :: TEMP +! REAL*8 :: NEMIS_DT +! REAL*8 :: USA_MASK(IIPAR,JJPAR) +! REAL*8 :: EMS_TOTAL(NNEMS) +! REAL*4 :: EMS_PERCENT(IIPAR,JJPAR,NNEMS) +! LOGICAL, PARAMETER :: LPRINT_TOTAL = .TRUE. +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! CHARACTER(LEN=20) :: OUTPUT_SF_DIAG_FILE +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! +! ! Parameters +! REAL*8, PARAMETER :: SEC_PER_YEAR = 3.1536d7 +! REAL*8, PARAMETER :: MIN_PER_YEAR = 5.2560d5 +! REAL*8, PARAMETER :: TG_PER_KG = 1d-09 +! +! !================================================================= +! ! MAKE_SF_DIAG_FILE begins here! +! !================================================================= +! +! ! Hardwire output file for now +! OUTPUT_SF_DIAG_FILE = 'gctm.sf.diag.NN' +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM SF File: ' // +! & 'Scale Factors Diagnostics' +! UNIT = 'unitless' +! LONRES = DISIZE +! LATRES = DJSIZE +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the adjoint file for output -- binary punch format +! !================================================================= +! +! ! Copy the output observation file name into a local variable +! FILENAME = TRIM( OUTPUT_SF_DIAG_FILE ) +! +! ! Replace NN token w/ actual value +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! +! ! Add OPTDATA_DIR prefix to FILENAME +! FILENAME = TRIM( DIAGADJTMP_DIR ) // TRIM( FILENAME ) +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_SF_DIAG_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +! IF ( NEMS ) THEN +! +! +! ! Also write the actual emissions. +! ! Go ahead and include this every time. +! CATEGORY = 'IJ-EM0-$' +! UNIT = 'molecule/cm2/s' +! +! ! emdt / sim = hr / sim * min / hr * emdt / min +! NEMIS_DT = ( GET_TAUe() - GET_TAUb() ) * 60d0 / GET_TS_EMIS() +! +! DO N = 1, NNEMS +! +! ! Compile TRACER [ molec / cm2 / s ] +! ! Get the actual emission in the current cell +! ! Original emissions are in EMS_orig, but in a variety of unit +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! lightning NOx +! IF ( N == IDADJEMS_ENOxli ) THEN +! +! ! Add to prevent allocation segfault (dkh, 10/10/08) +! IF ( LLIGHTNOX ) THEN +! +! ! molec NOx / cm2 / s total sim -> molec NOx / cm2 / s +! TRACER(I,J,N) = EMS_orig_li(I,J) +! & / NEMIS_DT ! number of emissions +! +! ELSE +! TRACER(I,J,N) = 0D0 +! ENDIF +! +! +! ! soil NOx +! ELSEIF ( N == IDADJEMS_ENOxso ) THEN +! +! ! molec NOx / cm2 / s total -> molec / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & / NEMIS_DT ! number of emissions +! +! +! ! BC / OC +! ELSEIF ( N == IDADJEMS_BCan .or. N == IDADJEMS_OCan .or. +! & N == IDADJEMS_BCbb .or. N == IDADJEMS_OCbb .or. +! & N == IDADJEMS_BCbf .or. N == IDADJEMS_OCbf ) +! & THEN +! +! ! Convert from kg / yr to molec C / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * XNUMOL(IDTBCPI) +! & / GET_AREA_CM2(J) +! & / SEC_PER_YEAR +! +! +! ! Anth NOx +! ELSEIF ( N == IDADJEMS_ENOx1 .or. N == IDADJEMS_ENOx2 ) +! & THEN +! +! ! Convert from kg / box / emdt to molec / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * XNUMOL(IDTNOX) +! & / GET_AREA_CM2(J) +! & / ( GET_TS_EMIS() * 60.d0 ) ! seconds per emdt +! +! ! NH3 +! ELSEIF ( N == IDADJEMS_ENH3_an .or. +! & N == IDADJEMS_ENH3_na .or. +! & N == IDADJEMS_ENH3_bb .or. +! & N == IDADJEMS_ENH3_bf ) +! & THEN +! +! ! Convert from kg NH3 / box / s to molec / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * XNUMOL(IDTNH3) +! & / GET_AREA_CM2(J) +! +! ! SO2 +! ELSEIF ( N == IDADJEMS_ESO2_bb .or. +! & N == IDADJEMS_ESO2_bf .or. +! & N == IDADJEMS_ESO2_sh ) +! & THEN +! +! ! Convert from kg SO2 / box / s to molec / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * XNUMOL(IDTSO2) +! & / GET_AREA_CM2(J) +! +! ! Volcano SO2 emissions (dkh, cklee 09/14/08) +! ELSEIF ( N == IDADJEMS_ESO2_ev .or. !(added,cklee) +! & N == IDADJEMS_ESO2_nv ) !(added,cklee) +! & THEN +! ! Convert from kg SO2 / box / s total to molec / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * XNUMOL(IDTSO2) +! & / GET_AREA_CM2(J) +! & / NEMIS_DT +! +! ! Anth SOx +! ELSEIF ( N == IDADJEMS_ESOx1 .or. +! & N == IDADJEMS_ESOx2 ) THEN +! +! ! it's already in molec SOx / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! +! ELSE +! +! CALL ERROR_STOP('undefined emissions', +! & 'inverse_mod.f') +! ENDIF +! +!#if defined ( LOG_OPT ) +! ! Apply current scaling +! TRACER(I,J,N) = TRACER(I,J,N) * EXP(EMS_ICS(I,J,1,N)) +! +!#else +! ! Apply current scaling +! TRACER(I,J,N) = TRACER(I,J,N) * EMS_ICS(I,J,1,N) +!#endif +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 50+N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER(:,:,N) ) +! +! ENDDO +! +! +! ! Also write the normalized emissions +! CALL READ_USA_MASK( USA_MASK ) +! CATEGORY = 'IJ-EMP-$' +! UNIT = '%' +! +! EMS_TOTAL(:) = 0d0 +! EMS_PERCENT(:,:,:) = 0d0 +! +! DO N = 1, NNEMS +! +! ! Note: not in parallel, would need another tmp array for that +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! IF ( USA_MASK(I,J) > 0d0 ) THEN +! +! EMS_TOTAL(N) = EMS_TOTAL(N) +! & + TRACER(I,J,N) * GET_AREA_CM2(J) +! ENDIF +! +! ENDDO +! ENDDO +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! IF ( EMS_TOTAL(N) == 0d0 .or. +! & USA_MASK(I,J) == 0d0 ) THEN +! +! ! Not sure what to store as "actual emission" for lightning NOx +! EMS_PERCENT(I,J,N) = 0d0 +! +! ELSE +! +! ! emissions percentages +! EMS_PERCENT(I,J,N) = TRACER(I,J,N) * GET_AREA_CM2(J) +! & / EMS_TOTAL(N) * 100d0 +! +! ENDIF +! +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 50+N+NNEMS, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, EMS_PERCENT(:,:,N) ) +! +! ! dkh debug +! print*, 'EMS_PERCENT total = ', SUM(EMS_PERCENT(:,:,N)), N +! +! ENDDO +! +! !NOFFSET = 0 +! +! ! VOC emissions -- anth hydrocarbons (EMISRR) +! CATEGORY = 'EMISRR' +! print*, 'make_ics db: nemis = ', NEMIS(NCS) +! DO N = 1, NEMIS(NCS) +! +! ! Compile TRACER [ molec / cm2 / s ] +! ! Get the actual emission in the current cell +! ! Original emissions are in EMS_orig, but in a variety of unit +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! molec C / box / s total sim -> molec C / cm2 / s +! TRACER_VOC(I,J,N) = EMISRR_orig(I,J,N) +! & / GET_AREA_CM2(J) +! & / NEMIS_DT +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_VOC(:,:,N) ) +! +! ! dkh debug +! print*, 'max EMISRR = ', MAXVAL(EMISRR_orig(:,:,N)), N +! +! ENDDO +! +! ! VOC emissions -- biogenic hydrocarbons (EMISRRB) +! CATEGORY = 'EMISRRB' +! DO N = 1, NEMIS(NCS) +! +! ! Compile TRACER [ molec / cm2 / s ] +! ! Get the actual emission in the current cell +! ! Original emissions are in EMS_orig, but in a variety of unit +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! molec C / box / s total sim -> molec C / cm2 / s +! TRACER_VOC(I,J,N) = EMISRRB_orig(I,J,N) +! & / GET_AREA_CM2(J) +! & / NEMIS_DT +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_VOC(:,:,N) ) +! +! ! dkh debug +! print*, 'max EMISRRB = ', MAXVAL(EMISRRB_orig(:,:,N)), N +! +! ENDDO +! !NOFFSET = NOFFSET + NEMIS(NCS) +! +! ! VOC emissions - BIOFUEL +! CATEGORY = 'BIOFUEL' +! DO N = 1, NBFTRACE +! +! ! Compile TRACER [ molec / cm2 / s ] +! ! Get the actual emission in the current cell +! ! Original emissions are in EMS_orig, but in a variety of unit +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! molec C / cm3 / s total sim -> molec C / cm2 / s +! TRACER_VOC(I,J,N) = BIOFUEL_orig(N,I,J) +! & * BXHEIGHT(I,J,1) * 100d0 +! & / NEMIS_DT +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_VOC(:,:,N) ) +! +! ! dkh debug +! print*, 'max BIOFUEL = ', MAXVAL(BIOFUEL_orig(N,:,:)), N +! +! ENDDO +! +! !NOFFSET = NOFFSET + NBFTRACE +! +! ! VOC emissions - BURNEMIS +! CATEGORY = 'BURNEMIS' +! DO N = 1, NBIOTRCE +! +! ! Compile TRACER [ molec / cm2 / s ] +! ! Get the actual emission in the current cell +! ! Original emissions are in EMS_orig, but in a variety of unit +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! molec C / cm3 / s total sim -> molec C / cm2 / s +! TRACER_VOC(I,J,N) = BURNEMIS_orig(N,I,J) +! & * BXHEIGHT(I,J,1) * 100d0 +! & / NEMIS_DT +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_VOC(:,:,N) ) +! +! ! dkh debug +! print*, 'max BURNEMIS= ', MAXVAL(BURNEMIS_orig(N,:,:)), N +! +! ENDDO +! +! ENDIF +! +! ! Close file +! CLOSE( IU_RST ) +! +! IF ( LPRINT_TOTAL ) THEN +! ! print out scaled emissions totals +! CALL READ_USA_MASK( USA_MASK ) +! +! ! Tracer is now going to be in units of Tg X / yr / box +! TRACER =0d0 +! TRACER_US=0d0 +! +! IF ( NNEMS > LLPAR ) CALL ERROR_STOP('baddd','inverse_mod') +! +! DO N = 1, NNEMS +! +! ! Units of emission for NOx from EMISRN are different +! ! Units of carbon emission also different. Skip em +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Get the actual emission in the current cell +! +! ! lightning NOx +! IF ( N == IDADJEMS_ENOxli ) THEN +! IF ( LLIGHTNOX ) THEN +! +! ! molec NOx / cm2 / s -> Tg N / yr +! TRACER(I,J,N) = EMS_orig_li(I,J) +! & / NEMIS_DT ! number of emissions +! & * SEC_PER_YEAR ! s/yr +! & * GET_AREA_CM2(J) ! cm^2 +! & / XNUMOL(IDTNOX) ! molec / kg of NO2 +! & * TG_PER_KG ! Tg / kg +! & * 14.d0 / 46.d0 ! g N / g NO2 +! +! TRACER_US(I,J,N) = TRACER(I,J,N) * USA_MASK(I,J) +! ELSE +! TRACER(I,J,N) = 0d0 +! TRACER_US(I,J,N) = 0d0 +! ENDIF +! +! ! soil NOx +! ELSEIF ( N == IDADJEMS_ENOxso ) THEN +! +! ! Not sure what to store as "actual emission" for soil NOx +! !TRACER(I,J,N) = 0d0 +! ! molec NOx / cm2 / s total -> Tg N / yr +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & / NEMIS_DT +! & * SEC_PER_YEAR ! s/yr +! & * GET_AREA_CM2(J) ! cm^2 +! & / XNUMOL(IDTNOX) ! molec / g of NO2 +! & * TG_PER_KG ! Tg / kg +! & * 14.d0 / 46.d0 ! g N / g NO2 +! +! TRACER_US(I,J,N) = TRACER(I,J,N) * USA_MASK(I,J) +! +! +! ! BC / OC +! ELSEIF ( N == IDADJEMS_BCan .or. N == IDADJEMS_OCan .or. +! & N == IDADJEMS_BCbb .or. N == IDADJEMS_OCbb .or. +! & N == IDADJEMS_BCbf .or. N == IDADJEMS_OCbf ) +! & THEN +! +! ! Convert from kg C / yr to Tg C / year +! TRACER(I,J,N) = EMS_orig(I,J,N) * TG_PER_KG +! TRACER_US(I,J,N) = EMS_orig(I,J,N) * TG_PER_KG +! & * USA_MASK(I,J) +! +! ! Anth NOx +! ELSEIF ( N == IDADJEMS_ENOx1 .or. N == IDADJEMS_ENOx2 ) +! & THEN +! +! ! Convert from kg NOx / emdt to Tg N / year +! TRACER(I,J,N) = EMS_orig(I,J,N) * TG_PER_KG +! & * MIN_PER_YEAR / GET_TS_EMIS() +! & * 14d0 / 46d0 +! TRACER_US(I,J,N) = EMS_orig(I,J,N) * TG_PER_KG +! & * MIN_PER_YEAR / GET_TS_EMIS() +! & * 14d0 / 46d0 +! & * USA_MASK(I,J) +! +! ! SO2 +! ELSEIF ( N == IDADJEMS_ESO2_bb .or. +! & N == IDADJEMS_ESO2_bf .or. +! & N == IDADJEMS_ESO2_sh ) +! +! & THEN +! +! ! Convert from kg SO2 / box / s to Tg S / year +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 +! TRACER_US(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 * USA_MASK(I,J) +! +! ! Volcano SO2 emissions (dkh, cklee 09/14/08) +! ELSEIF ( N == IDADJEMS_ESO2_ev .or. +! & N == IDADJEMS_ESO2_nv ) +! & THEN +! ! Convert from kg SO2 / box / s total to Tg S / year +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 +! & / NEMIS_DT +! TRACER_US(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 * USA_MASK(I,J) +! & / NEMIS_DT +! +! ! NH3 +! ELSEIF ( N == IDADJEMS_ENH3_an .or. +! & N == IDADJEMS_ENH3_na .or. +! & N == IDADJEMS_ENH3_bb .or. +! & N == IDADJEMS_ENH3_bf ) +! & THEN +! +! ! Convert from kg NH3 / box / s to Tg N / year +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 14d0 / 17d0 +! TRACER_US(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 14d0 / 17d0 +! & * USA_MASK(I,J) +! +! ! Anth SOx +! ELSEIF ( N == IDADJEMS_ESOx1 .or. +! & N == IDADJEMS_ESOx2 ) +! & THEN +! +! ! Convert from molec SOx / cm2 / s to Tg S / year +! TRACER(I,J,N) = EMS_orig(I,J,N) * GET_AREA_CM2(J) +! & / XNUMOL(IDTSO2) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 +! TRACER_US(I,J,N) = EMS_orig(I,J,N) * GET_AREA_CM2(J) +! & / XNUMOL(IDTSO2) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 +! & * USA_MASK(I,J) +! +! ELSE +! +! CALL ERROR_STOP('undefined emissions', +! & 'inverse_mod.f') +! +! ENDIF +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDDO +! +! print*, 'PRIOR EMISSIONS' +! print*, 'TOTAL SOx1 [Tg S/y] = ', SUM(TRACER(:,:,1)) +! print*, 'TOTAL SOx2 [Tg S/y] = ', SUM(TRACER(:,:,2)) +! print*, 'TOTAL SO2_sh [Tg S/y] = ', SUM(TRACER(:,:,3)) +! print*, 'TOTAL SO2_bb [Tg S/y] = ', SUM(TRACER(:,:,4)) +! print*, 'TOTAL SO2_bf [Tg S/y] = ', SUM(TRACER(:,:,5)) +! print*, 'TOTAL NH3_bb [Tg N/y] = ', SUM(TRACER(:,:,6)) +! print*, 'TOTAL NH3_bf [Tg N/y] = ', SUM(TRACER(:,:,7)) +! print*, 'TOTAL NH3_an [Tg N/y] = ', SUM(TRACER(:,:,8)) +! print*, 'TOTAL NH3_na [Tg N/y] = ', SUM(TRACER(:,:,9)) +! print*, 'TOTAL BCan [Tg C/y] = ', SUM(TRACER(:,:,10)) +! print*, 'TOTAL OCan [Tg C/y] = ', SUM(TRACER(:,:,11)) +! print*, 'TOTAL BCbf [Tg C/y] = ', SUM(TRACER(:,:,12)) +! print*, 'TOTAL OCbf [Tg C/y] = ', SUM(TRACER(:,:,13)) +! print*, 'TOTAL BCbb [Tg C/y] = ', SUM(TRACER(:,:,14)) +! print*, 'TOTAL OCbb [Tg C/y] = ', SUM(TRACER(:,:,15)) +! print*, 'TOTAL NOx1 [Tg N/y] = ', SUM(TRACER(:,:,16)) +! print*, 'TOTAL NOx2 [Tg N/y] = ', SUM(TRACER(:,:,17)) +! print*, 'TOTAL NOx_li [Tg N/y] = ', SUM(TRACER(:,:,18)) +! print*, 'TOTAL NOx_so [Tg N/y] = ', SUM(TRACER(:,:,19)) +! print*, 'TOTAL SO2_ev [Tg S/y] = ', SUM(TRACER(:,:,20)) +! print*, 'TOTAL SO2_nv [Tg S/y] = ', SUM(TRACER(:,:,21)) +! print*, 'TOTAL US SOx1 [Tg S/y] = ', SUM(TRACER_US(:,:,1)) +! print*, 'TOTAL US SOx2 [Tg S/y] = ', SUM(TRACER_US(:,:,2)) +! print*, 'TOTAL US SO2_sh [Tg S/y] = ', SUM(TRACER_US(:,:,3)) +! print*, 'TOTAL US SO2_bb [Tg S/y] = ', SUM(TRACER_US(:,:,4)) +! print*, 'TOTAL US SO2_bf [Tg S/y] = ', SUM(TRACER_US(:,:,5)) +! print*, 'TOTAL US NH3_bb [Tg N/y] = ', SUM(TRACER_US(:,:,6)) +! print*, 'TOTAL US NH3_bf [Tg N/y] = ', SUM(TRACER_US(:,:,7)) +! print*, 'TOTAL US NH3_an [Tg N/y] = ', SUM(TRACER_US(:,:,8)) +! print*, 'TOTAL US NH3_na [Tg N/y] = ', SUM(TRACER_US(:,:,9)) +! print*, 'TOTAL US BCan [Tg C/y] = ', SUM(TRACER_US(:,:,10)) +! print*, 'TOTAL US OCan [Tg C/y] = ', SUM(TRACER_US(:,:,11)) +! print*, 'TOTAL US BCbf [Tg C/y] = ', SUM(TRACER_US(:,:,12)) +! print*, 'TOTAL US OCbf [Tg C/y] = ', SUM(TRACER_US(:,:,13)) +! print*, 'TOTAL US BCbb [Tg C/y] = ', SUM(TRACER_US(:,:,14)) +! print*, 'TOTAL US OCbb [Tg C/y] = ', SUM(TRACER_US(:,:,15)) +! print*, 'TOTAL US NOx1 [Tg N/y] = ', SUM(TRACER_US(:,:,16)) +! print*, 'TOTAL US NOx2 [Tg N/y] = ', SUM(TRACER_US(:,:,17)) +! print*, 'TOTAL US NOx_li [Tg N/y] = ', SUM(TRACER_US(:,:,18)) +! print*, 'TOTAL US NOx_so [Tg N/y] = ', SUM(TRACER_US(:,:,19)) +! print*, 'TOTAL US SO2_ev [Tg N/y] = ', SUM(TRACER_US(:,:,20)) +! print*, 'TOTAL US SO2_nv [Tg N/y] = ', SUM(TRACER_US(:,:,21)) +! +! +! DO N = 1, NNEMS +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +!#if defined ( LOG_OPT ) +! ! Apply current scaling +! TRACER(I,J,N) = TRACER(I,J,N) * EXP(EMS_ICS(I,J,1,N)) +! TRACER_US(I,J,N) = TRACER_US(I,J,N) +! & * EXP(EMS_ICS(I,J,1,N)) +! +!#else +! ! Apply current scaling +! TRACER(I,J,N) = TRACER(I,J,N) * EMS_ICS(I,J,1,N) +! TRACER_US(I,J,N) = TRACER_US(I,J,N) * EMS_ICS(I,J,1,N) +!#endif +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDDO +! +! print*, 'POSTERIOR EMISSIONS' +! print*, 'TOTAL SOx1 [Tg S/y] = ', SUM(TRACER(:,:,1)) +! print*, 'TOTAL SOx2 [Tg S/y] = ', SUM(TRACER(:,:,2)) +! print*, 'TOTAL SO2_sh [Tg S/y] = ', SUM(TRACER(:,:,3)) +! print*, 'TOTAL SO2_bb [Tg S/y] = ', SUM(TRACER(:,:,4)) +! print*, 'TOTAL SO2_bf [Tg S/y] = ', SUM(TRACER(:,:,5)) +! print*, 'TOTAL NH3_bb [Tg N/y] = ', SUM(TRACER(:,:,6)) +! print*, 'TOTAL NH3_bf [Tg N/y] = ', SUM(TRACER(:,:,7)) +! print*, 'TOTAL NH3_an [Tg N/y] = ', SUM(TRACER(:,:,8)) +! print*, 'TOTAL NH3_na [Tg N/y] = ', SUM(TRACER(:,:,9)) +! print*, 'TOTAL BCan [Tg C/y] = ', SUM(TRACER(:,:,10)) +! print*, 'TOTAL OCan [Tg C/y] = ', SUM(TRACER(:,:,11)) +! print*, 'TOTAL BCbf [Tg C/y] = ', SUM(TRACER(:,:,12)) +! print*, 'TOTAL OCbf [Tg C/y] = ', SUM(TRACER(:,:,13)) +! print*, 'TOTAL BCbb [Tg C/y] = ', SUM(TRACER(:,:,14)) +! print*, 'TOTAL OCbb [Tg C/y] = ', SUM(TRACER(:,:,15)) +! print*, 'TOTAL NOx1 [Tg N/y] = ', SUM(TRACER(:,:,16)) +! print*, 'TOTAL NOx2 [Tg N/y] = ', SUM(TRACER(:,:,17)) +! print*, 'TOTAL NOx_li [Tg N/y] = ', SUM(TRACER(:,:,18)) +! print*, 'TOTAL NOx_so [Tg N/y] = ', SUM(TRACER(:,:,19)) +! print*, 'TOTAL SO2_ev [Tg S/y] = ', SUM(TRACER(:,:,20)) +! print*, 'TOTAL SO2_nv [Tg S/y] = ', SUM(TRACER(:,:,21)) +! print*, 'TOTAL US SOx1 [Tg S/y] = ', SUM(TRACER_US(:,:,1)) +! print*, 'TOTAL US SOx2 [Tg S/y] = ', SUM(TRACER_US(:,:,2)) +! print*, 'TOTAL US SO2_sh [Tg S/y] = ', SUM(TRACER_US(:,:,3)) +! print*, 'TOTAL US SO2_bb [Tg S/y] = ', SUM(TRACER_US(:,:,4)) +! print*, 'TOTAL US SO2_bf [Tg S/y] = ', SUM(TRACER_US(:,:,5)) +! print*, 'TOTAL US NH3_bb [Tg N/y] = ', SUM(TRACER_US(:,:,6)) +! print*, 'TOTAL US NH3_bf [Tg N/y] = ', SUM(TRACER_US(:,:,7)) +! print*, 'TOTAL US NH3_an [Tg N/y] = ', SUM(TRACER_US(:,:,8)) +! print*, 'TOTAL US NH3_na [Tg N/y] = ', SUM(TRACER_US(:,:,9)) +! print*, 'TOTAL US BCan [Tg C/y] = ', SUM(TRACER_US(:,:,10)) +! print*, 'TOTAL US OCan [Tg C/y] = ', SUM(TRACER_US(:,:,11)) +! print*, 'TOTAL US BCbf [Tg C/y] = ', SUM(TRACER_US(:,:,12)) +! print*, 'TOTAL US OCbf [Tg C/y] = ', SUM(TRACER_US(:,:,13)) +! print*, 'TOTAL US BCbb [Tg C/y] = ', SUM(TRACER_US(:,:,14)) +! print*, 'TOTAL US OCbb [Tg C/y] = ', SUM(TRACER_US(:,:,15)) +! print*, 'TOTAL US NOx1 [Tg N/y] = ', SUM(TRACER_US(:,:,16)) +! print*, 'TOTAL US NOx2 [Tg N/y] = ', SUM(TRACER_US(:,:,17)) +! print*, 'TOTAL US NOx_li [Tg N/y] = ', SUM(TRACER_US(:,:,18)) +! print*, 'TOTAL US NOx_so [Tg N/y] = ', SUM(TRACER_US(:,:,19)) +! print*, 'TOTAL US SO2_ev [Tg N/y] = ', SUM(TRACER_US(:,:,20)) +! print*, 'TOTAL US SO2_nv [Tg N/y] = ', SUM(TRACER_US(:,:,21)) +! +! +! ENDIF +! +! +! !### Debug +! +! IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_SF_DIAG_FILE: wrote file' ) +! +! ! Return to calling program +! END SUBROUTINE MAKE_SF_DIAG_FILE +! +!!------------------------------------------------------------------------------ +! + SUBROUTINE READ_SF_FILE ( ) +! +!****************************************************************************** +! Subroutine READ_SF_FILE reads the gctm.sf.* file into ICS_SF or EMS_SF +! (dkh, 9/17/04) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! +! Notes +! (1 ) Add support for ACTIVE_VARS == 'EMISSIONS' case (dkh, 11/27/04) +! (2 ) Add support for ACTIVE_VARS == 'FDTEST' case (dkh, 02/17/05) +! (3 ) Now use CATEGORY = 'IJ-EMS-$' for ACTIVE_VARS == 'EMISSIONS' case. +! (dkh, 03/28/05) +! (4 ) Change name from ICS to SF, replace CMN_ADJ (dkh, ks, mak, cs 06/08/09) +! (5 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, ICS_SF + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_MOD, ONLY : LPRT + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! LPRT + + ! Local Variables + INTEGER :: I, IOS, J, L, M, N + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + CHARACTER(LEN=20) :: INPUT_SF_FILE + + !================================================================= + ! READ_SF_FILE begins here! + !================================================================= + + ! Hardwire output file for now + INPUT_SF_FILE = 'gctm.sf.NN' + + ! Initialize some variables + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open SF file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_SF_FILE ) + + ! Replace NN token w/ actual value + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add OPTDATA_DIR prefix to FILENAME + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + ! can hardwire this to read a specific file from another run: + !FILENAME = TRIM( 'opt_ics/ADJv27fi04r10/gctm.ics.16' ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'S F F I L E I N P U T' + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_SF_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + IF ( LICS ) THEN + + !================================================================= + ! Read initial conditions -- store in the TRACER array + !================================================================= + DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:6') + + !============================================================== + ! Assign data from the TRACER array to the xxx_IC array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-ICS-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ICS_SF (I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ENDIF + + IF ( LADJ_EMS ) THEN + + !================================================================= + ! Read emission scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NNEMS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:6') + + !============================================================== + ! Assign data from the TRACER array to the xxx_IC array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-EMS-$' ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + EMS_SF(I,J,M,N) = TRACER(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + !================================================================= + ! Read strat prod & loss scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NSTPL + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:6') + + !============================================================== + ! Assign data from the TRACER array to the xxx_STR array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + + IF ( CATEGORY(1:8) == 'IJ-STRP$' ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + PROD_SF(I,J,M,N) = TRACER(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDDO + + !================================================================= + ! Read strat prod & loss scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NSTPL + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:6') + + IF ( CATEGORY(1:8) == 'IJ-STRL$' ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + LOSS_SF(I,J,M,N) = TRACER(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDDO + ENDIF + + + IF ( LADJ_RRATE ) THEN + !================================================================= + ! Read rxn rate scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NRRATES + + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_sf_file:rate1' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_sf_file:rate2' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_sf_file:rate3' ) + + IF ( CATEGORY(1:8) == 'IJ-RATSF' ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + RATE_SF(I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDDO + ENDIF + + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_SF_FILE: read file' ) + + ! Return to calling program + END SUBROUTINE READ_SF_FILE + +!----------------------------------------------------------------------- + + SUBROUTINE MAKE_SAT_DIAG_FILE ( type) +! +!****************************************************************************** +! Subroutine MAKE_DIAG_FILE creates a binary file of a diagnostic array +! calculated in CALC_ADJ_FORCING in adjoint_mod.f +! (mak, 02/09/06, 2/17/06, zhe 08/29/10) +! +! ============================================================================ +! (1 ) MODEL_BIAS +! NOTES: +! (1 ) Just like MAKE_ADJ_FILE except +! - write to .force. file +! (2 ) Add support for ACTIVE_VARS == 'EMISSIONS' case (dkh, 11/27/04) +! (3 ) Add support for ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (4 ) Change UNIT to unitless and change title to Scale factors (dkh, 03/06/05) +! (5 ) Change output for ACTIVE_VARS == 'EMISSIONS' case. +! Now use label IJ-EMS-$, and update gamap code accordingly. +! First write the scaling factors, in consecutive species. Temporal +! varations in the emissions, if any, will be in the L direction. +! Next, write out the optimized emissions themselves. +! Finally, write out the difference between orig and optimized emissions. +! (dkh, 03/28/05) +! (6 ) Use EMS_orig instead of ESO4_an_orig so that we can loop over N. +! (7 ) Move EMS_org declaration to CMN_ADJ, (mak) +! (8 ) Updated to v8, adj_group, 6/09/09, (mak, 6/22/09) +! (9 ) Bug fixed, the flog SDFLAG is added, zhe 8/29/10 +! (10) Update MOPITT obs operators (zhe, 1/19/11) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU, GET_CT_EMIS + USE ADJ_ARRAYS_MOD, ONLY : GET_MODEL_BIAS, GET_FORCING, + & GET_MODEL, GET_OBS, COST_ARRAY, + & COST_ARRAY, GET_DOFS, + & OBS_COUNT, GET_EMS_ORIG, + & N_CALC, SAT, DAYS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME +#if defined ( MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS ) + USE MOPITT_OBS_MOD, ONLY : OBS_HOUR_MOPITT !(zhe 1/19/11) +#endif +#if defined(AIRS_CO_OBS) + USE AIRS_CO_OBS_MOD, ONLY : OBS_HOUR_AIRS_CO +#endif + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LHMOD, LHOBS, LMODBIAS, LOBS_COUNT, + & LDOFS + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! TRCOFFSET, TINDEX + + ! Arguments + integer, intent(in) :: type ! type of diag file + INTEGER :: NN + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, M, N,H,s + REAL*4 :: TRACER(IIPAR,JJPAR,DAYS,sat) + REAL*4, ALLOCATABLE :: TRACER_EMS(:,:,:) + REAL*4, ALLOCATABLE :: TRACER_COST(:,:,:) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: OUTPUT_ICS_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + LOGICAL :: SDFLAG + + +! INPUTS: + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + !================================================================= + ! MAKE_SAT_DIAG_FILE begins here! + !================================================================= + + SDFLAG = .FALSE. + + ! Hardwire output file for now + IF( TYPE == 1 .AND. LHMOD ) THEN + + OUTPUT_ICS_FILE = 'gctm.model.NN' + UNIT = 'molec/cm2' + CATEGORY = 'IJ-AVG-$' + SDFLAG = .TRUE. + + ELSEIF( TYPE == 2 .AND. LHOBS ) THEN + + OUTPUT_ICS_FILE = 'gctm.obs.NN' + UNIT = 'molec/cm2' + CATEGORY = 'IJ-AVG-$' + TITLE = 'GEOS-CHEM observation file: ' + SDFLAG = .TRUE. + + ELSEIF( TYPE ==3 .AND. LMODBIAS ) THEN + + OUTPUT_ICS_FILE = 'gctm.modelbias.NN' + UNIT = '%' + CATEGORY = 'IJ-AVG-$' + TITLE = 'GEOS-CHEM model bias File: ' // + & 'model - obs bias' + SDFLAG = .TRUE. + + +c$$$ IF( type == 4 ) THEN +c$$$ +c$$$ OUTPUT_ICS_FILE = 'gctm.emsorig' +c$$$ TITLE = 'GEOS-CHEM emissions file: ' + + ELSEIF( TYPE == 5 .AND. LOBS_COUNT ) THEN + + OUTPUT_ICS_FILE = 'gctm.costf.NN' + TITLE = 'GEOS-CHEM cost file: ' + SDFLAG = .TRUE. + + ELSEIF( TYPE == 6 .AND. LDOFS ) THEN + + OUTPUT_ICS_FILE = 'gctm.dofs.NN' + TITLE = 'Degrees of Freedom of Signal for sats: ' + UNIT = 'unitless' + CATEGORY = 'IJ-DOF-$' + SDFLAG = .TRUE. + + ! (zhe, dkh, 02/04/11) + ELSEIF( TYPE == 7 ) THEN + + OUTPUT_ICS_FILE = 'gctm.forcing.NN' + TITLE = 'Adjoint forcing: ' + UNIT = 'unitless' + CATEGORY = 'IJ-AVG-$' + SDFLAG = .TRUE. + + ENDIF + + IF (SDFLAG) THEN + + ! zero TRACER array, for clarity + TRACER(:,:,:,:) = 0d0 + + ! Define variables for BINARY PUNCH FILE OUTPUT + + ! now passed in + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_ICS_FILE ) + + ! Replace NN token w/ actual value + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add OPT_DATA_DIR prefix to FILENAME + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_SAT_DIAG_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each observed quantity to the ics file + !================================================================= + !Temporarily store quantities in the TRACER array + + ! Loop over number of satellites + DO s = 1, sat + + IF( TYPE == 1 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, DAYS + DO J = 1, JJPAR + DO I = 1, IIPAR + ! average over all days, add all days in IDL + TRACER(I,J,L,s) = GET_MODEL(I,J,L,s) + ENDDO + ENDDO + ENDDO + +!$OMP END PARALLEL DO + + ELSEIF( TYPE == 2 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L) + DO L = 1, DAYS + DO J = 1, JJPAR + DO I = 1, IIPAR + ! average over all days, add all days in IDL + TRACER(I,J,L,s) = GET_OBS(I,J,L,s) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + print*, 'obs#:', s + print*, 'min obs:',minval(tracer(:,:,:,s)) + print*, 'max obs:',maxval(tracer(:,:,:,s)) + + ELSEIF( TYPE == 3 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, DAYS + DO J = 1, JJPAR + DO I = 1, IIPAR + ! average over all days, add all days in IDL + TRACER(I,J,L,s) = GET_MODEL_BIAS(I,J,L,s) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! (zhe, dkh, 02/04/11) + ELSEIF( TYPE == 7 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, DAYS + DO J = 1, JJPAR + DO I = 1, IIPAR + ! average over all days, add all days in IDL + TRACER(I,J,L,s) = GET_FORCING(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + + ENDIF ! TYPE + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, s, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, DAYS, I0+1, + & J0+1, 1, TRACER(:,:,:,s) ) + + ENDDO ! s = 1,SAT + + + IF (TYPE .EQ. 6 ) THEN + + DO s = 1, sat + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, DAYS + DO J = 1, JJPAR + DO I = 1, IIPAR + ! average over all days, add all days in IDL + TRACER(I,J,L,s) = GET_DOFS(I,J,L,s) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, s, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, DAYS, I0+1, + & J0+1, 1, TRACER(:,:,:,s) ) + + ENDDO ! s = 1,SAT + ENDIF !TYPE == 6 + + ! Comment for now and later decide if we want it (mak,6/22/09) +c$$$ IF( TYPE == 4 ) THEN +c$$$ ALLOCATE (TRACER_EMS(IIPAR,JJPAR,MMSCL)) +c$$$ TRACER_EMS = 0e0 +c$$$ +c$$$ ! The following taken from ND29 +c$$$ UNIT = 'kg/box/h' +c$$$ CATEGORY ='CO--SRCE' +c$$$ NN = TINDEX(29,1) +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, M) +c$$$ DO M = 1, MMSCL +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ ! average over all days, add all days in IDL +c$$$ TRACER_EMS(I,J,M) = GET_EMS_ORIG(I,J,M)*EMS_ICS(I,J,M,1) +c$$$ & /DBLE(GET_CT_EMIS() ) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, NN, +c$$$ & UNIT, GET_TAU(), GET_TAU(), RESERVED, +c$$$ & IIPAR, JJPAR, MMSCL, I0+1, +c$$$ & J0+1, 1, TRACER_EMS ) +c$$$ +c$$$ +c$$$ IF( ALLOCATED( TRACER_EMS ) ) DEALLOCATE(TRACER_EMS) +c$$$ +c$$$ ENDIF ! TYPE=4 + + IF( TYPE == 5 ) THEN + + !ALLOCATE (TRACER_COST(IFDSIZE, JFDSIZE, LFDSIZE )) + ALLOCATE (TRACER_COST(IIPAR, JJPAR, DAYS )) + TRACER_COST = 0e0 + + ! The following taken from ND29 + UNIT = 'unitless' + CATEGORY ='COSTF' + NN = 8301 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L) + DO L = 1, DAYS !LFDSIZE + DO J = 1, JJPAR !JFDSIZE + DO I = 1, IIPAR !IFDSIZE + ! COST_ARRAY + TRACER_COST(I,J,L) = COST_ARRAY(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !print*, 'min/max of COST_ARRAY going to file:' + !print*, minval(TRACER_COST), maxval(TRACER_COST) + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NN, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, DAYS, I0+1, + & J0+1, 1, TRACER_COST ) + + PRINT*, 'FINISHED STORING COSTF' + + IF( ALLOCATED( TRACER_COST ) ) DEALLOCATE(TRACER_COST) + + ALLOCATE (TRACER_COST(IIPAR,JJPAR,1)) + TRACER_COST = 0e0 + + ! The following taken from ND29 + UNIT = 'unitless' + CATEGORY ='OBSCT' + NN = 8401 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L) + DO L = 1, 1 + DO J = 1, JJPAR + DO I = 1, IIPAR + ! OBS_COUNT ARRAY + TRACER_COST(I,J,1) = OBS_COUNT(I,J) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NN, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER_COST ) + + print*, 'finished saving OBSCT, tot obs#:',sum(obs_count) + +#if defined (MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS) + + ! store OBS_HOUR, but note that it's only for the last day of sim + CATEGORY ='OBSHR' + NN = 8501 + TRACER_COST(:,:,:) = 0e0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L) + DO L = 1, 1 + DO J = 1, JJPAR + DO I = 1, IIPAR + ! OBS_COUNT ARRAY + TRACER_COST(I,J,1) = OBS_HOUR_MOPITT(I,J) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NN, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER_COST ) + + PRINT*, 'FINISHED OBS HOUR MOPITT' +#endif + +#if defined(AIRS_CO_OBS) + ! store OBS_HOUR, but note that it's only for the last day of sim + CATEGORY ='OBSHR' + NN = 8502 + TRACER_COST(:,:,:) = 0e0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L) + DO L = 1, 1 + DO J = 1, JJPAR + DO I = 1, IIPAR + ! OBS_COUNT ARRAY + TRACER_COST(I,J,1) = OBS_HOUR_AIRS_CO(I,J) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NN, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER_COST ) + + PRINT*, 'FINISHED storing OBS_HOUR_AIRS_CO' +#endif + + IF( ALLOCATED( TRACER_COST ) ) DEALLOCATE(TRACER_COST) + + ENDIF ! TYPE=5 + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF( LPRT ) CALL DEBUG_MSG( '### MAKE_SAT_DIAG_FILE: wrote file') + + ENDIF !SDFLAG + + + ! Return to calling program + END SUBROUTINE MAKE_SAT_DIAG_FILE + +!------------------------------------------------------------------------------ +! Now move this in adj_arrays_mod.f (dkh, 10/15/09) +! +! SUBROUTINE EXPAND_NAME( FILENAME, N_ITRN ) +!! +!!****************************************************************************** +!! Subroutine EXPAND_DATE replaces "NN" token within +!! a filename string with the actual values. (bmy, 6/27/02, 12/2/03) +!! (dkh, 9/22/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) FILENAME (CHARACTER) : Filename with tokens to replace +!! (2 ) N_ITRN (INTEGER ) : Current iteration number +!! +!! +!! Arguments as Output: +!! ============================================================================ +!! (1 ) FILENAME (CHARACTER) : Modified filename +!! +!! NOTES: +!! (1 ) Based on EXPAND_DATE +!! +!!****************************************************************************** +!! +! ! References to F90 modules +! USE CHARPAK_MOD, ONLY : STRREPL +! USE ERROR_MOD, ONLY : ERROR_STOP +! +!# include "define.h" +! +! ! Arguments +! CHARACTER(LEN=*), INTENT(INOUT) :: FILENAME +! INTEGER, INTENT(IN) :: N_ITRN +! +! ! Local variables +! CHARACTER(LEN=2) :: NN_STR +! +! !================================================================= +! ! EXPAND_NAME begins here! +! !================================================================= +! +!#if defined( LINUX_PGI ) +! +! ! Use ENCODE statement for PGI/Linux (bmy, 9/29/03) +! ENCODE( 2, '(i2.2)', NN_STR ) N_ITRN +! +!#else +! +! ! For other platforms, use an F90 internal write (bmy, 9/29/03) +! WRITE( NN_STR, '(i2.2)' ) N_ITRN +! +!#endif +! +! ! Replace NN token w/ actual value +! CALL STRREPL( FILENAME, 'NN', NN_STR ) +! +! +! ! Return to calling program +! END SUBROUTINE EXPAND_NAME +! +!!----------------------------------------------------------------------------- + + SUBROUTINE DISPLAY_STUFF( LOCATION ) +! +!******************************************************************************** +! Subroutine DISPLAY_STUFF writes output to the screen during optimization +! (dkh, 11/28/04) +! +! NOTES +! (1 ) Rearragne the structure so that LOCATION is outermost selection, then +! ACTIVE_VARS == xx is subselection. Add support for LOCATION 4 ( final +! iteration ). dkh, 02/17/05 +! (2 ) Update to v8 and new interface/var names (mak, 6/19/09) +! (3 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!******************************************************************************** +! + ! References to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC_SAV + USE ADJ_ARRAYS_MOD, ONLY : FD_DIFF + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, MFD, LFD, NFD, EMSFD + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ_FD + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, ICSFD + USE ADJ_ARRAYS_MOD, ONLY : STRFD + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF, RATE_SF0 + USE ADJ_ARRAYS_MOD, ONLY : RATFD + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST, LADJ_EMS, LICS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size params + + ! Argument + INTEGER :: LOCATION + + ! Local variables + INTEGER :: I_DUM + INTEGER :: N + REAL*8 :: FINAL_ADJ_GRAD + REAL*8 :: FINAL_FD_GRAD + + !============================================================ + ! DISPLAY_STUFF starts here! + !============================================================ + + + SELECT CASE ( LOCATION ) + + ! Read/Write an iteration + CASE( 1 ) + + IF ( LICS ) THEN + + WRITE(6,*) ' ICS_SF(1,1,1,:) is ', ICS_SF(1,1,1,:) + WRITE(6,*) ' ICS_SF(:,:,1,1) range is ', + & MINVAL(ICS_SF(:,:,1,1) ), + & ' to ', MAXVAL(ICS_SF(:,:,1,1) ) + + WRITE(6,*) ' ICS_SF(1,1,:,1) range is ', + & MINVAL(ICS_SF(1,1,:,1) ), + & ' to ', MAXVAL(ICS_SF(1,1,:,1) ) + + ELSEIF( LADJ_EMS ) THEN + + ! Nothing + + ELSEIF( LFDTEST ) THEN + + IF (LICS) THEN + WRITE(6,*) ' ICS_SF(FD) is ',ICS_SF(IFD,JFD,LFD,ICSFD) + ENDIF + IF (LADJ_EMS) THEN + WRITE(6,*) ' EMS_SF(FD) is ',EMS_SF(IFD,JFD,LFD,EMSFD) + + ! Strat prod and loss (hml) + IF (LADJ_STRAT) THEN + WRITE(6,*) ' PROD_SF(FD) is ' + & ,PROD_SF(IFD,JFD,LFD,STRFD) + WRITE(6,*) ' LOSS_SF(FD) is ' + & ,LOSS_SF(IFD,JFD,LFD,STRFD) + ENDIF + + ! Reaction rates (tww) + IF (LADJ_RRATE) THEN + WRITE(6,*) ' RATE_SF(FD) is ' + & , RATE_SF(IFD,JFD,LFD,RATFD) + ENDIF + + ENDIF + + ELSE + CALL ERROR_STOP( 'ACTIVE_VARS not defined!', + & 'DISPLAY_STUFF' ) + ENDIF + + ! After loading gradient + CASE( 2 ) + + IF ( LICS .AND. LADJ_EMS ) THEN + + WRITE(6,*) ' ICS_SF(:,:,1,1) range is ', + & MINVAL( ICS_SF(:,:,1,1) ), ' to ', + & MAXVAL( ICS_SF(:,:,1,1) ) + + + WRITE(6,*) ' EMS_SF(:,:,1,1) range is ', + & MINVAL( EMS_SF(:,:,1,1) ), ' to ', + & MAXVAL( EMS_SF(:,:,1,1) ) + + print*, ' GRADNT range is', + & MINVAL( GRADNT ), ' to ', + & MAXVAL( GRADNT ) + + ELSEIF ( LFDTEST .AND. LICS ) THEN + + ! for now, the I_DUM calculation is only supported for LICS, + ! not LADJ_EMS (mak, 6/22/09) + I_DUM = IFD + ( IIPAR * ( JFD - 1) ) + & + ( IIPAR * JJPAR * ( LFD - 1 ) ) + & + ( IIPAR * JJPAR * LLPAR * ( ICSFD - 1 ) ) + + WRITE(6,*) ' GRADNT(FD) = ', GRADNT(I_DUM) + + WRITE(6,*) ' MIN/MAX ICS_SF_ADJ = ', + & MINVAL(ICS_SF_ADJ(:,:,:,:)), + & MAXVAL(ICS_SF_ADJ(:,:,:,:)) + + ELSEIF ( LFDTEST .AND. LADJ_EMS ) THEN + + WRITE(6,*) ' MIN/MAX EMS_SF_ADJ = ', + & MINVAL(EMS_SF_ADJ(:,:,:,:)), + & MAXVAL(EMS_SF_ADJ(:,:,:,:)) + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + WRITE(6,*) ' MIN/MAX PROD_SF_ADJ = ', + & MINVAL(PROD_SF_ADJ(:,:,:,:)), + & MAXVAL(PROD_SF_ADJ(:,:,:,:)) + + WRITE(6,*) ' MIN/MAX LOSS_SF_ADJ = ', + & MINVAL(LOSS_SF_ADJ(:,:,:,:)), + & MAXVAL(LOSS_SF_ADJ(:,:,:,:)) + ENDIF + + ! Reaction rates (tww) + IF ( LADJ_RRATE ) THEN + WRITE(6,*) ' MIN/MAX RATE_SF_ADJ = ', + & MINVAL(RATE_SF_ADJ(:,:,:,:)), + & MAXVAL(RATE_SF_ADJ(:,:,:,:)) + ENDIF + + ELSEIF ( LICS ) THEN + +! print*, 'gradnt', gradnt(1), +! & gradnt(1+iipar*jjpar*llpar*(1)) , +! & gradnt(1+iipar*jjpar*llpar*2), +! & gradnt(1+iipar*jjpar*llpar*3) + + ELSEIF ( LADJ_EMS ) THEN + + WRITE(6,*) ' EMS_SF(:,:,1,1) range is ', + & MINVAL( EMS_SF(:,:,1,1) ), ' to ', + & MAXVAL( EMS_SF(:,:,1,1) ) + + print*, ' GRADNT range is', + & MINVAL( GRADNT ), ' to ', + & MAXVAL( GRADNT ) + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + WRITE(6,*) ' PROD_SF(:,:,1,1) range is ', + & MINVAL( PROD_SF(:,:,1,1) ), ' to ', + & MAXVAL( PROD_SF(:,:,1,1) ) + + WRITE(6,*) ' LOSS_SF(:,:,1,1) range is ', + & MINVAL( LOSS_SF(:,:,1,1) ), ' to ', + & MAXVAL( LOSS_SF(:,:,1,1) ) + + print*, ' PROD_GRADNT range is', + & MINVAL( GRADNT_P ), ' to ', + & MAXVAL( GRADNT_P ) + + print*, ' LOSS_GRADNT range is', + & MINVAL( GRADNT_L ), ' to ', + & MAXVAL( GRADNT_L ) + ENDIF + + ! Reaction rates (tww) + IF ( LADJ_RRATE ) THEN + WRITE(6,*) ' RATE_SF(:,:,1,1) range is ', + & MINVAL( RATE_SF(:,:,1,1) ), ' to ', + & MAXVAL( RATE_SF(:,:,1,1) ) + ENDIF + + ELSE + CALL ERROR_STOP( 'ACTIVE VARS not defined!', + & 'DISPLAY_STUFF, inverse_mod.f' ) + ENDIF + + ! For all values of ACTIVE_VARS... + WRITE(6,*) ' cost function', COST_FUNC + IF ( N_CALC > 1 ) THEN + WRITE(6,*) ' local change = ', + & COST_FUNC / COST_FUNC_SAV(N_CALC - 1), + & ' = current / previous ' + ENDIF + WRITE(6,*) ' total change so far = ', + & COST_FUNC / COST_FUNC_SAV(1), + & ' = currrent / initial ' + + + ! Compute an iteration + CASE( 3 ) + + WRITE(6,*) ' COMPUTING NEW VALUES FOR N_CALC = ', + & N_CALC + + IF( LFDTEST .AND. LICS) THEN + + WRITE(6,*) ' COMPUTING NEW VALUES FOR N_CALC = ', + & N_CALC + IF (LICS) THEN + WRITE(6,*) ' CURRENT ICS_SF(FD) IS ', + & ICS_SF(IFD,JFD,LFD,ICSFD) + ENDIF + IF (LADJ_EMS) THEN + WRITE(6,*) ' CURRENT EMS_SF(FD) IS ', + & EMS_SF(IFD,JFD,MFD,EMSFD) + ENDIF + + + ELSEIF ( LICS ) THEN + WRITE(6,*) ' CURRENT ICS_SF(1,1,1,:) IS ', + & ICS_SF(1,1,1,:) + + WRITE(6,*) ' ICS_SF(:,:,1,1) range is ', + & MINVAL(ICS_SF(:,:,1,1) ), + & ' to ', MAXVAL(ICS_SF(:,:,1,1) ) + + WRITE(6,*) ' ICS_SF(1,1,:,1) range is ', + & MINVAL(ICS_SF(1,1,:,1) ), + & ' to ', MAXVAL(ICS_SF(1,1,:,1) ) + + WRITE(6,*) ' RANGE OF ICS_SF(:,:,:,:) IS ', + & MINVAL(ICS_SF), ' TO ', + & MAXVAL(ICS_SF) + + ELSEIF( LADJ_EMS ) THEN + + ! Nothing + + ELSE + CALL ERROR_STOP( 'ACTIVE VARS not defined!', + & 'DISPLAY_STUFF, inverse_mod.f' ) + ENDIF + + !After the final iteration + CASE( 4 ) + + ! For all values of ACTIVE_VARS... + WRITE(6,*) 'COST_FUNC = ', COST_FUNC + IF ( COST_FUNC_SAV(1) > 0d0 ) + & WRITE(6,*) 'COST_FUNC reduction = ', + & COST_FUNC / COST_FUNC_SAV(1) + + ! Add gradient diagnostics (dkh, 06/24/09) + IF ( LICS ) THEN + DO N = 1, N_TRACERS + WRITE(6,*) 'MIN ICS_SF_ADJ = ', + & MINVAL(ICS_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MAX ICS_SF_ADJ = ', + & MAXVAL(ICS_SF_ADJ(:,:,:,N)), N + ENDDO + ENDIF + IF ( LADJ_EMS ) THEN + DO N = 1, NNEMS + WRITE(6,*) 'MIN EMS_SF_ADJ = ', + & MINVAL(EMS_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MAX EMS_SF_ADJ = ', + & MAXVAL(EMS_SF_ADJ(:,:,:,N)), N + ENDDO + + ! strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + DO N = 1, NSTPL + WRITE(6,*) 'MIN PROD_SF_ADJ = ', + & MINVAL(PROD_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MAX PROD_SF_ADJ = ', + & MAXVAL(PROD_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MIN LOSS_SF_ADJ = ', + & MINVAL(LOSS_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MAX LOSS_SF_ADJ = ', + & MAXVAL(LOSS_SF_ADJ(:,:,:,N)), N + ENDDO + ENDIF + + ! reaction rates (tww) + IF ( LADJ_RRATE ) THEN + DO N = 1, NRRATES + WRITE(6,*) 'MIN RATE_SF_ADJ = ', + & MINVAL(RATE_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MAX RATE_SF_ADJ = ', + & MAXVAL(RATE_SF_ADJ(:,:,:,N)), N + ENDDO + ENDIF + ENDIF + + ! Compile statistics from the finite difference test. + ! Calculate final gradients after two iterations. + ! Now only do this for a SPOT test (dkh, 02/21/11) + !IF ( LFDTEST .AND. N_CALC == 2 ) THEN + IF ( LFD_SPOT .AND. N_CALC == 2 ) THEN + + IF ( LADJ_EMS ) THEN + ! Determine the gradient calculated using the adjoint method + ! as an average of the gradient at FD_PERT [ STT_ADJ_FD(1) ] + ! and FD_PERT + FD_DIFF [ STT_ADJ_FD(2) ]. + STT_ADJ_FD(2) = EMS_SF_ADJ(IFD,JFD,MFD,EMSFD) + FINAL_ADJ_GRAD = .5d0 + & * ( STT_ADJ_FD(1) + STT_ADJ_FD(2) ) + ELSEIF ( LICS ) THEN + ! Determine the gradient calculated using the adjoint method + ! as an average of the gradient at FD_PERT [ STT_ADJ_FD(1) ] + ! and FD_PERT + FD_DIFF [ STT_ADJ_FD(2) ]. + STT_ADJ_FD(2) = ICS_SF_ADJ(IFD,JFD,LFD,ICSFD) + FINAL_ADJ_GRAD = .5d0 + & * ( STT_ADJ_FD(1) + STT_ADJ_FD(2) ) + + ENDIF + + + ! The finite difference gradient is + ! [ J( FD_PERT + FD_DIFF ) - J( FD_PERT ) ] / FD_DIFF + FINAL_FD_GRAD = ( COST_FUNC - COST_FUNC_SAV(1) ) + & / ( FD_DIFF ) + + ! Echo results to the screen + WRITE(6,*) ' ADJOINT gradient = ', FINAL_ADJ_GRAD + WRITE(6,*) ' FN DIFF gradient = ', FINAL_FD_GRAD + WRITE(6,*) ' ADJ / FD = ', + & FINAL_ADJ_GRAD / FINAL_FD_GRAD + + ENDIF +! + WRITE(6,*) 'FORCE EXIT AFTER ', N_CALC_STOP,' ITERATIONS.' + + CASE DEFAULT + ! Nothing +! + END SELECT + + + END SUBROUTINE DISPLAY_STUFF + +! needs to be updated +!!---------------------------------------------------------------------- +!! +!! SUBROUTINE INIT_REGIONAL_EMS +!! +!!******************************************************************************** +!! Subroutine INIT_REGIONAL_EMS initializes spatially dependent emissions factors +!! (dkh, 12/04/04) +!! +!! NOTES +!! (1 ) Updated to add random noise. (dkh, 08/27/06) +!!******************************************************************************** +!! +!# include "CMN_SIZE" ! Size params +! +! ! Local variables +! INTEGER :: I, J +! DOUBLE PRECISION :: RAN +! +! !============================================================ +! ! INIT_REGIONAL_EMS begins here! +! !============================================================ +! WRITE(6,*) ' U S E S P A T I A L L Y V A R I A B L E ' +! WRITE(6,*) ' E M I S S I O N S S C A L I N G S F O R ' +! WRITE(6,*) ' R E F E R E N C E C A L C U L A T I O N ' +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, RAN ) +! DO I = 1, IIPAR +! DO J = 1, JJPAR +! +! ! Nor Am +! IF ( I < 28 .AND. J > 28 ) THEN +! EMS_SF(I,J,1,IDADJEMS_ESOx1) = 0.8D0 +! EMS_SF(I,J,1,IDADJEMS_ESOx2) = 0.8D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx1) = 0.85D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx2) = 0.85D0 +! +! ! Europe +! ELSEIF ( I > 27 .AND. I < 48 .AND. J > 28 ) THEN +! EMS_SF(I,J,1,IDADJEMS_ESOx1) = 0.7D0 +! EMS_SF(I,J,1,IDADJEMS_ESOx2) = 0.7D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx1) = 0.95D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx2) = 0.95D0 +! +! ! Asia / India +! ELSEIF ( I > 47 .AND. J > 20 ) THEN +! EMS_SF(I,J,1,IDADJEMS_ESOx1) = 1.3D0 +! EMS_SF(I,J,1,IDADJEMS_ESOx2) = 1.3D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx1) = 1.2D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx2) = 1.2D0 +! +! ! The rest of the Southern Hemisphere +! ELSE +! EMS_SF(I,J,1,IDADJEMS_ESOx1) = 0.75D0 +! EMS_SF(I,J,1,IDADJEMS_ESOx2) = 0.75D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx1) = 0.77D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx2) = 0.77D0 +! +! ENDIF +! +! RAN = DRAN(I+J) +! +! ! add a small bit of random variation +! EMS_SF(I,J,1,IDADJEMS_ESOx1) = EMS_SF(I,J,1,IDADJEMS_ESOx1) +! & + RAN / 20 +! EMS_SF(I,J,1,IDADJEMS_ESOx2) = EMS_SF(I,J,1,IDADJEMS_ESOx2) +! & + RAN / 20 +! EMS_SF(I,J,1,IDADJEMS_ENOx1) = EMS_SF(I,J,1,IDADJEMS_ENOx1) + +! & + RAN / 20 +! EMS_SF(I,J,1,IDADJEMS_ENOx2) = EMS_SF(I,J,1,IDADJEMS_ENOx2) + +! & + RAN / 20 +! +! ENDDO +! ENDDO +!!OMP END PARALLEL DO +! END SUBROUTINE INIT_REGIONAL_EMS +!!---------------------------------------------------------------------- + SUBROUTINE SET_SF_FORFD +! +!***************************************************************************** +! Subroutine SET_SF_FORFD is used to initialize ICS_SF during the second +! iteration to the orginal value + FD_DIFF. dkh, 02/17/05 +! +! NOTES: +! (1 ) Add support for 2nd order FD calculation +! (2 ) Add support for FD_GLOB option (dkh, 10/11/08) +! (3 ) Now initialize EMS_SF to FD_BKGRND (dkh, 10/11/08) +! (4 ) Change name to SET_SF_FORFD, replace CMN_ADJ, simplify the definition +! of the FD pert (dkh, ks, mak, cs 06/07/09) +! (5 ) Now support strat fluxes LADJ_STRAT and add flags to avoid accessing +! unallocated arrays (hml, dkh, 02/20/12, adj32_025) +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, ICS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : IFD,JFD,LFD,NFD + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, PROD_SF0 + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF, LOSS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : MFD, EMSFD + USE ADJ_ARRAYS_MOD, ONLY : FD_DIFF + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + USE ADJ_ARRAYS_MOD, ONLY : STRFD + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF, RATE_SF0 + USE ADJ_ARRAYS_MOD, ONLY : RATFD + + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + + +# include "CMN_SIZE" ! Size params + + !================================================================= + ! SET_SF_FORFD begins here! + !================================================================= + + ICS_SF(:,:,:,:) = ICS_SF0(:,:,:,:) + IF ( LADJ_EMS ) EMS_SF(:,:,:,:) = EMS_SF0(:,:,:,:) + IF ( LADJ_STRAT ) THEN + PROD_SF(:,:,:,:) = PROD_SF0(:,:,:,:) + LOSS_SF(:,:,:,:) = LOSS_SF0(:,:,:,:) + ENDIF + IF ( LADJ_RRATE ) THEN + RATE_SF(:,:,:,:) = RATE_SF0(:,:,:,:) + ENDIF + + ! Nudge the scaling factor value only in the FD cell + IF ( LFD_SPOT ) THEN + + ! for initial conditions : + IF ( LICS ) THEN + + IF ( N_CALC == 2 ) THEN + ICS_SF(IFD,JFD,LFD,ICSFD) = ICS_SF(IFD,JFD,LFD,ICSFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + ICS_SF(IFD,JFD,LFD,ICSFD) = ICS_SF(IFD,JFD,LFD,ICSFD) + & - FD_DIFF + ENDIF + + ! for boundary conditions : + ELSEIF ( LADJ_EMS ) THEN + + ! Strat prod and loss (hml) + IF ( .NOT. LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + IF ( N_CALC == 2 ) THEN + EMS_SF(IFD,JFD,MFD,EMSFD) = EMS_SF(IFD,JFD,MFD,EMSFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + EMS_SF(IFD,JFD,MFD,EMSFD) = EMS_SF(IFD,JFD,MFD,EMSFD) + & - FD_DIFF + ENDIF + + ELSEIF ( LADJ_STRAT ) THEN + IF ( N_CALC == 2 ) THEN + LOSS_SF(IFD,JFD,MFD,STRFD) = LOSS_SF(IFD,JFD,MFD,STRFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + LOSS_SF(IFD,JFD,MFD,STRFD) = LOSS_SF(IFD,JFD,MFD,STRFD) + & - FD_DIFF + ENDIF + + ! Reaction rates (tww) + ELSEIF ( LADJ_RRATE ) THEN + IF ( N_CALC == 2 ) THEN + RATE_SF(IFD,JFD,LFD,RATFD) = RATE_SF(IFD,JFD,LFD,RATFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + RATE_SF(IFD,JFD,LFD,RATFD) = RATE_SF(IFD,JFD,LFD,RATFD) + & - FD_DIFF + ENDIF + ENDIF + + ENDIF + + ! Perturb thoughout model domain. + ELSEIF ( LFD_GLOB ) THEN + + ! for test with no transport: + print*, 'PERTURB GLOBALLY !!!!' + + IF ( LICS ) THEN + + IF ( N_CALC == 2 ) THEN + ICS_SF(:,:,LFD,ICSFD) = ICS_SF(:,:,LFD,ICSFD) + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + ICS_SF(:,:,LFD,ICSFD) = ICS_SF(:,:,LFD,ICSFD) - FD_DIFF + ENDIF + + ELSEIF ( LADJ_EMS ) THEN + + ! Strat prod and loss (hml) + IF ( .NOT. LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + IF ( N_CALC == 2 ) THEN + EMS_SF(:,:,MFD,EMSFD) = EMS_SF(:,:,MFD,EMSFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + EMS_SF(:,:,MFD,EMSFD) = EMS_SF(:,:,MFD,EMSFD) + & - FD_DIFF + ENDIF + + ! Make RRATE default when both turned on (hml, 06/08/13) + !ELSEIF ( LADJ_STRAT ) THEN + ELSEIF ( LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + + IF ( N_CALC == 2 ) THEN + LOSS_SF(:,:,MFD,STRFD) = LOSS_SF(:,:,MFD,STRFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + LOSS_SF(:,:,MFD,STRFD) = LOSS_SF(:,:,MFD,STRFD) + & - FD_DIFF + ENDIF + + ! Reaction rates (tww) + ELSEIF ( LADJ_RRATE ) THEN + IF ( N_CALC == 2 ) THEN + RATE_SF(:,:,LFD,RATFD) = RATE_SF(:,:,LFD,RATFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + RATE_SF(:,:,LFD,RATFD) = RATE_SF(:,:,LFD,RATFD) + & - FD_DIFF + ENDIF + + ENDIF + ENDIF + + ENDIF + + + ! Return to calling program + END SUBROUTINE SET_SF_FORFD + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_CFN_FILE( ) +! +!****************************************************************************** +! Subroutine MAKE_CFN_FILE creates a cfn.NN file which stores the current +! iteration number and cost function value. (dkh, 02/13/06) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! +! Module Variable as Output: +! ============================================================================ +! (1 ) COST_FUNC : Current cost function value +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE FILE_MOD, ONLY : IOERROR + +# include "CMN_SIZE" + + ! Local variables + CHARACTER(LEN=80) :: OUTPUT_CFN_FILE + CHARACTER(LEN=120) :: REMOVE_CFN_FILE_CMD + CHARACTER(LEN=80) :: FILENAME + INTEGER :: IOS + + !================================================================= + ! MAKE_CFN_FILE begins here! + !================================================================= + + ! Make file name + OUTPUT_CFN_FILE = 'cfn.NN' + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_CFN_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the OPTDATA_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + !================================================================= + ! Open the cfn file for output + !================================================================= + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_CFN_FILE: Writing ', a ) + + ! Remove any previous cfn files for the current iteration + REMOVE_CFN_FILE_CMD = 'rm ' // TRIM (FILENAME) + + CALL SYSTEM ( TRIM( REMOVE_CFN_FILE_CMD ) ) + + + ! Open file for input + OPEN( 65, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL', + & POSITION='APPEND' ) + + ! Error check + IF ( IOS /= 0 ) CALL IOERROR( IOS, 65, 'write_cost_func:1') + + ! Write iteration number and cost function + WRITE( 65, *) N_CALC, COST_FUNC + + + ! Return to calling program + END SUBROUTINE MAKE_CFN_FILE +!------------------------------------------------------------------------------ + + SUBROUTINE READ_CFN_FILE( ) +! +!****************************************************************************** +! Subroutine READ_CFN_FILE reads the value fo the cost function at iteration +! NN from the cfn.NN file. (dkh, 02/13/06) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! +! Module variable as Output: +! ============================================================================ +! (1 ) COST_FUNC : Cost function value +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE FILE_MOD, ONLY : IOERROR + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" + + ! Local variables + CHARACTER(LEN=80) :: OUTPUT_CFN_FILE + CHARACTER(LEN=80) :: FILENAME + INTEGER :: N, N_TMP, IOS + REAL*8 :: CFN_TMP, COST_FUNC_check + LOGICAL :: FOUND = .FALSE. + + !================================================================= + ! READ_CFN_FILE begins here! + !================================================================= + + ! Make file name + OUTPUT_CFN_FILE = 'cfn.NN' + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_CFN_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the OPTDATA_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + !================================================================= + ! Open the cost function file for input + !================================================================= + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_CFN_FILE: Reading ', a ) + + ! Open file for input -- readonly + OPEN( 65, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL', + & POSITION='REWIND') + + ! Error check + IF ( IOS /= 0 ) CALL IOERROR( IOS, 65, 'read_cost_func:1') + + ! Read values in file + READ( 65, *) N_TMP, CFN_TMP + + ! Check to make sure that we're reading the correct file. If so, update + ! COST_FUNC with the value from the file. + IF ( N_TMP == N_CALC) THEN + COST_FUNC = CFN_TMP + FOUND = .TRUE. + ENDIF + + ! Error check + IF ( .NOT. FOUND ) THEN + CALL ERROR_STOP('Cost function value missing', 'inverse_mod' ) + ENDIF + + ! Return to calling program + END SUBROUTINE READ_CFN_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE SET_OPT_RANGE( ) +! +!****************************************************************************** +! Subroutine SET_OPT_RANGE sets the range of the emissions which we +! wish to optimize by setting all others to zero. (dkh, 10/17/06) +! +! +! Module variables as Input: +! ============================================================================ +! (1 ) EMS_SF_ADJ : All emissions gradients +! (2 ) ICS_SF_ADJ : All tracer gradients +! (3 ) OPT_THIS_EMS : Logial array of emissions to optimize +! (4 ) OPT_THIS_ICS : Logial array of initial conditions to optimize +! +! Module variables as Output: +! ============================================================================ +! (1 ) EMS_SF_ADJ : All emissions gradients +! (2 ) ICS_SF_ADJ : All tracer gradients +! +! NOTES: +! (1 ) Replace CMN_ADJ, update naming, add spatial filter from ks +! (dkh, ks, mak, cs 06/07/09) +! (2 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NNEMS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_EMS, OPT_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_PROD + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_LOSS + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE TRACER_MOD, ONLY : N_TRACERS + ! added for reaction rates (tww, 05/15/12) + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_RATE + USE ADJ_ARRAYS_MOD, ONLY : NRRATES, RATFD + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + + +# include "CMN_SIZE" ! Size params + + ! Local variables + INTEGER I, J, M, N + + !================================================================= + ! SET_OPT_RANGE begins here! + !================================================================= + + ! dkh debug + print*, ' SET_OPT_RANGE: MIN / MAX ICS_SF_ADJ = ', + & MINVAL(ICS_SF_ADJ), MAXVAL(ICS_SF_ADJ) + + IF ( LICS ) THEN + DO N = 1, N_TRACERS + IF ( .not. OPT_THIS_TRACER(N) ) THEN + ICS_SF_ADJ(:,:,:,N) = 0d0 + ENDIF + ENDDO + ENDIF + + ! dkh debug + print*, ' SET_OPT_RANGE 2 : MIN / MAX ICS_SF_ADJ = ', + & MINVAL(ICS_SF_ADJ), MAXVAL(ICS_SF_ADJ) + + ! Zero the gradients of the species we don't want to optimize + IF ( LADJ_EMS ) THEN + DO N = 1, NNEMS + IF ( .not. OPT_THIS_EMS(N) ) THEN + EMS_SF_ADJ(:,:,:,N) = 0d0 + ENDIF + ENDDO + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + DO N = 1, NSTPL + IF ( .not. OPT_THIS_PROD(N) ) THEN + PROD_SF_ADJ(:,:,:,N) = 0d0 + ENDIF + IF ( .not. OPT_THIS_LOSS(N) ) THEN + LOSS_SF_ADJ(:,:,:,N) = 0d0 + ENDIF + ENDDO + ENDIF + + ! reaction rates (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN + ! tww debug + print*, ' SET_OPT_RANGE 3 : MIN / MAX RATE_SF_ADJ = ', + & MINVAL(RATE_SF_ADJ), MAXVAL(RATE_SF_ADJ) + print*, 'OPT_THIS_RATE = ', OPT_THIS_RATE(:) + print*, 'RATFD = ', RATFD + + DO N = 1, NRRATES + IF ( .not. OPT_THIS_RATE(N) ) THEN + RATE_SF_ADJ(:,:,:,N) = 0d0 + ENDIF + ENDDO + + ! tww debug + print*,' SET_OPT_RANGE 4 : MIN / MAX RATE_SF_ADJ = ', + & MINVAL(RATE_SF_ADJ), MAXVAL(RATE_SF_ADJ) + ! tww debug + print*,' SET_OPT_RANGE 5 : MIN / MAX RATE_SF_ADJ(RATFD) = ', + & MINVAL(RATE_SF_ADJ(:,:,:,RATFD)), + & MAXVAL(RATE_SF_ADJ(:,:,:,RATFD)) + ENDIF + + + + ENDIF + + +! ! Only consider gradients in specific spatial range +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M, N ) +! DO N = 1, NNEMS +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Zero the gradients which we don't +! ! want to optimize +!! IF ( (( I < 42 .and. I > 34 ) .and. ! IN +!! & ( J > 32 .and. J < 39 )) ! EUROPE +!! IF ( (( I > 18 .and. I < 23 ) .and. ! IN +!! & ( J > 30 .and. J < 35 )) ! Eastern US +!! IF ( (( I < 19 .or. I > 22 ) .or. ! not IN +!! & ( J < 31 .or. J > 34 )) ! Eastern US +! IF ( (( I < 12 .or. I > 22 ) .or. ! not IN +! & ( J < 31 .or. J > 34 )) ! US +! & .or. +! & ( .not. OPT_THIS_EMS(N) ) ) THEN +! +! EMS_SF_ADJ(I,J,M,N) = 0d0 +! +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! + +! old code from ks +!#if defined ( TES_O3_OBS ) +! +! ! Zero the gradients above NLEVS +! ICS_FD_ADJ(:,:,NLEVS+1:LLPAR,:) = 0d0 +! +! ! Smoothly drive gradients to zero at poles +! IF (NLAT_TO_IGNORE > 0) THEN +! +! DO N = 1, N_TRACERS +! DO L = 1, NLEVS +! DO J = 1, NLAT_TO_IGNORE +! DO I = 1, IIPAR +! TEMP = NLAT_TO_IGNORE - J +! FACTOR = COS( (TEMP / ( NLAT_TO_IGNORE - 1 ) ) +! & * ( pi / 2 )**2 +! ICS_FD_ADJ(I,J,L,N) = ICS_FD_ADJ(I,J,L,N) * FACTOR +! ENDDO +! ENDDO +! ENDDO +! ENDDO +! +! DO N = 1, N_TRACERS +! DO L = 1, NLEVS +! DO J = JJPAR - NLAT_TO_IGNORE + 1, JJPAR +! DO I = 1,IIPAR +! TEMP = NLAT_TO_IGNORE - J +! FACTOR = COS( (TEMP / ( NLAT_TO_IGNORE - 1 ) ) +! & * ( pi / 2 )**2 +! ICS_FD_ADJ(I,J,L,N) = ICS_FD_ADJ(I,J,L,N) * FACTOR +! ENDDO +! ENDDO +! ENDDO +! ENDDO +! +! ENDIF +!#endif + + ! Return to calling program + END SUBROUTINE SET_OPT_RANGE + +!------------------------------------------------------------------------------ + DOUBLE PRECISION FUNCTION DRAN(K) +C +C RANDOM NUMBER GENERATOR - BASED ON ALGORITHM 266 BY PIKE AND +C HILL (MODIFIED BY HANSSON), COMMUNICATIONS OF THE ACM, +C VOL. 8, NO. 10, OCTOBER 1965. +C +C THE SINGLE PRECISION VERSION OF THIS SUBPROGRAM IS INTENDED +C FOR USE ON COMPUTERS WITH FIXED POINT WORDLENGTH OF AT +C LEAST 29 BITS. IT IS BEST IF THE FLOATING POINT +C SIGNIFICAND HAS AT MOST 29 BITS. +C +C FOLLOWING CODY AND WAITE'S RECOMMENDATION (P .14), WE +C PRODUCE A PAIR OF RANDOM NUMBERS AND USE RAN1 + +C 2**(-29)*RAN2 IN AN ATTEMPT TO GENERATE ABOUT 58 RANDOM BITS. +C + INTEGER IY,J,K + DATA IY /100001/ +C + J = K + IY = IY * 125 + IY = IY - (IY/2796203) * 2796203 + DRAN = DBLE(FLOAT(IY)) / 2796203.0D+00 +C + IY = IY * 125 + IY = IY - (IY/2796203) * 2796203 + DRAN = DRAN + (DBLE(FLOAT(IY)) / 2796203.0D+00) / 536870912.0D+00 + RETURN +C ---------- LAST CARD OF DRAN ---------- + END FUNCTION DRAN +! needs to be updated: +!-------------------------------------------------------------------------------- +! +! SUBROUTINE UPDATE_HESSIAN( ) +! +!****************************************************************************** +! Subroutine UPDATE_HESSIAN constructs an approximation of the inverse +! Hessian using the DFP formula (see Muller and Stavrakou, 2005, eqn 18). +! +! This routine is set up to be used offline so that the Hessian is +! only approximated at the end of a convered optimization. To implement, +! uncomment code in 3 places in inverse.f +! +! The initial estimate can be identiy matrix or initial estimate of uncertainty +! +! It takes too long to consider all possible correlations, so we apply the +! following filters: +! - Only consider corelations between emissions of +! - anth SOx (surface and stack) +! - anth NOx (surface and stack) +! - anth NH3 +! - natural NH3 +! - Only within the U.S. +! - Only in places where ADJ_EMS at first iteration is > 1d-4 +! +! If these filters are changes, the array diminsion HMAX will need to be +! updated. To determine the size of the MASD parameter, do a dry run, +! then go back and update. +! +! NOTES: +! +!****************************************************************************** +! +! +! print*, ' SUBROUTINE UPDATE_HESSIAN needs to be updated ' +! print*, ' SUBROUTINE UPDATE_HESSIAN needs to be updated ' +! print*, ' SUBROUTINE UPDATE_HESSIAN needs to be updated ' +! print*, ' SUBROUTINE UPDATE_HESSIAN needs to be updated ' +! +! ! Reference to f90 modules +! +!# include "CMN_SIZE" +! +! ! Arguments +! +! ! Local variables +! INTEGER, PARAMETER :: HMAX = 3675 +! +! INTEGER :: I, J, M, N, II, JJ, NITR +! +! REAL*8, SAVE :: USA_MASK(IIPAR,JJPAR) +! +! INTEGER, SAVE :: IIMAP(IIPAR,JJPAR,MMSCL,NNEMS) = 0d0 +! INTEGER, SAVE :: MAPI(HMAX), MAPJ(HMAX) +! INTEGER, SAVE :: MAPM(HMAX), MAPN(HMAX) +! +! REAL*8, SAVE :: EMS_SF_OLD(IIPAR,JJPAR,MMSCL,NNEMS) +! REAL*8, SAVE :: ADJ_EMS_OLD(IIPAR,JJPAR,MMSCL,NNEMS) +! REAL*8, SAVE :: HINV(HMAX,HMAX) +! LOGICAL, SAVE :: FIRST = .TRUE. +! +! REAL*8 :: S(HMAX), Y(HMAX), YTS, YTHINVY +! REAL*8 :: YTS_INV, YTHINVY_INV +! REAL*8 :: SST(HMAX,HMAX), HINVY(HMAX), YTHINV(HMAX) +! REAL*8 :: HINVYYTHINV(HMAX,HMAX) +! +! !================================================================= +! ! UPDATE_HESSIAN begins here! +! !================================================================= +! +! PRINT*, ' UPDATE HESSIAN AT ITERATE ', N_CALC +! +! +! IF ( FIRST ) THEN +! +! ! Initialize HINV to the identity matrix (or initial unc. est) +! HINV(:,:) = 0d0 +! +! DO JJ = 1, HMAX +! DO II = 1, HMAX +! +! IF ( II == JJ ) HINV(II,II) = 0.3d0 +! +! ENDDO +! ENDDO +! +! ! Get USA mask +! CALL READ_USA_MASK( USA_MASK ) +! +! ! dkh debug +! print*, ' yea yea eya' +! +! II = 0 +! +! DO N = 1, NNEMS +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Spatial filter +! ! Only in US: +!! IF ( USA_MASK(I,J) == 0d0 ) CYCLE +! ! Only in places where emissions are nonzero +! IF ( ABS(ADJ_EMS(I,J,M,N)) < 1d-4 ) CYCLE +! +! IF ( +! & N == IDADJEMS_ESOx1 .or. +! & N == IDADJEMS_ESOx2 .or. +! & N == IDADJEMS_ENOx1 .or. +! & N == IDADJEMS_ENOx2 .or. +! & N == IDADJEMS_ENH3_an .or. +! & N == IDADJEMS_ENH3_na +! & ) THEN +! +! +! ! Update vector index +! II = II + 1 +! +! ! Save mapping arrays +! IIMAP(I,J,M,N) = II +! MAPI(II) = I +! MAPJ(II) = J +! MAPM(II) = M +! MAPN(II) = N +! +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +! ENDDO +! +! +! EMS_ICS_OLD(:,:,:,:) = EMS_ICS(:,:,:,:) +! ADJ_EMS_OLD(:,:,:,:) = ADJ_EMS(:,:,:,:) +! print*, ' UPDATE HESSIAN, pts founds = ', II +! CALL MAKE_HESS_FILE( HINV, USA_MASK , HMAX, IIMAP , 1 ) +! FIRST = .FALSE. +! +! +! print*, 'EMS_ICS = ', EMS_ICS(19,33,1,IDADJEMS_ESOx2) +! print*, 'EMS_ICS_OLD = ', EMS_ICS_OLD(19,33,1,IDADJEMS_ESOx2) +! print*, 'ADJ_EMS = ', ADJ_EMS(19,33,1,IDADJEMS_ESOx2) +! print*, 'ADJ_EMS_OLD = ', ADJ_EMS_OLD(19,33,1,IDADJEMS_ESOx2) +! +! RETURN +! ENDIF +! +! +! DO II = 1, HMAX +! +! I = MAPI(II) +! J = MAPJ(II) +! M = MAPM(II) +! N = MAPN(II) +! +! ! find s_k = f_{k+1} - f_{k} +! S(II) = EMS_ICS(I,J,M,N) - EMS_ICS_OLD(I,J,M,N) +! +! ! find y_k = grad_{k+1} - grad_{k} +! Y(II) = ADJ_EMS(I,J,M,N) - ADJ_EMS_OLD(I,J,M,N) +! +! ENDDO +! +! print*, ' UPDATE HESSIAN, pts founds = ', II +! +! print*, 'EMS_ICS = ', EMS_ICS(19,33,1,IDADJEMS_ESOx2) +! print*, 'EMS_ICS_OLD = ', EMS_ICS_OLD(19,33,1,IDADJEMS_ESOx2) +! print*, 'ADJ_EMS = ', ADJ_EMS(19,33,1,IDADJEMS_ESOx2) +! print*, 'ADJ_EMS_OLD = ', ADJ_EMS_OLD(19,33,1,IDADJEMS_ESOx2) +! +! ! Rotate +! EMS_ICS_OLD(:,:,:,:) = EMS_ICS(:,:,:,:) +! ADJ_EMS_OLD(:,:,:,:) = ADJ_EMS(:,:,:,:) +! +! !---------------------------------------------------------- +! ! Update inverse Hessian +! !---------------------------------------------------------- +! +! ! y^T*s +! YTS = 0d0 +! DO II = 1, HMAX +! +! YTS = YTS + Y(II) * S(II) +! +! ENDDO +! +! print*, ' YTS = ', YTS , N_CALC +! +! ! s * s^T / YTS +! DO II = 1, HMAX +! DO JJ = 1, HMAX +! +! SST(II,JJ) = S(II) * S(JJ) +! +! ENDDO +! ENDDO +! +! ! HINV * y +! DO II = 1, HMAX +! +! HINVY(II) = 0D0 +! +! DO JJ = 1, HMAX +! +! HINVY(II) = HINVY(II) + HINV(II,JJ) * Y(JJ) +! +! ENDDO +! ENDDO +! +! ! y^T * HINV +! DO JJ = 1, HMAX +! +! YTHINV(JJ) = 0d0 +! +! DO II = 1, HMAX +! +! YTHINV(JJ) = YTHINV(JJ) + Y(II) * HINV(II,JJ) +! +! ENDDO +! ENDDO +! +! +! ! HINVY * YTHINV +! DO JJ = 1, HMAX +! DO II = 1, HMAX +! +! HINVYYTHINV(II,JJ) = HINVY(II) * YTHINV(JJ) +! +! ENDDO +! ENDDO +! +! +! ! YT * HINVY +! YTHINVY = 0d0 +! DO II = 1, HMAX +! YTHINVY = YTHINVY + Y(II) * HINVY(II) +! ENDDO +! print*, 'YTHINVY = ', YTHINVY +! +! ! HINV = HINV + SST * (1/YTS) - HINVYYTHINV * (1/YTHINVY) +! YTS_INV = 1 / YTS +! YTHINVY_INV = 1 / YTHINVY +! DO JJ = 1, HMAX +! DO II = 1, HMAX +! +! HINV(II,JJ) = HINV(II,JJ) +! & + SST(II,JJ) * YTS_INV +! & - HINVYYTHINV(II,JJ) * YTHINVY_INV +! +! ENDDO +! ENDDO +! +! print*, ' MAX HINV = ', MAXVAL(HINV(:,:)) +! print*, ' MIN HINV = ', MINVAL(HINV(:,:)) +! +! NITR = N_CALC +! +! CALL MAKE_HESS_FILE( HINV, USA_MASK , HMAX, IIMAP , NITR ) +! +! ! Return to calling program +! END SUBROUTINE UPDATE_HESSIAN +!!------------------------------------------------------------------------------ +! needs to be updated +! +! SUBROUTINE MAKE_HESS_FILE( HINV, USA_MASK , HMAX, IIMAP, NITR ) +!! +!!****************************************************************************** +!! Subroutine MAKE_HESS_FILE creates a binary file of selected elements +!! of the approximate inverse hessian. (dkh, 05/15/07) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) HINV : Current estimate of inverse hessian +!! +!! Module Variable as Input: +!! ============================================================================ +!! (1 ) N_CALC : Current iteration number +!! +!! NOTES: +!! (1 ) Just like MAKE_GDT_FILE except +!! - pass NITR as an argument +!!****************************************************************************** +!! +! +! ! References to F90 modules +! USE BPCH2_MOD +! USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_SETUP" ! +!# include "CMN" ! LPRT +!# include "CMN_ADJ" ! NADJ, OPTDATA_DIR, ACTIVE_VARS +! +! +! ! Arguments +! INTEGER :: HMAX +! REAL*8 :: HINV(HMAX,HMAX) +! REAL*8 :: USA_MASK(IIPAR,JJPAR) +! INTEGER :: IIMAP(IIPAR,JJPAR,MMSCL,NNEMS) +! INTEGER :: NITR +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, M, N, II, JJ +! INTEGER :: YYYY, MM, DD, HH, SS +! REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +! REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) +! CHARACTER(LEN=255) :: FILENAME +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! CHARACTER(LEN=20) :: OUTPUT_GDT_FILE +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! +! !================================================================= +! ! MAKE_HESS_FILE begins here! +! !================================================================= +! +! ! Clear intermediate arrays +! EMS_3D(:,:,:) = 0d0 +! +! ! Hardwire output file for now +!#if defined( GEOS_1 ) || defined( GEOS_STRAT ) +! OUTPUT_GDT_FILE = 'gctm.invhess.NN' +!#else +! OUTPUT_GDT_FILE = 'gctm.invhess.NN' +!#endif +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM Adjoint File: ' // +! & 'Inverse hessian ' +! UNIT = 'none' +! CATEGORY = 'IJ-INVH-' +! LONRES = DISIZE +! LATRES = DJSIZE +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the adjoint file for output -- binary punch format +! !================================================================= +! +! ! Copy the output observation file name into a local variable +! FILENAME = TRIM( OUTPUT_GDT_FILE ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, NITR ) +! +! ! Add the OPTDATA_DIR prefix to the file name +! FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_HESS_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +!! IF ( ACTIVE_VARS == 'TRACERS'.OR. +!! & ACTIVE_VARS == 'FDTEST' ) THEN +! IF ( ACTIVE_VARS == 'TRACERS' ) THEN +! +! CALL ERROR_STOP( 'inverse hessian not supported ', +! & ' MAKE_HESS_FILE, inverse_mod.f') +! +! ELSEIF ( ACTIVE_VARS == 'EMISSIONS' .OR. +! & ACTIVE_VARS == 'FDTEST' ) THEN +! +! ! Reset CATEGORY as labeling in gamap is different +! CATEGORY = 'IJ-INVH-' +! +! !================================================================= +! ! Write each observed quantity to the observation file +! !================================================================= +! DO N = 1, NNEMS +! +! !Temporarily store quantities in the TRACER array +! EMS_3D(I,J,M) = 0d0 +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M, II ) +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! +! II = IIMAP(I,J,M,N) +! IF ( II == 0 ) CYCLE +! +! IF ( HINV(II,II) > 0 ) THEN +! EMS_3D(I,J,M) = REAL(SQRT(HINV(II,II))) +! ELSE +! print*, I, J, M, N, II +! CALL ERROR_STOP('non positive hessian diagonal ', +! & 'inverse_mod.f') +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ENDDO +! +! ! Reset CATEGORY as labeling in gamap is different +! CATEGORY = 'IJ-COREL' +! +! !================================================================= +! ! Write correlation for a given cell +! !================================================================= +! DO N = 1, NNEMS +! +! ! target cell +! JJ = IIMAP(13,33,1,IDADJEMS_ENH3_an) +! +! !Temporarily store quantities in the TRACER array +! EMS_3D(I,J,M) = 0d0 +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M, II ) +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! +! II = IIMAP(I,J,M,N) +! !IF ( II == 0 ) CYCLE +! IF ( II == 0 ) THEN +! EMS_3D(I,J,M) = 0d0 +! ELSE +! EMS_3D(I,J,M) = REAL(HINV(II,JJ)/(SQRT(HINV(II,II)) +! & * SQRT(HINV(JJ,JJ)))) +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ENDDO +! ELSE +! CALL ERROR_STOP( 'ACTIVE_VARS not defined!', +! & 'MAKE_HESS_FILE' ) +! ENDIF +! +! ! Close file +! CLOSE( IU_RST ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_HESS_FILE: wrote file' ) +! +! ! Return to calling program +! END SUBROUTINE MAKE_HESS_FILE + +!------------------------------------------------------------------------------ +! SUBROUTINE READ_USA_MASK( USA_MASK ) +!! +!!****************************************************************************** +!! Subroutine READ_USA_MASK reads the USA mask from disk. The USA mask is +!! the fraction of the grid box (I,J) which lies w/in the continental USA. +!! (rch, bmy, 11/10/04, 10/3/05) +!! +!! NOTES: +!! (1 ) Now can read data for GEOS and GCAP grids (bmy, 8/16/05) +!! (2 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!!****************************************************************************** +!! +! ! Reference to F90 modules +! !USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! +!#include "CMN_SIZE" +! +! ! Local variables +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*8 :: XTAU +! REAL*8 :: USA_MASK(IGLOB,JGLOB) +! CHARACTER(LEN=255) :: FILENAME +! +! +! !================================================================= +! ! READ_USA_MASK begins here! +! !================================================================= +! +! ! File name +! ! Argg - haven't initialized the forward model yet, so DATA_DIR undefined +! ! Just put the mask in the home directory +!! FILENAME = TRIM( DATA_DIR ) // +!! & 'EPA_NEI_200411/usa_mask.' // GET_NAME_EXT_2D() // +! FILENAME = +! & 'usa_mask.geos' // +! & '.' // GET_RES_EXT() +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_USA_MASK: Reading ', a ) +! +! ! Get TAU0 for Jan 1985 +! XTAU = GET_TAU0( 1, 1, 1985 ) +! +! ! USA mask is stored in the bpch file as #2 +! CALL READ_BPCH2( FILENAME, 'LANDMAP', 2, +! & XTAU, IGLOB, JGLOB, +! & 1, ARRAY, QUIET=.TRUE. ) +! +! ! Cast to REAL*8 +! !CALL TRANSFER_2D( ARRAY(:,:,1), USA_MASK ) +! USA_MASK(:,:) = ARRAY(:,:,1) +! +! ! Return to calling program +! END SUBROUTINE READ_USA_MASK +! +!!------------------------------------------------------------------------------ + SUBROUTINE CALC_NOPT + +! +!****************************************************************************** +! Subroutine CALC_NOPT calculates the number of paramteres to optimize +! +! NOTES: +! (1 ) Set NOPT for initial conditions to 3D: IIPAR*JJPAR*LLPAR*N_TRACERS to +! be consistent with other parts of the code (mak, 6/18/09) +! (2 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NOPT + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS, LICS + USE TRACER_MOD, ONLY : N_TRACERS, ITS_A_TAGCO_SIM + +# include "CMN_SIZE" + + !================================================================= + ! CALC_NOPT begins here! + !================================================================= + + ! if optimizing both initial emissions and initial conditions + IF ( LADJ_EMS .AND. LICS ) THEN + NOPT = IIPAR * JJPAR * MMSCL * NNEMS + + & IIPAR * JJPAR * LLPAR * N_TRACERS + + ! if optimizing emissions only + ELSEIF ( LADJ_EMS ) THEN + + NOPT = IIPAR * JJPAR * MMSCL * NNEMS + + IF ( ITS_A_TAGCO_SIM() .AND. NNEMS == 2 ) THEN + NOPT = IIPAR * JJPAR * MMSCL + 1 + ENDIF + + ! Strat prod and loss (hml) + !!IF ( LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + IF ( LADJ_STRAT ) THEN + NOPT = NOPT + IIPAR * JJPAR * MMSCL * NSTPL * 2 + !!NOPT = IIPAR * JJPAR * MMSCL * ( NSTPL * 2 + NNEMS ) + ENDIF + + ! Reaction rates (tww) + !!! To avoid double counting (hml, 06/11/13) + !!IF ( LADJ_RRATE .AND. LADJ_STRAT ) THEN + IF ( LADJ_RRATE ) THEN + NOPT = NOPT + IIPAR * JJPAR * LLPAR * NRRATES + ENDIF + !!NOPT = IIPAR * JJPAR * LLPAR + !! * ( NRRATES+ NNEMS + NSTPL*2 ) + !!ELSEIF ( LADJ_RRATE .AND. .NOT. LADJ_STRAT ) THEN + !!NOPT = IIPAR * JJPAR * LLPAR * ( NRRATES + NNEMS ) + !!ENDIF + + ! if optimizing initial conditions only + ELSEIF ( LICS ) THEN + + NOPT = IIPAR * JJPAR * LLPAR * N_TRACERS + + ENDIF + + PRINT*, 'Max size of control vector is:', NOPT + + ! Return to calling program + END SUBROUTINE CALC_NOPT + +!------------------------------------------------------------------------------ + + SUBROUTINE ITER_CONDITION( IT ) +! +!****************************************************************************** +! Subroutine ITER_CONDITION output information which will be used +! to determine whether the convergence has been reached (zhe 11/28/10) +! +! Variable as Input: +! ============================================================================ +! (1 ) IT : Current iteration number +! +! NOTES: +! (1 ) Place output in DIAGADJ_DIR instead of OPTDATA_DIR (dkh, 02/04/11) +! (2 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC_SAV + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_ADJ_MOD, ONLY : LATF + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER :: IT + + + ! Local variables + INTEGER :: I + REAL*4 :: PG, NG, PS, NS + CHARACTER(LEN=255) :: FILENAME + LOGICAL, SAVE :: FIRST = .TRUE. + + ! For strat prod and loss (hml) + REAL*4 :: PG_P, PG_L, NG_P, NG_L + REAL*4 :: PS_P, PS_L, NS_P, NS_L + + !================================================================= + ! ITER_CONDITION begins here! + !================================================================= + + PG = 0.0 + NG = 0.0 + PS = 0.0 + NS = 0.0 + + ! For strat prod and loss (hml) + PG_P = 0.0 + NG_p = 0.0 + PS_P = 0.0 + NS_P = 0.0 + PG_L = 0.0 + NG_L = 0.0 + PS_L = 0.0 + NS_L = 0.0 + + FILENAME = 'gctm.iteration' + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + IF ( FIRST ) THEN + OPEN (99, FILE = FILENAME, STATUS ='REPLACE') + WRITE(99, 1001) + WRITE(99, 1002) + FIRST = .FALSE. + ENDIF + + ! For strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + DO I = 1, IIPAR * JJPAR + IF ( GRADNT_P(I) .GT. 0 .AND. GRADNT_L(I) .GT. 0 ) THEN + PG_P = PG_P + GRADNT_P(I) + PG_L = PG_L + GRADNT_L(I) + ELSE + NG_P = NG_P + GRADNT_P(I) + NG_L = NG_L + GRADNT_L(I) + ENDIF + + IF ( XP(I) .GT. 1 .AND. XL(I) .GT. 1 ) THEN + PS_P = PS_P + XP(I) - 1 + PS_L = PS_L + XL(I) - 1 + ELSE + NS_P = NS_P + XP(I) - 1 + NS_L = NS_L + XL(I) - 1 + ENDIF + ENDDO + + WRITE(99, 1005) IT, LATF, COST_FUNC_SAV(IT), + & COST_FUNC_SAV(IT)/COST_FUNC_SAV(1), PG_P, PG_L, + & NG_P, NG_L, PS_P, PS_L, NS_P, NS_L + + ELSE + + DO I = 1, IIPAR * JJPAR + IF ( GRADNT(I) .GT. 0 ) THEN + PG = PG + GRADNT(I) + ELSE + NG = NG + GRADNT(I) + ENDIF + + IF ( X(I) .GT. 1 ) THEN + PS = PS + X(I) - 1 + ELSE + NS = NS + X(I) - 1 + ENDIF + ENDDO + + WRITE(99, 1003) IT, LATF, COST_FUNC_SAV(IT), + & COST_FUNC_SAV(IT)/COST_FUNC_SAV(1), PG, NG, PS, NS + + ENDIF + + 1001 format ('GEOS-CHEM ADJOINT CONVERGNECE CONDITION',/,/, + + 'IT = iteration number',/, + + 'A = accepted iteration',/, + + 'F = cost fun',/, + + 'FdF0 = cost fun reduction',/, + + 'PG = total positive gradient',/, + + 'NG = total negative gradient',/, + + 'PS = total underestimated scaling factor',/, + + 'NS = total overestimated scaling factor',/) + + 1002 format (/,3x,'IT',2x,'A',7x,'F',10x,'FdF0',9x,'PG',12x,'NG', + + 10x,'PS',10x,'NS') + 1003 format (3x,i2,2x,L1,2x,E12.6,2x,F8.6,2x,E11.5,2x, + + E12.5,2x,F9.2,2x,F10.2) + +! Strat prod and loss (hml) + 1004 format (/,3x,'IT',2x,'A',7x,'F',10x,'FdF0',9x,'PG_P',12x,'PG_L', + + 12x,'NG_P',10x,'NG_L',10x,'PS_P',10x,'PS_L',10x,'NS_P', + + 10x,'NS_L') + 1005 format (3x,i2,2x,L1,2x,E12.6,2x,F8.6,2x,E11.5,2x,E11.5,2x, + + E12.5,2x,E12.5,2x,F9.2,2x,F9.2,2x,F10.2,2x,F10.2) + + ! Return to calling program + END SUBROUTINE ITER_CONDITION + +!-------------------------------------------------------------------------------- + + SUBROUTINE MAYBE_DO_GEOS_CHEM_ADJ( ) +! +!****************************************************************************** +! Subroutine MAYBE_DO_GEOS_CHEM_ADJ is called for FDTESTS and determines +! whether or not the adjoint model needs to be run. (dkh, 02/21/11) +! +! Module variables as Input: +! ============================================================================ +! (1 ) LFD_GLOB (LOGICAL) : Switch to perform global finite diff test +! (2 ) LFD_SPOT (LOGICAL) : Switch to perform spot finite diff test +! (3 ) N_CALC_STOP (INTEGER) : Current iteration number +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_STOP + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE GEOS_CHEM_ADJ_MOD, ONLY : DO_GEOS_CHEM_ADJ + + !================================================================= + ! MAYBE_DO_GEOS_CHEM_ADJ begins here! + !================================================================= + + ! For global finite difference test we compare the average of + ! two finite difference sensitivities with an adjoint sensitivity + ! around the base case. + IF ( LFD_GLOB ) THEN + + ! Only calculate the adjoint during the first iteration + IF ( N_CALC_STOP == 1 ) THEN + + CALL DO_GEOS_CHEM_ADJ + + ! Don't bother with more than 3 iterations + ELSEIF ( N_CALC_STOP > 3 ) THEN + + CALL ERROR_STOP('To many iterations for FD_GLOB', + & 'inverse_mod.f' ) + ENDIF + + + ! For SPOT finite difference test we compare the average of + ! two adjoint sensitivities with a finite difference sensitivity + ! around the base case + 1/2 FD_DIFF + ELSEIF ( LFD_SPOT ) THEN + + ! calculate the adjoint during the first and second iteration + IF ( N_CALC_STOP == 1 .or. N_CALC_STOP == 2 ) THEN + + CALL DO_GEOS_CHEM_ADJ + + ! Don't bother with more than 2 iteratoins + ELSEIF ( N_CALC_STOP > 2 ) THEN + + CALL ERROR_STOP('To many iterations for FD_SPOT', + & 'inverse_mod.f' ) + ENDIF + + ENDIF + + ! Return to calling program + END SUBROUTINE MAYBE_DO_GEOS_CHEM_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_SAT_DIAGS( ) +! +!****************************************************************************** +! Subroutine DO_SAT_DIAGS writes satellite diagnostics +! (mkeller, 06/15) +! +! NOTES: +! +!****************************************************************************** +! +# include "define_adj.h" ! Obs operator flags + + ! References to F90 modules +#if defined(TES_O3_OBS) || defined(MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS ) + USE HDF5 +#endif + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE LOGICAL_ADJ_MOD, ONLY : LSAT_HDF_L2, LSAT_HDF_L3, LDCOSAT + +#if defined(OMI_NO2_OBS) + !USE OMI_NO2_OBS_MOD, ONLY : MAKE_OMI_BIAS_FILE_HDF5 +#endif + +#if defined(TES_O3_OBS) + USE TES_O3_MOD, ONLY : MAKE_TES_BIAS_FILE_HDF5 +#endif + +#if defined(MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS ) + USE MOPITT_OBS_MOD, ONLY : MAKE_MOPITT_BIAS_FILE_HDF5 +#endif + + ! Local variables + CHARACTER(LEN=255) :: FILENAME_HDF5 + INTEGER :: FILE_ID + INTEGER :: HDF_ERR + + !================================================================= + ! DO_SAT_DIAGS begins here! + !================================================================= + +#if defined(TES_O3_OBS) || defined(MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS ) + ! HDF based diagnostics (mkeller, 06/15) + IF ( LSAT_HDF_L2 .or. LSAT_HDF_L3 ) THEN + + FILENAME_HDF5 = TRIM("satellite_diagnostics.NN.h5") + + CALL EXPAND_NAME( FILENAME_HDF5, N_CALC ) + + FILENAME_HDF5 = TRIM( DIAGADJ_DIR ) // + & TRIM( FILENAME_HDF5 ) + + ! create satellite diagnostic file + CALL H5FCREATE_F( FILENAME_HDF5, H5F_ACC_TRUNC_F, FILE_ID, + & HDF_ERR ) + + +#if defined( OMI_NO2_OBS ) + !CALL MAKE_OMI_BIAS_FILE_HDF5( FILE_ID ) +#endif + +#if defined( TES_O3_OBS ) + CALL MAKE_TES_BIAS_FILE_HDF5( FILE_ID ) +#endif + +#if defined( MOPITT_V5_CO_OBS ) || defined (MOPITT_V6_CO_OBS ) + CALL MAKE_MOPITT_BIAS_FILE_HDF5( FILE_ID ) +#endif + + CALL H5FCLOSE_F( FILE_ID, HDF_ERR ) + + ENDIF +#endif + + !============================================================== + ! Diagnostics (original from mak, non HDF output) + !============================================================== + + ! store satellite diagnostics + ! for now CO, but subroutines all general, just need linking + ! (mak 6/19/09) + IF ( LDCOSAT ) THEN + !Store FORCING, MOP_MOD_DIFF and MODEL_BIAS + !CALL MAKE_FORCING_FILE + !CALL MAKE_MOPMOD_FILE + ! store model, mopitt and model bias to files + ! model + CALL MAKE_SAT_DIAG_FILE( 1 ) + + ! obs and DOFs + IF( N_CALC_STOP == 1) THEN + CALL MAKE_SAT_DIAG_FILE( 2 ) + ENDIF + CALL MAKE_SAT_DIAG_FILE( 6 ) + + CALL MAKE_SAT_DIAG_FILE( 7 ) + + ! model bias (wrt satellite data) + CALL MAKE_SAT_DIAG_FILE( 3 ) + + ! store COST_ARRAY, OBS_COUNT, OBS_HOUR* + CALL MAKE_SAT_DIAG_FILE( 5 ) + + ENDIF + + END SUBROUTINE DO_SAT_DIAGS + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_INVERSE +! +!****************************************************************************** +! Subroutine INIT_INVERSE initializes and zeros all allocatable arrays +! declared in "inverse_mod.f" (dkh, 1/26/05) +! +! NOTES: +! (1 ) Now also allocate EMS_ICS_orig (dkh, 03/29/05) +! (2 ) Now check for incompatible preproc. definitions and ACTIVE_VARS. (dkh, 10/17/06) +! (3 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NOPT + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE, LADJ + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: IS_INIT = .FALSE. + INTEGER :: AS, I + + !================================================================= + ! INIT_INVERSE begins here! + !================================================================= + + ! Return if we have already initialized + IF ( IS_INIT ) RETURN + + !fp + IF ( LADJ ) THEN + + !Allocate arrays + ALLOCATE( GRADNT( NOPT ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GRADNT' ) + + ENDIF + + ALLOCATE( X( NOPT ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'X' ) + + IF ( LADJ_STRAT ) THEN + ALLOCATE( GRADNT_P( IIPAR*JJPAR*MMSCL*NSTPL ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GRADNT_P' ) + + ALLOCATE( GRADNT_L( IIPAR*JJPAR*MMSCL*NSTPL ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GRADNT_L' ) + + ALLOCATE( XP( IIPAR*JJPAR*MMSCL*NSTPL ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'XP' ) + + ALLOCATE( XL( IIPAR*JJPAR*MMSCL*NSTPL ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'XL' ) + + ENDIF + + END SUBROUTINE INIT_INVERSE + +!------------------------------------------------------------------------------ + + + ! Return to calling program + SUBROUTINE CLEANUP_INVERSE +! +!****************************************************************************** +! Subroutine CLEANUP_INVERE deallocates all previously allocated arrays +! for inverse_mod -- call at the end of the program (dkh, 1/26/05) +! +! NOTES: +! (1 ) Now also deallocate EMS_ICS_orig (dkh, 03/29/05) +! (2 ) No longer make EMS_ICS an array in this module (dkh, 06/08/09) +! (3 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + !================================================================= + ! CLEANUP_INVERSE begins here! + !================================================================= + IF ( ALLOCATED( GRADNT ) ) DEALLOCATE( GRADNT ) + IF ( ALLOCATED( X ) ) DEALLOCATE( X ) + + ! Return to calling program + END SUBROUTINE CLEANUP_INVERSE + +!------------------------------------------------------------------------------ + + END MODULE INVERSE_MOD + + diff --git a/code/adjoint/inverse_mod.f~ b/code/adjoint/inverse_mod.f~ new file mode 100644 index 0000000..8216572 --- /dev/null +++ b/code/adjoint/inverse_mod.f~ @@ -0,0 +1,5948 @@ +!$Id: inverse_mod.f,v 1.20 2012/03/04 19:34:15 daven Exp $ + MODULE INVERSE_MOD +! +!***************************************************************************** +! Module INVERSE_MOD contains all the subroutines that used to be in +! inverse.f. While having these routines in the top most program file worked +! on SGI, it didn't work on Linux, so had to move all to a module. +! (dkh, 02/05)! +! Module Variables: +! ============================================================================ +! (1 ) COST_FUNC (REAL*8) : Value of cost function +! (2 ) N_CALC (INTEGER) : Optimization iteration number +! (3 ) N_CALC_STOP (INTEGER) : Maximum optimization iteration number +! (4 ) F (DOUBLE) : For optimization routine +! (5 ) X (DOUBLE, ALLOC): Vector of active varialbes +! (6 ) GRADNT (DOUBLE, ALLOC): Vector of adjoint gradients +! (7 ) XP (DOUBLE, ALLOC): Vector of active strat prod varialbes +! (8 ) GRADNT_P (DOUBLE, ALLOC): Vector of strat prod adjoint gradients +! (9 ) XL (DOUBLE, ALLOC): Vector of active strat loss varialbes +! (10) GRADNT_L (DOUBLE, ALLOC): Vector of adjoint strat loss gradients +! +! Module Routines +! ============================================================================ +! (1 ) SET_SF : Initializes ICS_SF and EMS_SF +! (2 ) SET_LOG_SF : Initializes ICS_SF and EMS_SF for log scaling +! (3 ) GET_X_FROM_SF : Turns SF array into a vector X for optimization +! (4 ) GET_SF_FROM X : Turns vector X into array SF after optimization +! (5 ) GET_GRADNT_FROM_ADJ : Turns ADJ_STT array into vector GRADNT for opt. +! (6 ) MAKE_GDT_FILE : Save GRADNT values at iteration N_CALC to adjtmp/*gdt* +! (7 ) READ_GDT_FILE : Reads saved GRADNT values from previous iterations +! (8 ) MAKE_SF_FILE : Saves SF at iteration N_CALC to adjtmp/*sf* +! (9 ) READ_SF_FILE : Reads saved SF from previous iterations +! (10) EXPAND_NAME : Adds iteration number to file names +! (11) DISPLAY_STUFF : Echo various things at each iteration +! (12) SET_SF_FORFD : Set the scaling factors for finite difference test. +! (13) MAKE_CFN_FILE : Save cost function to cnf.* file +! (14) READ_CFN_FILE : Read cost function from cnf.* file +! (15) SET_OPT_RANGE : Set range of parameters to optimize +! (16) CALC_NOPT : Set range of parameters to optimize +! (17) ITER_CONDITION : Write out iteration diagnostics to gctm.iteration +! (18) MAYBE_DO_GEOS_CHEM_ADJ: For FDTEST determine if need to call adjoint +! (19) DO_SAT_DAIGS : Make satellite diagnostic files +! (20) INIT_INVERSE : Initialize allocatable arrays +! (21) CLEANUP_INVERSE : Deallocatte arrays +! +! Modules referenced by "inverse_mod.f" +! ============================================================================ +! (1 ) bpch2_mod.f : Module containing routines for binary pch file I/O +! (2 ) charpak_mod.f : Module containing string handling routines +! (3 ) error_mod.f : Module containing NaN and other error check routines +! (4 ) file_mod.f : Module containing file unit numbers & error checks +! (5 ) grid_mod.f : Module containing horizontal grid information +! (6 ) restart_mod.f : Module containing CHECK_DIMENSIONS +! (7 ) time_mod.f : Module containing routines to compute time & date +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added subroutine INIT_REGIONAL_ICS (dkh, 02/12/05) +! (3 ) Now use IDADJxxx (03/03/05) +! (4 ) Don't zero the adjoints of NO3, NIT, and NH4 +! (5 ) Now save EMS_ICS from reference run to EMS_ICS_orig, a mod variable +! Also update MAKE_GDT and MAKE_ICS to handle all emissions. +! (dkh, 03/29/05) +! (6 ) Remove all duplicate declarations of N_CALC and N_CALC_STOP. Now this +! is always treated as a module variable. (dkh, 02/15/06) +! (7 ) Update MAKE_ICS_FILE to support writing initial NOx emisions. (dkh, 08/27/06) +! (8 ) Bug fix: change N to 1 in TRACER(I,J,1) while writing scaled +! emissions. (dkh, 10/26/06) +! (9 ) BUG FIX: make ADJ_STT_FD allocatable. (dkh, 03/21/07) +! (10) Update to support LOG_OPT pre-processor option. +! (11) Add support for strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! (12 ) Add / move satellite diagnostic output here (dkh, 06/25/15) +!***************************************************************************** +! + IMPLICIT NONE + +# include "define_adj.h" ! obs operators + + !==================================================================== + ! MODULE VARIABLES ( those that used to be program variables ) + !==================================================================== + !REAL*8, ALLOCATABLE :: EMS_ICS_orig(:,:,:,:) + REAL*8, ALLOCATABLE :: X(:) + REAL*8, ALLOCATABLE :: GRADNT(:) + + !For strat prod & loss SF (hml, 08/11/14) + REAL*8, ALLOCATABLE :: XP(:) + REAL*8, ALLOCATABLE :: GRADNT_P(:) + REAL*8, ALLOCATABLE :: XL(:) + REAL*8, ALLOCATABLE :: GRADNT_L(:) + + !==================================================================== + ! MODULE ROUTINES + !==================================================================== + CONTAINS + +!----------------------------------------------------------------------------- + + SUBROUTINE SET_SF +! +!***************************************************************************** +! Subroutine SET_SF sets the intial conditions used for a GEOS_CHEM run +! (dkh, 9/16/04). +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (3 ) Switch to using IDADJxxx (dkh, 03/03/05) +! (4 ) Rename to SET_SF, replace CMN_ADJ with adjoint_array_mod +! (dkh, ks, mak, cs 06/07/09) +! (5 ) Now get first guesses from input.gcadj file (mak, 9/23/09) +! (6 ) Now use ICS_SF_DEFAULT and ICS_SF_DEFAULT instad of ICS_SF_tmp +! and EMS_SF_tmp. (dkh, 02/09/11) +! (7 ) Now support strat fluxes LADJ_STRAT and add flags to avoid accessing +! unallocated arrays (hml, dkh, 02/20/12, adj32_025) +! +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, ICS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + USE ADJ_ARRAYS_MOD, ONLY : ADCOEMS + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE ADJ_ARRAYS_MOD, ONLY : NFD, MFD, EMSFD + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + !USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_tmp, EMS_SF_tmp + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, PROD_SF0 + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF, LOSS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF, RATE_SF0 + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_DEFAULT + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE TRACERID_MOD, ONLY : IDTOX, IDTNOX + +# include "CMN_SIZE" ! Size params +# include "define_adj.h" ! obs operators + + ! local variables + INTEGER :: I + INTEGER :: J + INTEGER :: L + INTEGER :: M + + !================================================================= + ! SET_SF begins here! + !================================================================= + + + ! Set to defaults or user defined values + IF ( N_CALC_STOP .EQ. 0) THEN + + ! Set default scaling factors to 1d0 everywhere for reference run + ! (perfect model generating pseudo observations) + ICS_SF(:,:,:,:) = 1.d0 + + IF ( LADJ_EMS ) EMS_SF(:,:,:,:) = 1.d0 + + IF ( LADJ_STRAT ) THEN + PROD_SF(:,:,:,:) = 1.d0 + LOSS_SF(:,:,:,:) = 1.d0 + ENDIF + + IF ( LADJ_RRATE ) THEN + RATE_SF(:,:,:,:) = 1.d0 + ENDIF + + ELSE + + ! Now define defaults for all in input.gcadj (dkh, 02/09/11) + !EMS_SF(:,:,:,:) = 1.d0 + !ICS_SF(:,:,:,:) = 1.d0 + !! otherwise, use values from input.gcadj file for ICSFD and EMSFD + !EMS_SF(:,:,:,EMSFD) = EMS_SF_tmp + !ICS_SF(:,:,:,ICSFD) = ICS_SF_tmp +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ICS_SF (I,J,L,:) = ICS_SF_DEFAULT (:) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF ( LADJ_EMS ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + EMS_SF(I,J,M,:) = EMS_SF_DEFAULT(:) + + IF ( LADJ_STRAT ) THEN + PROD_SF(I,J,M,:) = PROD_SF_DEFAULT(:) + LOSS_SF(I,J,M,:) = LOSS_SF_DEFAULT(:) + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Added for reaction rates (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + RATE_SF(I,J,L,:) = RATE_SF_DEFAULT(:) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDIF + ENDIF + + ! the following options for PSEUDO_OBS should not become obsolete + ! We don't even have to remember to change initial SF between pseudo obs + ! and perturbed run, since the adjustment will be made automaticlally above + ! the following #if statement can be removed. + ! one thing we can add is NFD selection to EMS_SF, so that we don't have to + ! perturb all emissions, but only one. not sure if this would be good or + ! would just complicate things... + ! (mak, 9/23/09) + +#if defined ( PSEUDO_OBS ) + + ! Make the initial guess for iteration N_CALC == 1 + ! BUG FIX: make sure this happens every time the optimization + ! cycles through N_CALC = 1 as well. (mak, dkh, 09/08/09) + !IF ( N_CALC == 1 ) THEN +! IF ( N_CALC == 1 +! & .or. ( N_CALC == 0 .and. N_CALC_STOP > 1 ) ) THEN + IF ( N_CALC == 1 .or. + & ( N_CALC == 0 .and. N_CALC_STOP > 0 ) ) THEN + + ! For control parameters = initial conditions + IF ( LICS ) THEN + + ! Now enforce defaults for all set in input.gcadj (dkh, 02/09/11) + !! BUG FIX: enforce defualt scaling factors before using SF_tmp + !! (dkh, 07/30/10) + !ICS_SF(:,:,:,:) = 1.d0 + ! + !print*, 'set ICS_SF to', ICS_SF_tmp + !! Start with an initial guess for ICS_SF that is wrong + !! Let's set the default to perturb everything to avoid + !! hardwiring (mak, 6/18/09) + !! now this is done via input.gcadj file (mak, 9/23/09) + !ICS_SF(:,:,:,ICSFD) = ICS_SF_tmp !0.5d0 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ICS_SF(I,J,L,:) = ICS_SF_DEFAULT(:) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ELSEIF ( LADJ_EMS ) THEN + + ! Now enforce defaults for all set in input.gcadj (dkh, 02/09/11) + !!! BUG FIX: enforce defualt scaling factors before using SF_tmp + !! (dkh, 07/30/10) + !EMS_SF(:,:,:,:) = 1.d0 + ! + !! Start with an initial guess for EMS_SF that is wrong + !EMS_SF(:,:,1,EMSFD) = EMS_SF_tmp +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + EMS_SF(I,J,M,:) = EMS_SF_DEFAULT(:) + + IF ( LADJ_STRAT ) THEN + PROD_SF(I,J,M,:) = PROD_SF_DEFAULT(:) + LOSS_SF(I,J,M,:) = LOSS_SF_DEFAULT(:) + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Added for reaction rates (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + RATE_SF(I,J,L,:) = RATE_SF_DEFAULT(:) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ENDIF + + ENDIF + +#endif + + ! Save a copy of the initial guess of the scaling factors + ! for use later in calculating the a priori penalty term + ICS_SF0 (:,:,:,:) = ICS_SF (:,:,:,:) + + ! Add flags (hml, 02/23/12) + IF ( LADJ_EMS ) EMS_SF0 (:,:,:,:) = EMS_SF (:,:,:,:) + + IF ( LADJ_STRAT ) THEN + PROD_SF0(:,:,:,:) = PROD_SF(:,:,:,:) + LOSS_SF0(:,:,:,:) = LOSS_SF(:,:,:,:) + ENDIF + + IF ( LADJ_RRATE ) THEN + RATE_SF0(:,:,:,:) = RATE_SF(:,:,:,:) + ENDIF + + ! Return to calling program + END SUBROUTINE SET_SF +!----------------------------------------------------------------------------- + + SUBROUTINE SET_LOG_SF +! +!***************************************************************************** +! Subroutine SET_LOG_SF sets the intial conditions used for a GEOS_CHEM run +! (dkh, 9/16/04). +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (3 ) Switch to using IDADJxxx (dkh, 03/03/05) +! (4 ) Rename to SET_LOG_SF, replace CMN_ADJ with adjoint_array_mod +! (dkh, ks, mak, cs 06/07/09) +! (5 ) Now use ICS_SF_DEFAULT and ICS_SF_DEFAULT instad of ICS_SF_tmp +! and EMS_SF_tmp. (dkh, 02/09/11) +! (6 ) Add flags to avoid accessing unallocated arrays +! (hml, dkh, 02/27/12, adj32_025) +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, ICS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE ADJ_ARRAYS_MOD, ONLY : NFD, MFD, EMSFD + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + !USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_tmp, EMS_SF_tmp + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE TRACERID_MOD, ONLY : IDTOX + +# include "CMN_SIZE" ! Size params + + ! Internal varaibles + INTEGER :: I + INTEGER :: J + INTEGER :: L + INTEGER :: M + + + !================================================================= + ! SET_LOG_SF begins here! + !================================================================= + + IF ( LADJ_STRAT ) THEN + CALL ERROR_STOP(' LADJ_STRAT not yet implemented for LOG_OPT', + & ' subroutine SET_LOG_SF, inverse_mod.f ' ) + ENDIF + + IF ( LADJ_RRATE ) THEN + CALL ERROR_STOP(' LADJ_RRATE not yet implemented for LOG_OPT', + & ' subroutine SET_LOG_SF, inverse_mod.f ' ) + ENDIF + + ! Set to defaults or user defined values + ! Add flags (hml, 02/23/12) + IF ( N_CALC_STOP .EQ. 0) THEN + ! Set default scaling factors to 0d0 everywhere for reference run + ! (perfect model generating pseudo observations) + ICS_SF(:,:,:,:) = 0.d0 + IF ( LADJ_EMS ) EMS_SF(:,:,:,:) = 0.d0 + ELSE + + + ! Now define defaults for all in input.gcadj (dkh, 02/09/11) + !EMS_SF(:,:,:,:) = 0.d0 + !ICS_SF(:,:,:,:) = 0.d0 + !! otherwise, use values from input.gcadj file for ICSFD and EMSFD + !EMS_SF(:,:,:,EMSFD) = LOG(EMS_SF_tmp) + !ICS_SF(:,:,:,ICSFD) = LOG(ICS_SF_tmp) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ICS_SF(I,J,L,:) = LOG(ICS_SF_DEFAULT(:)) + + ENDDO + ENDDO + ENDDO + + ! Add flags (hml, 02/23/12) + IF ( LADJ_EMS ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + EMS_SF(I,J,M,:) = LOG(EMS_SF_DEFAULT(:)) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDIF + + +#if defined ( PSEUDO_OBS ) + + ! BUG FIX: make sure this happens every time the optimization + ! cycles through N_CALC = 1 as well. (mak, dkh, 09/08/09) + !IF ( N_CALC == 1 ) THEN +! IF ( N_CALC == 1 +! & .or. ( N_CALC == 0 .and. N_CALC_STOP > 1 ) ) THEN + IF ( N_CALC == 1 .or. + & ( N_CALC == 0 .and. N_CALC_STOP > 0 ) ) THEN + + + ! For control parameters = initial conditions + IF ( LICS ) THEN + + ! Now define defaults for all in input.gcadj (dkh, 02/09/11) + !! BUG FIX: enforce defualt scaling factors before using SF_tmp + !! (dkh, 07/30/10) + !ICS_SF(:,:,:,:) = 0.d0 + ! + !! Start with an initial guess for ICS_SF that is wrong + !ICS_SF(:,:,:,ICSFD) = LOG(ICS_SF_tmp) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ICS_SF(I,J,L,:) = LOG(ICS_SF_DEFAULT(:)) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ENDIF + IF ( LADJ_EMS ) THEN + + ! Now define defaults for all in input.gcadj (dkh, 02/09/11) + !! BUG FIX: enforce defualt scaling factors before using SF_tmp + !!! (dkh, 07/30/10) + !EMS_SF(:,:,:,:) = 0.d0 + ! + !! Start with an initial guess for EMS_SF that is wrong + !EMS_SF(:,:,1,EMSFD) = LOG(EMS_SF_tmp) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + EMS_SF(I,J,M,:) = LOG(EMS_SF_DEFAULT(:)) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ENDIF + +#endif + + ! Save a copy of the initial guess of ICS_SF for regularization + ICS_SF0(:,:,:,:) = ICS_SF(:,:,:,:) + + ! Save a copy of the initial guess of EMS_SF for regularization + ! Add flags (hml, 02/23/12) + IF ( LADJ_EMS ) EMS_SF0(:,:,:,:) = EMS_SF(:,:,:,:) + + + ! Return to calling program + END SUBROUTINE SET_LOG_SF + +!----------------------------------------------------------------------------- + + SUBROUTINE GET_X_FROM_SF +! +!***************************************************************************** +! Subroutine GET_X_FROM_ICS compiles the vector X of initial conditions from +! the array STT_IC. (dkh, 9/16/04) +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (3 ) Rename to SET_LOG_SF, replace CMN_ADJ with adjoint_array_mod +! (dkh, ks, mak, cs 06/07/09) +! (4 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, EMS_SF, MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, NFD + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size params + + ! Local variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + INTEGER :: OFFSET + + !================================================================= + ! GET_X_FROM_SF begins here! + !================================================================= + IF ( LICS ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( L - 1 ) ) + & + ( IIPAR * JJPAR * LLPAR * ( N - 1 ) ) + + ! Load X from active tracer concentrations + X(I_DUM) = ICS_SF(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + !mkeller: + ENDIF + + + !ELSEIF ( LADJ_EMS ) THEN + IF ( LADJ_EMS ) THEN + + IF ( ITS_A_TAGCO_SIM() ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, 1 + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + ! Load X from active tracer concentrations + X(I_DUM) = EMS_SF(I,J,M,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF ( NNEMS == 2 ) THEN + N = 2 + print*, IIPAR*JJPAR*MMSCL,'adding backgnd component to X' + X(IIPAR*JJPAR*MMSCL+1) = EMS_SF(1,1,1,N) + ENDIF + + ELSE +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NNEMS + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + !mkeller: get proper offset for I_DUM + IF ( LICS ) I_DUM = + & I_DUM + IIPAR * JJPAR * LLPAR * N_TRACERS + + ! Load X from active tracer concentrations + X(I_DUM) = EMS_SF(I,J,M,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + OFFSET = IIPAR * JJPAR * MMSCL * NNEMS + + IF ( LADJ_STRAT ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NSTPL + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + ! Load X from active tracer concentrations + XP(I_DUM) = PROD_SF(I,J,M,N) + XL(I_DUM) = LOSS_SF(I,J,M,N) + IF ( I == IFD.and.J == JFD.and.N == NFD )THEN + print*, 'inverse_0: I_DUM = ' , + & I_DUM + print*, 'inverse_0: XL(I_DUM) = ' , + & XL(I_DUM) + print*, 'inverse_0: LOSS_SF = ' , + & LOSS_SF(I,J,M,N) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + X( IIPAR*JJPAR*MMSCL*NNEMS + 1 : + & IIPAR*JJPAR*MMSCL*(NSTPL+NNEMS)) = XP(:) + X( IIPAR*JJPAR*MMSCL*(NSTPL+NNEMS) + 1 : + & IIPAR*JJPAR*MMSCL*(2*NSTPL+NNEMS)) = XL(:) + + ! make OFFSET total number of emissions + strat PL scale factors + OFFSET = IIPAR*JJPAR*MMSCL*(2*NSTPL+NNEMS) + + ENDIF + + ! Reaction rates (tww) + IF ( LADJ_RRATE ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM ) + DO N = 1, NRRATES + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + I_DUM = I + ( IIPAR * (J - 1) ) + & + ( IIPAR * JJPAR * (L - 1) ) + & + ( IIPAR * JJPAR * LLPAR * (N - 1) ) + & + OFFSET + !I_DUM = I_DUM + IIPAR * JJPAR * MMSCL * NNEMS + ! Combine to the I_DUM equation (hml, 06/10/13) + !I_DUM = I_DUM + OFFSET + + ! Load X from active variables + X(I_DUM) = RATE_SF(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ENDIF + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_X_FROM_SF + +!----------------------------------------------------------------------------- + + SUBROUTINE GET_SF_FROM_X +! +!***************************************************************************** +! Subroutine GET_SF_FROM_X compiles the array of scaling factors from +! the vector X. (dkh, 9/16/04) +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (3 ) Rename to SET_LOG_SF, replace CMN_ADJ with adjoint_array_mod +! (dkh, ks, mak, cs 06/07/09) +! (4 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, EMS_SF, NNEMS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, NFD + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size params + + ! Local Variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + INTEGER :: OFFSET + + !================================================================= + ! GET_SF_FROM_X begins here! + !================================================================= + IF ( LICS ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( L - 1 ) ) + & + ( IIPAR * JJPAR * LLPAR * ( N - 1 ) ) + + ! Update the tracer concentrations from X + ICS_SF(I,J,L,N) = X(I_DUM) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + !ELSEIF ( LADJ_EMS ) THEN +!mkeller: + IF ( LADJ_EMS ) THEN + IF ( ITS_A_TAGCO_SIM() ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, 1 + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + ! Update the tracer concentrations from X + EMS_SF(I,J,M,N) = X(I_DUM) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF ( NNEMS == 2 ) THEN + N = 2 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Update the tracer concentrations from X + EMS_SF(I,J,M,N) = X(IIPAR*JJPAR*MMSCL+1) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ELSE + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NNEMS + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + !mkeller: get proper offset for I_DUM + IF ( LICS ) I_DUM = + & I_DUM + IIPAR * JJPAR * LLPAR * N_TRACERS + + ! Update the tracer concentrations from X + EMS_SF(I,J,M,N) = X(I_DUM) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + OFFSET = IIPAR * JJPAR * MMSCL * NNEMS + + ! For strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + XP(:) = X(IIPAR*JJPAR*MMSCL*NNEMS+1: + & IIPAR*JJPAR*MMSCL*(NNEMS+NSTPL)) + XL(:) = X(IIPAR*JJPAR*MMSCL*(NNEMS+NSTPL)+1: + & IIPAR*JJPAR*MMSCL*(NNEMS+2*NSTPL)) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NSTPL + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + + ! Update the tracer concentrations from X + PROD_SF(I,J,M,N) = XP(I_DUM) + LOSS_SF(I,J,M,N) = XL(I_DUM) + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + OFFSET = IIPAR*JJPAR*MMSCL*(NNEMS+2*NSTPL) + + ENDIF + + ! Reaction rates (tww) + IF ( LADJ_RRATE ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM ) + DO N = 1, NRRATES + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + I_DUM = I + ( IIPAR * (J - 1) ) + & + ( IIPAR * JJPAR * (L - 1 ) ) + & + ( IIPAR * JJPAR * LLPAR * (N - 1) ) + !I_DUM = I_DUM + IIPAR * JJPAR * MMSCL * NNEMS + ! Combine to the I_DUM equation (hml, 06/10/13) + I_DUM = I_DUM + OFFSET + + ! Update active variables from X + RATE_SF(I,J,L,N) = X(I_DUM) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ENDIF + ENDIF + + ! Return to calling program + END SUBROUTINE GET_SF_FROM_X + +!----------------------------------------------------------------------------- + + SUBROUTINE GET_GRADNT_FROM_ADJ +! +!***************************************************************************** +! Subroutine GET_GRADNT_FROM_ADJ compiles the gradient vector from the array +! of adjoint values. (dkh, 9/16/04) +! +! NOTES: +! (1 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (2 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (3 ) Don't zero the NIT, NH4 and NO3 gradnts (dkh, 03/03/05) +! (4 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ, LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size params + + ! Local Variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + INTEGER :: I_DUM_TMP + INTEGER :: OFFSET + + !================================================================= + ! GET_GRADNT_FROM_ADJ begins here! + !================================================================= + + IF ( LICS ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( L - 1 ) ) + & + ( IIPAR * JJPAR * LLPAR * ( N - 1 ) ) + + GRADNT(I_DUM) = ICS_SF_ADJ(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !ELSEIF( LADJ_EMS ) THEN +!mkeller: + ENDIF + IF ( LADJ_EMS ) THEN + + IF ( ITS_A_TAGCO_SIM() ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, 1 + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + GRADNT(I_DUM) = EMS_SF_ADJ(I,J,M,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF( NNEMS == 2 ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 2, 2 !NNEMS=2, but get zonal average for bkg + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = (IIPAR*JJPAR*MMSCL) + 1 + + ! KLUDGE: Ask MAK about this. + ! sum zonally + GRADNT(I_DUM) = GRADNT(I_DUM) + EMS_SF_ADJ(I,J,M,N) + + ENDDO + ENDDO + ENDDO + + ! Update to include CH4 oxidation (zhej, 01/16/12, adj32_017) + ! OLD: + !! KLUDGE: Ask MAK about this. + !! average zonally and per layer + !GRADNT(I_DUM) = GRADNT(I_DUM) + & ! / ( IIPAR * JJPAR * LLPAR * MMSCL) + ! NEW: + GRADNT(I_DUM) = GRADNT(I_DUM) / + & ( IIPAR * JJPAR * MMSCL) + + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ELSE + !mkeller: for now don't account for stratospheric production + IF ( .NOT. LADJ_STRAT ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NNEMS + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) +! mkeller: get proper offset for I_DUM + IF ( LICS ) I_DUM = + & I_DUM + IIPAR * JJPAR * LLPAR * N_TRACERS + + GRADNT(I_DUM) = EMS_SF_ADJ(I,J,M,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + OFFSET = IIPAR * JJPAR * MMSCL * NNEMS + + ELSEIF ( LADJ_STRAT ) THEN + + ! For strat prod & loss (hml, 08/29/11) + I_DUM_TMP = IIPAR * JJPAR * MMSCL * NNEMS + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M, N, I_DUM) + DO N = 1, NSTPL + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + I_DUM = I + ( IIPAR * ( J - 1) ) + & + ( IIPAR * JJPAR * ( M - 1 ) ) + & + ( IIPAR * JJPAR * MMSCL * ( N - 1 ) ) + + GRADNT_P(I_DUM) = PROD_SF_ADJ(I,J,M,N) + GRADNT_L(I_DUM) = LOSS_SF_ADJ(I,J,M,N) + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + GRADNT( I_DUM_TMP + 1 : + & I_DUM_TMP + IIPAR * JJPAR * MMSCL * NSTPL ) + & = GRADNT_P(:) + GRADNT( I_DUM_TMP + IIPAR * JJPAR * MMSCL * NSTPL + 1 : + & IIPAR * JJPAR * MMSCL * 2 * NSTPL ) + & = GRADNT_L(:) + + !OFFSET = # of emissions + # of strat prod loss + OFFSET = IIPAR * JJPAR * MMSCL * ( 2 * NSTPL + NNEMS ) + + ENDIF + + !ELSEIF ( LADJ_RRATE ) THEN + IF ( LADJ_RRATE ) THEN + + ! For reaction rates (tww, 05/15/12) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, I_DUM ) + DO N = 1, NRRATES + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + I_DUM = I + ( IIPAR * (J - 1) ) + & + ( IIPAR * JJPAR * (L - 1) ) + & + ( IIPAR * JJPAR * LLPAR * (N - 1) ) + & + OFFSET + !I_DUM = I_DUM + IIPAR*JJPAR*MMSCL*NNEMS + ! Combine to the I_DUM equation (hml, 06/10/13) + !I_DUM = I_DUM + OFFSET + GRADNT(I_DUM) = RATE_SF_ADJ(I,J,L,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDIF + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_GRADNT_FROM_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_GDT_FILE( ) +! +!****************************************************************************** +! Subroutine MAKE_GDT_FILE creates a binary file of ADJ_xxx +! (dkh, 9/17/04) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! (2 ) ICS_SF_ADJ : Array of adjoint gradients to be written +! (3 ) EMS_SF_ADJ : Array of adjoint gradients to be written +! +! NOTES: +! (1 ) Just like MAKE_OBS_FILE except +! - write to .adj. file +! (2 ) Changed name to MAKE_GDT_FILE. Now the .adj. files are trajectories, +! and the .gdt. files are final gradients (dkh, 10/03/04) +! (3 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (4 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (5 ) Now use CATEGORY = 'IJ-GDE-$' for 'EMISSIONS' case. (dkh, 03/29/05) +! (6 ) No longer pass COST_FUNC in the header; use cnf.* files. (dkh, 02/13/06) +! (7 ) Rename everything, replace CMN_ADJ, move nonessential stuff +! to diagnostic files (dkh, ks, mak, cs 06/07/09) +! (8 ) Add normalized gradients IJ-GDEN$ (dkh, 05/06/10) +! (9 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ, LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ID_PROD, ID_LOSS + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + + ! Added for reaction rate sensitivities (tww, 05/08/12) + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ, ID_RRATES + USE GCKPP_ADJ_GLOBAL, ONLY : NCOEFF, NCOEFF_EM, JCOEFF + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NEMIS(NCS) + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, M, N, NK + INTEGER :: NP, NL + INTEGER :: YYYY, MM, DD, HH, SS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) + CHARACTER(LEN=255) :: FILENAME + REAL*4 :: PROD_3D(IIPAR,JJPAR,MMSCL) + REAL*4 :: LOSS_3D(IIPAR,JJPAR,MMSCL) + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + ! Added for reaction rate sensitivity (tww, 05/08/12) + REAL*4 :: RATE_3D(IIPAR,JJPAR,LLPAR) + + CHARACTER(LEN=20) :: OUTPUT_GDT_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + !================================================================= + ! MAKE_GDT_FILE begins here! + !================================================================= + + ! Clear intermediate arrays + EMS_3D (:,:,:) = 0d0 + PROD_3D(:,:,:) = 0d0 + LOSS_3D(:,:,:) = 0d0 + + ! Hardwire output file for now + OUTPUT_GDT_FILE = 'gctm.gdt.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM GDT File: ' // + & 'Final gradient values ' + UNIT = 'none' + CATEGORY = 'IJ-GDT-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_GDT_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the OPTDATA_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_GDT_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + IF ( LICS ) THEN + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = 1, N_TRACERS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,L) = ICS_SF_ADJ (I,J,L,N) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + ENDIF + IF ( LADJ_EMS ) THEN + + ! Reset CATEGORY as labeling in gamap is different + CATEGORY = 'IJ-GDE-$' + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = 1, NNEMS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + EMS_3D(I,J,M) = REAL(EMS_SF_ADJ(I,J,M,N)) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, EMS_3D ) + ENDDO + +! Reset CATEGORY as labeling in gamap is different + CATEGORY = 'IJ-GDEN$' + UNIT = 'none' + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = 1, NNEMS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + EMS_3D(I,J,M) = REAL(EMS_SF_ADJ(I,J,M,N)) + & / COST_FUNC + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, EMS_3D ) + ENDDO + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + + !============================================================== + ! Write each observed quantity to the observation file + !============================================================== + DO N = 1, NSTPL + NP = ID_PROD(N) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + PROD_3D(I,J,M) = REAL(PROD_SF_ADJ(I,J,M,N)) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !Temporarily store quantities in the PROD_3D, LOSS_3D array + CATEGORY = 'IJ-GDP-$' + UNIT = 'J' + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NP, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, PROD_3D ) + + ENDDO + + ! Strat loss + DO N = 1, NSTPL + NL = ID_LOSS(N) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + LOSS_3D(I,J,M) = REAL(LOSS_SF_ADJ(I,J,M,N)) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CATEGORY = 'IJ-GDL-$' + UNIT = 'J' + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NL, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, LOSS_3D ) + + + ENDDO + ENDIF + ENDIF + + ! Added block for reaction rate sensitivity output (tww, 05/08/12) + IF ( LADJ_RRATE ) THEN + + !================================================================= + ! Write each observed quantity to the observation file + !================================================================= + DO N = NCOEFF_EM+1, NCOEFF + + ! Temporarily store quantities in the TRACER array + CATEGORY = 'IJ-RATE$' + ! Before it is normalized (hml, 06/11/13) + !UNIT = 'none' + UNIT = 'J' + + NK = ID_RRATES(N-NCOEFF_EM) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + RATE_3D(I,J,L) = REAL(RATE_SF_ADJ(I,J,L,N-NCOEFF_EM)) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NK, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, RATE_3D ) + ENDDO + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_GDT_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_GDT_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_GDT_FILE ( ) +! +!****************************************************************************** +! Subroutine READ_GDT_FILE reads the gctm.gdt file into ADJ_xxx +! (dkh, 9/17/04) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! +! Notes +! (1 ) now called GDT instead of ADJ +! (2 ) Added ACTIVE_VARS == 'EMISSIONS' case. (dkh, 11/27/04) +! (3 ) Added ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (4 ) Now use CATEGORY = 'IJ-GDE-$' for EMISSIONS case. (dkh, 03/29/05) +! (5 ) No longer pass COST_FUNC in the header; use cnf.* files. (dkh, 02/13/06) +! (6 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ,LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + USE ADJ_ARRAYS_MOD, ONLY : ID_RRATES + + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_MOD, ONLY : LPRT + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Local Variables + INTEGER :: I, IOS, J, L, M, N, XX + REAL*4, ALLOCATABLE :: TEMP(:,:,:) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: N_LICS, N_EMS, N_RATE + INTEGER :: N_STRAT_PROD, N_STRAT_LOSS + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + CHARACTER(LEN=20) :: INPUT_GDT_FILE + + !================================================================= + ! READ_GDT_FILE begins here! + !================================================================= + + ! Hardwire output file for now + INPUT_GDT_FILE = 'gctm.gdt.NN' + + ! Initialize some variables + N_LICS = 1 + N_EMS = 1 + N_STRAT_PROD = 1 + N_STRAT_LOSS = 1 + N_RATE = 1 + IOS = 0 + + IF ( LLPAR > MMSCL ) THEN + XX = LLPAR + ELSE + XX = MMSCL + ENDIF + + ALLOCATE(TEMP(IIPAR,JJPAR,XX)) + TEMP(:,:,:) = 0e0 + + !================================================================= + ! Open gradient file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_GDT_FILE ) + + ! Replace NN tokens in FILENAME w/ actual values + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add OPTDATA_DIR prefix to FILENAME + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'G D T F I L E I N P U T' + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_GDT_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + !================================================================= + ! Read adjoints -- store in the TRACER array + !================================================================= + DO WHILE ( .NOT. IOS < 0 ) + + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES , LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TEMP(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_gdt_file:6') + + !============================================================== + ! Assign data from the TRACER array to the ADJ_STT array. + !============================================================== + + SELECT CASE ( CATEGORY(1:8) ) + + ! Only process observation data (i.e. aerosol and precursors) + CASE ( 'IJ-GDT-$' ) + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + + ICS_SF_ADJ(:,:,:,N_LICS) = TEMP(:,:,1:LLPAR) + + N_LICS = N_LICS + 1 + + ! Only process observation data (i.e. aerosol and precursors) + CASE ( 'IJ-GDE-$' ) + + EMS_SF_ADJ(:,:,:,N_EMS) = TEMP(:,:,1:MMSCL) + + N_EMS = N_EMS + 1 + + ! Only process observation data (i.e. aerosol and precursors) + CASE ( 'IJ-GDP-$' ) + + PROD_SF_ADJ(:,:,:,N_STRAT_PROD) = TEMP(:,:,1:MMSCL) + + N_STRAT_PROD = N_STRAT_PROD + 1 + + ! Only process observation data (i.e. aerosol and precursors) + CASE ( 'IJ-GDL-$' ) + + LOSS_SF_ADJ(:,:,:,N_STRAT_LOSS) = TEMP(:,:,1:MMSCL) + + N_STRAT_LOSS = N_STRAT_LOSS + 1 + + CASE ( 'IJ-RATE$' ) + + RATE_SF_ADJ(:,:,:,N_RATE) = TEMP(:,:,1:LLPAR) + + N_RATE = N_RATE + 1 + + END SELECT + ENDDO + + IF ( LICS ) THEN + + IF ( N_TRACERS .NE. N_LICS - 1 ) CALL ERROR_STOP( + & ' Invalid number LICS found ' , 'READ_GDT_FILE' ) + + ENDIF + + IF ( LADJ_EMS ) THEN + + IF ( NNEMS .NE. N_EMS - 1 ) CALL ERROR_STOP( + & ' Invalid number EMS found ' , 'READ_GDT_FILE' ) + + ENDIF + + IF ( LADJ_STRAT ) THEN + + IF ( NSTPL .NE. N_STRAT_PROD - 1 ) CALL ERROR_STOP( + & ' Invalid number STRAT_PROD found ' , 'READ_GDT_FILE' ) + + IF ( NSTPL .NE. N_STRAT_LOSS - 1 ) CALL ERROR_STOP( + & ' Invalid number STRAT_LOSS found ' , 'READ_GDT_FILE' ) + + ENDIF + + IF ( LADJ_RRATE ) THEN + + IF ( NRRATES .NE. N_RATE - 1 ) CALL ERROR_STOP( + & ' Invalid number RRATES found ' , 'READ_GDT_FILE' ) + + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_GDT_FILE: read file' ) + + ! Return to calling program + END SUBROUTINE READ_GDT_FILE + +! needs to be updated +!----------------------------------------------------------------------- +! +! SUBROUTINE MAKE_GDT_DIAG_FILE( ) +!! +!!****************************************************************************** +!! Subroutine MAKE_GDT_DIAG_FILE creates a binary file of daignostics +!! relatied to the adjoint gradients. (dkh, 06/07/09) +!! (dkh, 9/17/04) +!! +!! Module Variable as Input: +!! ============================================================================ +!! (1 ) N_CALC : Current iteration number +!! (2 ) ICS_SF_ADJ : Array of adjoint gradients to be written +!! (3 ) EMS_SF_ADJ : Array of adjoint gradients to be written +!! (4 ) ADJ_BURNEMIS : Array of biomass burning sensitivities +!! (5 ) ADJ_BIOFUEL : Array of biofuel sensitivities +!! (6 ) ADJ_EMISRR : +!! (7 ) ADJ_EMISRRB : +!! +!! NOTES: +!! +!!****************************************************************************** +!! +! ! References to F90 modules +! USE ADJ_ARRAYS_MOD, ONLY : ADJ_BURNEMIS +! USE ADJ_ARRAYS_MOD, ONLY : ADJ_BIOFUEL +! USE ADJ_ARRAYS_MOD, ONLY : ADJ_EMISRR +! USE ADJ_ARRAYS_MOD, ONLY : ADJ_EMISRRB +! USE BPCH2_MOD +! USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR +! USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU +! USE BIOMASS_MOD, ONLY : NBIOTRCE +! USE BIOFUEL_MOD, ONLY : NBFTRACE +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN" ! LPRT +!# include "comode.h" ! NEMIS(NCS) +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, M, N +! INTEGER :: YYYY, MM, DD, HH, SS +! REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +! REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) +! CHARACTER(LEN=255) :: FILENAME +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! CHARACTER(LEN=20) :: OUTPUT_GDT_FILE +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! +! !================================================================= +! ! MAKE_GDT_FILE begins here! +! !================================================================= +! +! ! Clear intermediate arrays +! EMS_3D(:,:,:) = 0d0 +! +! ! Hardwire output file for now +! OUTPUT_GDT_FILE = 'gctm.gdt.diag.NN' +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM GDT File: ' // +! & 'Gradient diagnostics ' +! LONRES = DISIZE +! LATRES = DJSIZE +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the adjoint file for output -- binary punch format +! !================================================================= +! +! ! Copy the output observation file name into a local variable +! FILENAME = TRIM( OUTPUT_GDT_FILE ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! +! ! Add the OPTDATA_DIR prefix to the file name +! FILENAME = TRIM( DIAGADJTMP_DIR ) // TRIM( FILENAME ) +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_GDT_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +! !================================================================= +! ! Normalized sensitivies +! !================================================================= +! +! ! Reset CATEGORY as labeling in gamap is different +! CATEGORY = 'IJ-GDEN$' +! UNIT = '%' +! +! !================================================================= +! ! Write each observed quantity to the observation file +! !================================================================= +! DO N = 1, NNEMS +! +! ! Temporarily store quantities in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M ) +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! EMS_3D(I,J,M) = REAL(ADJ_EMS(I,J,M,N)) / COST_FUNC +! & * 100d0 +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N + NNEMS, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ENDDO +! +! +! !================================================================= +! ! Normalized VOC sensitivies - EMISRR (anthro hydrocarbons) +! !================================================================= +! CATEGORY = 'DEMISRR' +! DO N = 1, NEMIS(NCS) +! +! ! Temporarily store quantities in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! EMS_3D(I,J,1) = REAL(ADJ_EMISRR(I,J,N)) / COST_FUNC +! & * 100d0 +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! dkh debug +! print*, ' ADJ EMISRR = ', maxval(adj_emisrr(:,:,n)), n +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! ENDDO +! +! +! !================================================================= +! ! Normalized VOC sensitivies - EMISRRB (biogenic hydrocarbons) +! !================================================================= +! CATEGORY = 'DEMISRRB' +! DO N = 1, NEMIS(NCS) +! +! ! Temporarily store quantities in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! EMS_3D(I,J,1) = REAL(ADJ_EMISRRB(I,J,N)) / COST_FUNC +! & * 100d0 +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! dkh debug +! print*, ' ADJ EMISRRB = ', maxval(adj_emisrrb(:,:,n)), n +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! ENDDO +! +! !================================================================= +! ! Normalized VOC sensitivies - BOIFUEL +! !================================================================= +! CATEGORY = 'DBIOFUEL' +! DO N = 1, NBFTRACE +! +! ! Temporarily store quantities in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! EMS_3D(I,J,1) = REAL(ADJ_BIOFUEL(I,J,N)) / COST_FUNC +! & * 100d0 +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ! dkh debug +! print*, ' ADJ BIOFUEL= ', maxval(ADJ_BIOFUEL(:,:,n)), n +! +! ENDDO +! +! +! !================================================================= +! ! Normalized VOC sensitivies - BURNEMIS +! !================================================================= +! CATEGORY = 'DBURNEMIS' +! DO N = 1, NBIOTRCE +! +! ! Temporarily store quantities in the TRACER array +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! EMS_3D(I,J,1) = REAL(ADJ_BURNEMIS(I,J,N)) / COST_FUNC +! & * 100d0 +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ! dkh debug +! print*, ' ADJ BURNEMIS= ', maxval(ADJ_BURNEMIS(:,:,n)), n +! +! ENDDO +! +! ! Close file +! CLOSE( IU_RST ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_GDT_DIAG_FILE: wrote file' ) +! +! ! Return to calling program +! END SUBROUTINE MAKE_GDT_DIAG_FILE +! +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_SF_FILE ( ) +! +!****************************************************************************** +! Subroutine MAKE_SF_FILE creates a binary file of STT_IC or EMS_ICS +! (dkh, 9/17/04) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! (2 ) ICS_SF : Initial conditions scaling factors +! (3 ) EMS_SF : Emissions scaling factors +! +! NOTES: +! (1 ) Just like MAKE_ADJ_FILE except +! - write to .ics. file +! (2 ) Add support for ACTIVE_VARS == 'EMISSIONS' case (dkh, 11/27/04) +! (3 ) Add support for ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (4 ) Change UNIT to unitless and change title to Scale factors (dkh, 03/06/05) +! (5 ) Change output for ACTIVE_VARS == 'EMISSIONS' case. +! Now use label IJ-EMS-$, and update gamap code accordingly. +! First write the scaling factors, in consecutive species. Temporal +! varations in the emissions, if any, will be in the L direction. +! Next, write out the optimized emissions themselves. +! Finally, write out the difference between orig and optimized emissions. +! (dkh, 03/28/05) +! (6 ) Use EMS_orig instead of ESO4_an_orig so that we can loop over N. +! (7 ) Update to add support for writing NOx emissions. (dkh, 08/27/06) +! (8 ) Only write the value of the scaling facotr in locations where the +! actual emission is greater than zero. Also include the current +! scale emissions themselves in every *ics* file. (dkh, 09/22/06) +! (9 ) Add suppport for LOG_OPT +! (10) Standardize units for saving emissions. (dkh, 06/16/07) +! (11) Add option to print prior and posterior emissions totals. (dkh, 06/16/07) +! (12) Change names, replace CMN_ADJ. (dkh, ks, mak, cs 06/08/09) +! (13) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, ICS_SF, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_TOTAL, EMS_SF_DEFAULT + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : ID_PROD, ID_LOSS + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF, ID_RRATES + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + USE GCKPP_ADJ_GLOBAL, ONLY : NCOEFF, NCOEFF_EM, JCOEFF + + USE BPCH2_MOD + USE DIRECTORY_MOD, ONLY : TEMP_DIR + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TIME_MOD, ONLY : GET_TS_EMIS + USE TIME_MOD, ONLY : GET_TAUb, GET_TAUe + USE TRACER_MOD, ONLY : N_TRACERS + + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! EMISRN +# include "comode.h" ! NEMIS(NCS) + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, M, N, NK + INTEGER :: NP, NL + INTEGER :: YYYY, MM, DD, HH, SS + INTEGER :: NOFFSET + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + CHARACTER(LEN=255) :: FILENAME + REAL*8 :: TEMP + REAL*8 :: NEMIS_DT + REAL*8 :: USA_MASK(IIPAR,JJPAR) + REAL*8 :: EMS_TOTAL(NNEMS) + REAL*4 :: EMS_PERCENT(IIPAR,JJPAR,NNEMS) + LOGICAL, PARAMETER :: LPRINT_TOTAL = .TRUE. + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: OUTPUT_SF_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + ! Parameters + REAL*8, PARAMETER :: SEC_PER_YEAR = 3.1536d7 + REAL*8, PARAMETER :: MIN_PER_YEAR = 5.2560d5 + REAL*8, PARAMETER :: TG_PER_KG = 1d-09 + + !================================================================= + ! MAKE_SF_FILE begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_SF_FILE = 'gctm.sf.NN' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM SF File: ' // + & 'Scale Factors' + UNIT = 'unitless' + CATEGORY = 'IJ-ICS-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_SF_FILE ) + + ! Replace NN token w/ actual value + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add OPTDATA_DIR prefix to FILENAME + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_SF_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + IF ( LICS ) THEN + + CATEGORY = 'IJ-ICS-$' + + !================================================================= + ! Write each observed quantity to the ics file + !================================================================= + DO N = 1, N_TRACERS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,L) = ICS_SF(I,J,L,N) + ENDDO + ENDDO + ENDDO + +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + ENDIF + + IF ( LADJ_EMS ) THEN + + CATEGORY = 'IJ-EMS-$' + UNIT = 'unitless' + + !================================================================= + ! Write each observed quantity to the ics file + !================================================================= + DO N = 1, NNEMS + + !Temporarily store quantities in the TRACER array + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M , TEMP ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + + TRACER(I,J,M) = EMS_SF(I,J,M,N) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + IF ( LADJ_STRAT ) THEN + + !============================================================== + ! Write each observed quantity to the ics file + !============================================================== + DO N = 1, NSTPL + NP = ID_PROD(N) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,M) = PROD_SF(I,J,M,N) + ENDDO + ENDDO + ENDDO + +!$OMP END PARALLEL DO + + !Temporarily store quantities in the TRACER array + CATEGORY = 'IJ-STRP$' + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NP, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + DO N = 1, NSTPL + NP = ID_LOSS(N) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,M) = LOSS_SF(I,J,M,N) + ENDDO + ENDDO + ENDDO + +!$OMP END PARALLEL DO + + CATEGORY = 'IJ-STRL$' + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NL, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, MMSCL, I0+1, + & J0+1, 1, TRACER ) + + ENDDO + ENDIF + + IF ( LADJ_RRATE ) THEN + + !============================================================== + ! Write each observed quantity to the ics file + !============================================================== + DO N = NCOEFF_EM+1, NCOEFF + + NK = ID_RRATES(N-NCOEFF_EM) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + TRACER(I,J,L) = RATE_SF(I,J,L,N-NCOEFF_EM) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + CATEGORY = 'IJ-RATSF' + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NK, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, LLPAR, I0+1, + & J0+1, 1, TRACER ) + ENDDO + + ENDIF + + ENDIF + + + !### Debug + + IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_SF_FILE: wrote file' ) + + ! Return to calling program + END SUBROUTINE MAKE_SF_FILE +! needs to be updated: +!!------------------------------------------------------------------------------ +! +! SUBROUTINE MAKE_SF_DIAG_FILE ( ) +!! +!!****************************************************************************** +!! Subroutine MAKE_SF_DIAG_FILE creates a binary file of diagnostics +!! related to scaling factor values. (dkh, 06/08/09) +!! +!! Module Variable as Input: +!! ============================================================================ +!! (1 ) N_CALC : Current iteration number +!! (2 ) ICS_SF : Initial conditions scaling factors +!! (3 ) EMS_SF : Emissions scaling factors +!! +!! NOTES: +!! (1) Split this off from MAKE_ICS_FILE (dkh, ks, mak, cs 06/08/09) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, ICS_SF +! USE BPCH2_MOD +! USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP +! USE DIRECTORY_MOD, ONLY : TEMP_DIR +! USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJTMP_DIR +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET, GET_AREA_CM2 +! USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU +! USE TIME_MOD, ONLY : GET_TS_CHEM +! USE TIME_MOD, ONLY : GET_TS_EMIS +! USE TIME_MOD, ONLY : GET_TAUb, GET_TAUe +! USE TRACERID_MOD, ONLY : IDTNH3, IDTNOX, IDTBCPI, IDTSO2 +! USE SULFATE_MOD, ONLY : EMS_orig +! USE LIGHTNING_NOX_MOD, ONLY : EMS_orig_li +! USE EMISSIONS_MOD, ONLY : BIOFUEL_orig +! USE EMISSIONS_MOD, ONLY : BURNEMIS_orig +! USE EMISSIONS_MOD, ONLY : EMISRR_orig +! USE EMISSIONS_MOD, ONLY : EMISRRB_orig +! USE BIOMASS_MOD, ONLY : NBIOTRCE +! USE BIOFUEL_MOD, ONLY : NBFTRACE +! USE DAO_MOD, ONLY : BXHEIGHT +! +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN" ! LPRT, LLIGHTNOX +!# include "CMN_O3" ! EMISRN +!# include "comode.h" ! NEMIS(NCS) +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, M, N +! INTEGER :: YYYY, MM, DD, HH, SS +! INTEGER :: NOFFSET +! REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +! REAL*4 :: TRACER_VOC(IIPAR,JJPAR,20) +! REAL*4 :: TRACER_US(IIPAR,JJPAR,LLPAR) +! CHARACTER(LEN=255) :: FILENAME +! REAL*8 :: TEMP +! REAL*8 :: NEMIS_DT +! REAL*8 :: USA_MASK(IIPAR,JJPAR) +! REAL*8 :: EMS_TOTAL(NNEMS) +! REAL*4 :: EMS_PERCENT(IIPAR,JJPAR,NNEMS) +! LOGICAL, PARAMETER :: LPRINT_TOTAL = .TRUE. +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! CHARACTER(LEN=20) :: OUTPUT_SF_DIAG_FILE +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! +! ! Parameters +! REAL*8, PARAMETER :: SEC_PER_YEAR = 3.1536d7 +! REAL*8, PARAMETER :: MIN_PER_YEAR = 5.2560d5 +! REAL*8, PARAMETER :: TG_PER_KG = 1d-09 +! +! !================================================================= +! ! MAKE_SF_DIAG_FILE begins here! +! !================================================================= +! +! ! Hardwire output file for now +! OUTPUT_SF_DIAG_FILE = 'gctm.sf.diag.NN' +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM SF File: ' // +! & 'Scale Factors Diagnostics' +! UNIT = 'unitless' +! LONRES = DISIZE +! LATRES = DJSIZE +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the adjoint file for output -- binary punch format +! !================================================================= +! +! ! Copy the output observation file name into a local variable +! FILENAME = TRIM( OUTPUT_SF_DIAG_FILE ) +! +! ! Replace NN token w/ actual value +! CALL EXPAND_NAME( FILENAME, N_CALC ) +! +! ! Add OPTDATA_DIR prefix to FILENAME +! FILENAME = TRIM( DIAGADJTMP_DIR ) // TRIM( FILENAME ) +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_SF_DIAG_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +! IF ( NEMS ) THEN +! +! +! ! Also write the actual emissions. +! ! Go ahead and include this every time. +! CATEGORY = 'IJ-EM0-$' +! UNIT = 'molecule/cm2/s' +! +! ! emdt / sim = hr / sim * min / hr * emdt / min +! NEMIS_DT = ( GET_TAUe() - GET_TAUb() ) * 60d0 / GET_TS_EMIS() +! +! DO N = 1, NNEMS +! +! ! Compile TRACER [ molec / cm2 / s ] +! ! Get the actual emission in the current cell +! ! Original emissions are in EMS_orig, but in a variety of unit +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! lightning NOx +! IF ( N == IDADJEMS_ENOxli ) THEN +! +! ! Add to prevent allocation segfault (dkh, 10/10/08) +! IF ( LLIGHTNOX ) THEN +! +! ! molec NOx / cm2 / s total sim -> molec NOx / cm2 / s +! TRACER(I,J,N) = EMS_orig_li(I,J) +! & / NEMIS_DT ! number of emissions +! +! ELSE +! TRACER(I,J,N) = 0D0 +! ENDIF +! +! +! ! soil NOx +! ELSEIF ( N == IDADJEMS_ENOxso ) THEN +! +! ! molec NOx / cm2 / s total -> molec / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & / NEMIS_DT ! number of emissions +! +! +! ! BC / OC +! ELSEIF ( N == IDADJEMS_BCan .or. N == IDADJEMS_OCan .or. +! & N == IDADJEMS_BCbb .or. N == IDADJEMS_OCbb .or. +! & N == IDADJEMS_BCbf .or. N == IDADJEMS_OCbf ) +! & THEN +! +! ! Convert from kg / yr to molec C / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * XNUMOL(IDTBCPI) +! & / GET_AREA_CM2(J) +! & / SEC_PER_YEAR +! +! +! ! Anth NOx +! ELSEIF ( N == IDADJEMS_ENOx1 .or. N == IDADJEMS_ENOx2 ) +! & THEN +! +! ! Convert from kg / box / emdt to molec / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * XNUMOL(IDTNOX) +! & / GET_AREA_CM2(J) +! & / ( GET_TS_EMIS() * 60.d0 ) ! seconds per emdt +! +! ! NH3 +! ELSEIF ( N == IDADJEMS_ENH3_an .or. +! & N == IDADJEMS_ENH3_na .or. +! & N == IDADJEMS_ENH3_bb .or. +! & N == IDADJEMS_ENH3_bf ) +! & THEN +! +! ! Convert from kg NH3 / box / s to molec / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * XNUMOL(IDTNH3) +! & / GET_AREA_CM2(J) +! +! ! SO2 +! ELSEIF ( N == IDADJEMS_ESO2_bb .or. +! & N == IDADJEMS_ESO2_bf .or. +! & N == IDADJEMS_ESO2_sh ) +! & THEN +! +! ! Convert from kg SO2 / box / s to molec / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * XNUMOL(IDTSO2) +! & / GET_AREA_CM2(J) +! +! ! Volcano SO2 emissions (dkh, cklee 09/14/08) +! ELSEIF ( N == IDADJEMS_ESO2_ev .or. !(added,cklee) +! & N == IDADJEMS_ESO2_nv ) !(added,cklee) +! & THEN +! ! Convert from kg SO2 / box / s total to molec / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * XNUMOL(IDTSO2) +! & / GET_AREA_CM2(J) +! & / NEMIS_DT +! +! ! Anth SOx +! ELSEIF ( N == IDADJEMS_ESOx1 .or. +! & N == IDADJEMS_ESOx2 ) THEN +! +! ! it's already in molec SOx / cm2 / s +! TRACER(I,J,N) = EMS_orig(I,J,N) +! +! ELSE +! +! CALL ERROR_STOP('undefined emissions', +! & 'inverse_mod.f') +! ENDIF +! +!#if defined ( LOG_OPT ) +! ! Apply current scaling +! TRACER(I,J,N) = TRACER(I,J,N) * EXP(EMS_ICS(I,J,1,N)) +! +!#else +! ! Apply current scaling +! TRACER(I,J,N) = TRACER(I,J,N) * EMS_ICS(I,J,1,N) +!#endif +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 50+N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER(:,:,N) ) +! +! ENDDO +! +! +! ! Also write the normalized emissions +! CALL READ_USA_MASK( USA_MASK ) +! CATEGORY = 'IJ-EMP-$' +! UNIT = '%' +! +! EMS_TOTAL(:) = 0d0 +! EMS_PERCENT(:,:,:) = 0d0 +! +! DO N = 1, NNEMS +! +! ! Note: not in parallel, would need another tmp array for that +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! IF ( USA_MASK(I,J) > 0d0 ) THEN +! +! EMS_TOTAL(N) = EMS_TOTAL(N) +! & + TRACER(I,J,N) * GET_AREA_CM2(J) +! ENDIF +! +! ENDDO +! ENDDO +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! IF ( EMS_TOTAL(N) == 0d0 .or. +! & USA_MASK(I,J) == 0d0 ) THEN +! +! ! Not sure what to store as "actual emission" for lightning NOx +! EMS_PERCENT(I,J,N) = 0d0 +! +! ELSE +! +! ! emissions percentages +! EMS_PERCENT(I,J,N) = TRACER(I,J,N) * GET_AREA_CM2(J) +! & / EMS_TOTAL(N) * 100d0 +! +! ENDIF +! +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, 50+N+NNEMS, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, EMS_PERCENT(:,:,N) ) +! +! ! dkh debug +! print*, 'EMS_PERCENT total = ', SUM(EMS_PERCENT(:,:,N)), N +! +! ENDDO +! +! !NOFFSET = 0 +! +! ! VOC emissions -- anth hydrocarbons (EMISRR) +! CATEGORY = 'EMISRR' +! print*, 'make_ics db: nemis = ', NEMIS(NCS) +! DO N = 1, NEMIS(NCS) +! +! ! Compile TRACER [ molec / cm2 / s ] +! ! Get the actual emission in the current cell +! ! Original emissions are in EMS_orig, but in a variety of unit +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! molec C / box / s total sim -> molec C / cm2 / s +! TRACER_VOC(I,J,N) = EMISRR_orig(I,J,N) +! & / GET_AREA_CM2(J) +! & / NEMIS_DT +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_VOC(:,:,N) ) +! +! ! dkh debug +! print*, 'max EMISRR = ', MAXVAL(EMISRR_orig(:,:,N)), N +! +! ENDDO +! +! ! VOC emissions -- biogenic hydrocarbons (EMISRRB) +! CATEGORY = 'EMISRRB' +! DO N = 1, NEMIS(NCS) +! +! ! Compile TRACER [ molec / cm2 / s ] +! ! Get the actual emission in the current cell +! ! Original emissions are in EMS_orig, but in a variety of unit +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! molec C / box / s total sim -> molec C / cm2 / s +! TRACER_VOC(I,J,N) = EMISRRB_orig(I,J,N) +! & / GET_AREA_CM2(J) +! & / NEMIS_DT +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_VOC(:,:,N) ) +! +! ! dkh debug +! print*, 'max EMISRRB = ', MAXVAL(EMISRRB_orig(:,:,N)), N +! +! ENDDO +! !NOFFSET = NOFFSET + NEMIS(NCS) +! +! ! VOC emissions - BIOFUEL +! CATEGORY = 'BIOFUEL' +! DO N = 1, NBFTRACE +! +! ! Compile TRACER [ molec / cm2 / s ] +! ! Get the actual emission in the current cell +! ! Original emissions are in EMS_orig, but in a variety of unit +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! molec C / cm3 / s total sim -> molec C / cm2 / s +! TRACER_VOC(I,J,N) = BIOFUEL_orig(N,I,J) +! & * BXHEIGHT(I,J,1) * 100d0 +! & / NEMIS_DT +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_VOC(:,:,N) ) +! +! ! dkh debug +! print*, 'max BIOFUEL = ', MAXVAL(BIOFUEL_orig(N,:,:)), N +! +! ENDDO +! +! !NOFFSET = NOFFSET + NBFTRACE +! +! ! VOC emissions - BURNEMIS +! CATEGORY = 'BURNEMIS' +! DO N = 1, NBIOTRCE +! +! ! Compile TRACER [ molec / cm2 / s ] +! ! Get the actual emission in the current cell +! ! Original emissions are in EMS_orig, but in a variety of unit +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! molec C / cm3 / s total sim -> molec C / cm2 / s +! TRACER_VOC(I,J,N) = BURNEMIS_orig(N,I,J) +! & * BXHEIGHT(I,J,1) * 100d0 +! & / NEMIS_DT +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, 1, I0+1, +! & J0+1, 1, TRACER_VOC(:,:,N) ) +! +! ! dkh debug +! print*, 'max BURNEMIS= ', MAXVAL(BURNEMIS_orig(N,:,:)), N +! +! ENDDO +! +! ENDIF +! +! ! Close file +! CLOSE( IU_RST ) +! +! IF ( LPRINT_TOTAL ) THEN +! ! print out scaled emissions totals +! CALL READ_USA_MASK( USA_MASK ) +! +! ! Tracer is now going to be in units of Tg X / yr / box +! TRACER =0d0 +! TRACER_US=0d0 +! +! IF ( NNEMS > LLPAR ) CALL ERROR_STOP('baddd','inverse_mod') +! +! DO N = 1, NNEMS +! +! ! Units of emission for NOx from EMISRN are different +! ! Units of carbon emission also different. Skip em +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Get the actual emission in the current cell +! +! ! lightning NOx +! IF ( N == IDADJEMS_ENOxli ) THEN +! IF ( LLIGHTNOX ) THEN +! +! ! molec NOx / cm2 / s -> Tg N / yr +! TRACER(I,J,N) = EMS_orig_li(I,J) +! & / NEMIS_DT ! number of emissions +! & * SEC_PER_YEAR ! s/yr +! & * GET_AREA_CM2(J) ! cm^2 +! & / XNUMOL(IDTNOX) ! molec / kg of NO2 +! & * TG_PER_KG ! Tg / kg +! & * 14.d0 / 46.d0 ! g N / g NO2 +! +! TRACER_US(I,J,N) = TRACER(I,J,N) * USA_MASK(I,J) +! ELSE +! TRACER(I,J,N) = 0d0 +! TRACER_US(I,J,N) = 0d0 +! ENDIF +! +! ! soil NOx +! ELSEIF ( N == IDADJEMS_ENOxso ) THEN +! +! ! Not sure what to store as "actual emission" for soil NOx +! !TRACER(I,J,N) = 0d0 +! ! molec NOx / cm2 / s total -> Tg N / yr +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & / NEMIS_DT +! & * SEC_PER_YEAR ! s/yr +! & * GET_AREA_CM2(J) ! cm^2 +! & / XNUMOL(IDTNOX) ! molec / g of NO2 +! & * TG_PER_KG ! Tg / kg +! & * 14.d0 / 46.d0 ! g N / g NO2 +! +! TRACER_US(I,J,N) = TRACER(I,J,N) * USA_MASK(I,J) +! +! +! ! BC / OC +! ELSEIF ( N == IDADJEMS_BCan .or. N == IDADJEMS_OCan .or. +! & N == IDADJEMS_BCbb .or. N == IDADJEMS_OCbb .or. +! & N == IDADJEMS_BCbf .or. N == IDADJEMS_OCbf ) +! & THEN +! +! ! Convert from kg C / yr to Tg C / year +! TRACER(I,J,N) = EMS_orig(I,J,N) * TG_PER_KG +! TRACER_US(I,J,N) = EMS_orig(I,J,N) * TG_PER_KG +! & * USA_MASK(I,J) +! +! ! Anth NOx +! ELSEIF ( N == IDADJEMS_ENOx1 .or. N == IDADJEMS_ENOx2 ) +! & THEN +! +! ! Convert from kg NOx / emdt to Tg N / year +! TRACER(I,J,N) = EMS_orig(I,J,N) * TG_PER_KG +! & * MIN_PER_YEAR / GET_TS_EMIS() +! & * 14d0 / 46d0 +! TRACER_US(I,J,N) = EMS_orig(I,J,N) * TG_PER_KG +! & * MIN_PER_YEAR / GET_TS_EMIS() +! & * 14d0 / 46d0 +! & * USA_MASK(I,J) +! +! ! SO2 +! ELSEIF ( N == IDADJEMS_ESO2_bb .or. +! & N == IDADJEMS_ESO2_bf .or. +! & N == IDADJEMS_ESO2_sh ) +! +! & THEN +! +! ! Convert from kg SO2 / box / s to Tg S / year +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 +! TRACER_US(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 * USA_MASK(I,J) +! +! ! Volcano SO2 emissions (dkh, cklee 09/14/08) +! ELSEIF ( N == IDADJEMS_ESO2_ev .or. +! & N == IDADJEMS_ESO2_nv ) +! & THEN +! ! Convert from kg SO2 / box / s total to Tg S / year +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 +! & / NEMIS_DT +! TRACER_US(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 * USA_MASK(I,J) +! & / NEMIS_DT +! +! ! NH3 +! ELSEIF ( N == IDADJEMS_ENH3_an .or. +! & N == IDADJEMS_ENH3_na .or. +! & N == IDADJEMS_ENH3_bb .or. +! & N == IDADJEMS_ENH3_bf ) +! & THEN +! +! ! Convert from kg NH3 / box / s to Tg N / year +! TRACER(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 14d0 / 17d0 +! TRACER_US(I,J,N) = EMS_orig(I,J,N) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 14d0 / 17d0 +! & * USA_MASK(I,J) +! +! ! Anth SOx +! ELSEIF ( N == IDADJEMS_ESOx1 .or. +! & N == IDADJEMS_ESOx2 ) +! & THEN +! +! ! Convert from molec SOx / cm2 / s to Tg S / year +! TRACER(I,J,N) = EMS_orig(I,J,N) * GET_AREA_CM2(J) +! & / XNUMOL(IDTSO2) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 +! TRACER_US(I,J,N) = EMS_orig(I,J,N) * GET_AREA_CM2(J) +! & / XNUMOL(IDTSO2) +! & * SEC_PER_YEAR * TG_PER_KG +! & * 0.5d0 +! & * USA_MASK(I,J) +! +! ELSE +! +! CALL ERROR_STOP('undefined emissions', +! & 'inverse_mod.f') +! +! ENDIF +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDDO +! +! print*, 'PRIOR EMISSIONS' +! print*, 'TOTAL SOx1 [Tg S/y] = ', SUM(TRACER(:,:,1)) +! print*, 'TOTAL SOx2 [Tg S/y] = ', SUM(TRACER(:,:,2)) +! print*, 'TOTAL SO2_sh [Tg S/y] = ', SUM(TRACER(:,:,3)) +! print*, 'TOTAL SO2_bb [Tg S/y] = ', SUM(TRACER(:,:,4)) +! print*, 'TOTAL SO2_bf [Tg S/y] = ', SUM(TRACER(:,:,5)) +! print*, 'TOTAL NH3_bb [Tg N/y] = ', SUM(TRACER(:,:,6)) +! print*, 'TOTAL NH3_bf [Tg N/y] = ', SUM(TRACER(:,:,7)) +! print*, 'TOTAL NH3_an [Tg N/y] = ', SUM(TRACER(:,:,8)) +! print*, 'TOTAL NH3_na [Tg N/y] = ', SUM(TRACER(:,:,9)) +! print*, 'TOTAL BCan [Tg C/y] = ', SUM(TRACER(:,:,10)) +! print*, 'TOTAL OCan [Tg C/y] = ', SUM(TRACER(:,:,11)) +! print*, 'TOTAL BCbf [Tg C/y] = ', SUM(TRACER(:,:,12)) +! print*, 'TOTAL OCbf [Tg C/y] = ', SUM(TRACER(:,:,13)) +! print*, 'TOTAL BCbb [Tg C/y] = ', SUM(TRACER(:,:,14)) +! print*, 'TOTAL OCbb [Tg C/y] = ', SUM(TRACER(:,:,15)) +! print*, 'TOTAL NOx1 [Tg N/y] = ', SUM(TRACER(:,:,16)) +! print*, 'TOTAL NOx2 [Tg N/y] = ', SUM(TRACER(:,:,17)) +! print*, 'TOTAL NOx_li [Tg N/y] = ', SUM(TRACER(:,:,18)) +! print*, 'TOTAL NOx_so [Tg N/y] = ', SUM(TRACER(:,:,19)) +! print*, 'TOTAL SO2_ev [Tg S/y] = ', SUM(TRACER(:,:,20)) +! print*, 'TOTAL SO2_nv [Tg S/y] = ', SUM(TRACER(:,:,21)) +! print*, 'TOTAL US SOx1 [Tg S/y] = ', SUM(TRACER_US(:,:,1)) +! print*, 'TOTAL US SOx2 [Tg S/y] = ', SUM(TRACER_US(:,:,2)) +! print*, 'TOTAL US SO2_sh [Tg S/y] = ', SUM(TRACER_US(:,:,3)) +! print*, 'TOTAL US SO2_bb [Tg S/y] = ', SUM(TRACER_US(:,:,4)) +! print*, 'TOTAL US SO2_bf [Tg S/y] = ', SUM(TRACER_US(:,:,5)) +! print*, 'TOTAL US NH3_bb [Tg N/y] = ', SUM(TRACER_US(:,:,6)) +! print*, 'TOTAL US NH3_bf [Tg N/y] = ', SUM(TRACER_US(:,:,7)) +! print*, 'TOTAL US NH3_an [Tg N/y] = ', SUM(TRACER_US(:,:,8)) +! print*, 'TOTAL US NH3_na [Tg N/y] = ', SUM(TRACER_US(:,:,9)) +! print*, 'TOTAL US BCan [Tg C/y] = ', SUM(TRACER_US(:,:,10)) +! print*, 'TOTAL US OCan [Tg C/y] = ', SUM(TRACER_US(:,:,11)) +! print*, 'TOTAL US BCbf [Tg C/y] = ', SUM(TRACER_US(:,:,12)) +! print*, 'TOTAL US OCbf [Tg C/y] = ', SUM(TRACER_US(:,:,13)) +! print*, 'TOTAL US BCbb [Tg C/y] = ', SUM(TRACER_US(:,:,14)) +! print*, 'TOTAL US OCbb [Tg C/y] = ', SUM(TRACER_US(:,:,15)) +! print*, 'TOTAL US NOx1 [Tg N/y] = ', SUM(TRACER_US(:,:,16)) +! print*, 'TOTAL US NOx2 [Tg N/y] = ', SUM(TRACER_US(:,:,17)) +! print*, 'TOTAL US NOx_li [Tg N/y] = ', SUM(TRACER_US(:,:,18)) +! print*, 'TOTAL US NOx_so [Tg N/y] = ', SUM(TRACER_US(:,:,19)) +! print*, 'TOTAL US SO2_ev [Tg N/y] = ', SUM(TRACER_US(:,:,20)) +! print*, 'TOTAL US SO2_nv [Tg N/y] = ', SUM(TRACER_US(:,:,21)) +! +! +! DO N = 1, NNEMS +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +!#if defined ( LOG_OPT ) +! ! Apply current scaling +! TRACER(I,J,N) = TRACER(I,J,N) * EXP(EMS_ICS(I,J,1,N)) +! TRACER_US(I,J,N) = TRACER_US(I,J,N) +! & * EXP(EMS_ICS(I,J,1,N)) +! +!#else +! ! Apply current scaling +! TRACER(I,J,N) = TRACER(I,J,N) * EMS_ICS(I,J,1,N) +! TRACER_US(I,J,N) = TRACER_US(I,J,N) * EMS_ICS(I,J,1,N) +!#endif +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDDO +! +! print*, 'POSTERIOR EMISSIONS' +! print*, 'TOTAL SOx1 [Tg S/y] = ', SUM(TRACER(:,:,1)) +! print*, 'TOTAL SOx2 [Tg S/y] = ', SUM(TRACER(:,:,2)) +! print*, 'TOTAL SO2_sh [Tg S/y] = ', SUM(TRACER(:,:,3)) +! print*, 'TOTAL SO2_bb [Tg S/y] = ', SUM(TRACER(:,:,4)) +! print*, 'TOTAL SO2_bf [Tg S/y] = ', SUM(TRACER(:,:,5)) +! print*, 'TOTAL NH3_bb [Tg N/y] = ', SUM(TRACER(:,:,6)) +! print*, 'TOTAL NH3_bf [Tg N/y] = ', SUM(TRACER(:,:,7)) +! print*, 'TOTAL NH3_an [Tg N/y] = ', SUM(TRACER(:,:,8)) +! print*, 'TOTAL NH3_na [Tg N/y] = ', SUM(TRACER(:,:,9)) +! print*, 'TOTAL BCan [Tg C/y] = ', SUM(TRACER(:,:,10)) +! print*, 'TOTAL OCan [Tg C/y] = ', SUM(TRACER(:,:,11)) +! print*, 'TOTAL BCbf [Tg C/y] = ', SUM(TRACER(:,:,12)) +! print*, 'TOTAL OCbf [Tg C/y] = ', SUM(TRACER(:,:,13)) +! print*, 'TOTAL BCbb [Tg C/y] = ', SUM(TRACER(:,:,14)) +! print*, 'TOTAL OCbb [Tg C/y] = ', SUM(TRACER(:,:,15)) +! print*, 'TOTAL NOx1 [Tg N/y] = ', SUM(TRACER(:,:,16)) +! print*, 'TOTAL NOx2 [Tg N/y] = ', SUM(TRACER(:,:,17)) +! print*, 'TOTAL NOx_li [Tg N/y] = ', SUM(TRACER(:,:,18)) +! print*, 'TOTAL NOx_so [Tg N/y] = ', SUM(TRACER(:,:,19)) +! print*, 'TOTAL SO2_ev [Tg S/y] = ', SUM(TRACER(:,:,20)) +! print*, 'TOTAL SO2_nv [Tg S/y] = ', SUM(TRACER(:,:,21)) +! print*, 'TOTAL US SOx1 [Tg S/y] = ', SUM(TRACER_US(:,:,1)) +! print*, 'TOTAL US SOx2 [Tg S/y] = ', SUM(TRACER_US(:,:,2)) +! print*, 'TOTAL US SO2_sh [Tg S/y] = ', SUM(TRACER_US(:,:,3)) +! print*, 'TOTAL US SO2_bb [Tg S/y] = ', SUM(TRACER_US(:,:,4)) +! print*, 'TOTAL US SO2_bf [Tg S/y] = ', SUM(TRACER_US(:,:,5)) +! print*, 'TOTAL US NH3_bb [Tg N/y] = ', SUM(TRACER_US(:,:,6)) +! print*, 'TOTAL US NH3_bf [Tg N/y] = ', SUM(TRACER_US(:,:,7)) +! print*, 'TOTAL US NH3_an [Tg N/y] = ', SUM(TRACER_US(:,:,8)) +! print*, 'TOTAL US NH3_na [Tg N/y] = ', SUM(TRACER_US(:,:,9)) +! print*, 'TOTAL US BCan [Tg C/y] = ', SUM(TRACER_US(:,:,10)) +! print*, 'TOTAL US OCan [Tg C/y] = ', SUM(TRACER_US(:,:,11)) +! print*, 'TOTAL US BCbf [Tg C/y] = ', SUM(TRACER_US(:,:,12)) +! print*, 'TOTAL US OCbf [Tg C/y] = ', SUM(TRACER_US(:,:,13)) +! print*, 'TOTAL US BCbb [Tg C/y] = ', SUM(TRACER_US(:,:,14)) +! print*, 'TOTAL US OCbb [Tg C/y] = ', SUM(TRACER_US(:,:,15)) +! print*, 'TOTAL US NOx1 [Tg N/y] = ', SUM(TRACER_US(:,:,16)) +! print*, 'TOTAL US NOx2 [Tg N/y] = ', SUM(TRACER_US(:,:,17)) +! print*, 'TOTAL US NOx_li [Tg N/y] = ', SUM(TRACER_US(:,:,18)) +! print*, 'TOTAL US NOx_so [Tg N/y] = ', SUM(TRACER_US(:,:,19)) +! print*, 'TOTAL US SO2_ev [Tg N/y] = ', SUM(TRACER_US(:,:,20)) +! print*, 'TOTAL US SO2_nv [Tg N/y] = ', SUM(TRACER_US(:,:,21)) +! +! +! ENDIF +! +! +! !### Debug +! +! IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_SF_DIAG_FILE: wrote file' ) +! +! ! Return to calling program +! END SUBROUTINE MAKE_SF_DIAG_FILE +! +!!------------------------------------------------------------------------------ +! + SUBROUTINE READ_SF_FILE ( ) +! +!****************************************************************************** +! Subroutine READ_SF_FILE reads the gctm.sf.* file into ICS_SF or EMS_SF +! (dkh, 9/17/04) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! +! Notes +! (1 ) Add support for ACTIVE_VARS == 'EMISSIONS' case (dkh, 11/27/04) +! (2 ) Add support for ACTIVE_VARS == 'FDTEST' case (dkh, 02/17/05) +! (3 ) Now use CATEGORY = 'IJ-EMS-$' for ACTIVE_VARS == 'EMISSIONS' case. +! (dkh, 03/28/05) +! (4 ) Change name from ICS to SF, replace CMN_ADJ (dkh, ks, mak, cs 06/08/09) +! (5 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, ICS_SF + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_MOD, ONLY : LPRT + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! LPRT + + ! Local Variables + INTEGER :: I, IOS, J, L, M, N + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + CHARACTER(LEN=20) :: INPUT_SF_FILE + + !================================================================= + ! READ_SF_FILE begins here! + !================================================================= + + ! Hardwire output file for now + INPUT_SF_FILE = 'gctm.sf.NN' + + ! Initialize some variables + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open SF file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_SF_FILE ) + + ! Replace NN token w/ actual value + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add OPTDATA_DIR prefix to FILENAME + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + ! can hardwire this to read a specific file from another run: + !FILENAME = TRIM( 'opt_ics/ADJv27fi04r10/gctm.ics.16' ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'S F F I L E I N P U T' + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_SF_FILE: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + IF ( LICS ) THEN + + !================================================================= + ! Read initial conditions -- store in the TRACER array + !================================================================= + DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:6') + + !============================================================== + ! Assign data from the TRACER array to the xxx_IC array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-ICS-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + ICS_SF (I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ENDIF + + IF ( LADJ_EMS ) THEN + + !================================================================= + ! Read emission scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NNEMS + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_ics_file:6') + + !============================================================== + ! Assign data from the TRACER array to the xxx_IC array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + IF ( CATEGORY(1:8) == 'IJ-EMS-$' ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + EMS_SF(I,J,M,N) = TRACER(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + ENDDO + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + !================================================================= + ! Read strat prod & loss scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NSTPL + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:6') + + !============================================================== + ! Assign data from the TRACER array to the xxx_STR array. + !============================================================== + + ! Only process observation data (i.e. aerosol and precursors) + + IF ( CATEGORY(1:8) == 'IJ-STRP$' ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + PROD_SF(I,J,M,N) = TRACER(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDDO + + !================================================================= + ! Read strat prod & loss scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NSTPL + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:4' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:5') + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_strat_file:6') + + IF ( CATEGORY(1:8) == 'IJ-STRL$' ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, M ) + DO M = 1, MMSCL + DO J = 1, JJPAR + DO I = 1, IIPAR + LOSS_SF(I,J,M,N) = TRACER(I,J,M) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDDO + ENDIF + + + IF ( LADJ_RRATE ) THEN + !================================================================= + ! Read rxn rate scale factors -- store in the TRACER array + !================================================================= + DO N = 1, NRRATES + + READ( IU_RST, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_sf_file:rate1' ) + + READ( IU_RST, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_sf_file:rate2' ) + + READ( IU_RST, IOSTAT=IOS ) + & ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST, + & 'read_sf_file:rate3' ) + + IF ( CATEGORY(1:8) == 'IJ-RATSF' ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + RATE_SF(I,J,L,N) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + ENDDO + ENDIF + + ENDIF + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_SF_FILE: read file' ) + + ! Return to calling program + END SUBROUTINE READ_SF_FILE + +!----------------------------------------------------------------------- + + SUBROUTINE MAKE_SAT_DIAG_FILE ( type) +! +!****************************************************************************** +! Subroutine MAKE_DIAG_FILE creates a binary file of a diagnostic array +! calculated in CALC_ADJ_FORCING in adjoint_mod.f +! (mak, 02/09/06, 2/17/06, zhe 08/29/10) +! +! ============================================================================ +! (1 ) MODEL_BIAS +! NOTES: +! (1 ) Just like MAKE_ADJ_FILE except +! - write to .force. file +! (2 ) Add support for ACTIVE_VARS == 'EMISSIONS' case (dkh, 11/27/04) +! (3 ) Add support for ACTIVE_VARS == 'FDTEST' case. (dkh, 02/17/05) +! (4 ) Change UNIT to unitless and change title to Scale factors (dkh, 03/06/05) +! (5 ) Change output for ACTIVE_VARS == 'EMISSIONS' case. +! Now use label IJ-EMS-$, and update gamap code accordingly. +! First write the scaling factors, in consecutive species. Temporal +! varations in the emissions, if any, will be in the L direction. +! Next, write out the optimized emissions themselves. +! Finally, write out the difference between orig and optimized emissions. +! (dkh, 03/28/05) +! (6 ) Use EMS_orig instead of ESO4_an_orig so that we can loop over N. +! (7 ) Move EMS_org declaration to CMN_ADJ, (mak) +! (8 ) Updated to v8, adj_group, 6/09/09, (mak, 6/22/09) +! (9 ) Bug fixed, the flog SDFLAG is added, zhe 8/29/10 +! (10) Update MOPITT obs operators (zhe, 1/19/11) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU, GET_CT_EMIS + USE ADJ_ARRAYS_MOD, ONLY : GET_MODEL_BIAS, GET_FORCING, + & GET_MODEL, GET_OBS, COST_ARRAY, + & COST_ARRAY, GET_DOFS, + & OBS_COUNT, GET_EMS_ORIG, + & N_CALC, SAT, DAYS, MMSCL + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME +#if defined ( MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS ) + USE MOPITT_OBS_MOD, ONLY : OBS_HOUR_MOPITT !(zhe 1/19/11) +#endif +#if defined(AIRS_CO_OBS) + USE AIRS_CO_OBS_MOD, ONLY : OBS_HOUR_AIRS_CO +#endif + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LHMOD, LHOBS, LMODBIAS, LOBS_COUNT, + & LDOFS + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! TRCOFFSET, TINDEX + + ! Arguments + integer, intent(in) :: type ! type of diag file + INTEGER :: NN + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, M, N,H,s + REAL*4 :: TRACER(IIPAR,JJPAR,DAYS,sat) + REAL*4, ALLOCATABLE :: TRACER_EMS(:,:,:) + REAL*4, ALLOCATABLE :: TRACER_COST(:,:,:) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=20) :: OUTPUT_ICS_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + LOGICAL :: SDFLAG + + +! INPUTS: + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + !================================================================= + ! MAKE_SAT_DIAG_FILE begins here! + !================================================================= + + SDFLAG = .FALSE. + + ! Hardwire output file for now + IF( TYPE == 1 .AND. LHMOD ) THEN + + OUTPUT_ICS_FILE = 'gctm.model.NN' + UNIT = 'molec/cm2' + CATEGORY = 'IJ-AVG-$' + SDFLAG = .TRUE. + + ELSEIF( TYPE == 2 .AND. LHOBS ) THEN + + OUTPUT_ICS_FILE = 'gctm.obs.NN' + UNIT = 'molec/cm2' + CATEGORY = 'IJ-AVG-$' + TITLE = 'GEOS-CHEM observation file: ' + SDFLAG = .TRUE. + + ELSEIF( TYPE ==3 .AND. LMODBIAS ) THEN + + OUTPUT_ICS_FILE = 'gctm.modelbias.NN' + UNIT = '%' + CATEGORY = 'IJ-AVG-$' + TITLE = 'GEOS-CHEM model bias File: ' // + & 'model - obs bias' + SDFLAG = .TRUE. + + +c$$$ IF( type == 4 ) THEN +c$$$ +c$$$ OUTPUT_ICS_FILE = 'gctm.emsorig' +c$$$ TITLE = 'GEOS-CHEM emissions file: ' + + ELSEIF( TYPE == 5 .AND. LOBS_COUNT ) THEN + + OUTPUT_ICS_FILE = 'gctm.costf.NN' + TITLE = 'GEOS-CHEM cost file: ' + SDFLAG = .TRUE. + + ELSEIF( TYPE == 6 .AND. LDOFS ) THEN + + OUTPUT_ICS_FILE = 'gctm.dofs.NN' + TITLE = 'Degrees of Freedom of Signal for sats: ' + UNIT = 'unitless' + CATEGORY = 'IJ-DOF-$' + SDFLAG = .TRUE. + + ! (zhe, dkh, 02/04/11) + ELSEIF( TYPE == 7 ) THEN + + OUTPUT_ICS_FILE = 'gctm.forcing.NN' + TITLE = 'Adjoint forcing: ' + UNIT = 'unitless' + CATEGORY = 'IJ-AVG-$' + SDFLAG = .TRUE. + + ENDIF + + IF (SDFLAG) THEN + + ! zero TRACER array, for clarity + TRACER(:,:,:,:) = 0d0 + + ! Define variables for BINARY PUNCH FILE OUTPUT + + ! now passed in + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the adjoint file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_ICS_FILE ) + + ! Replace NN token w/ actual value + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add OPT_DATA_DIR prefix to FILENAME + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_SAT_DIAG_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write each observed quantity to the ics file + !================================================================= + !Temporarily store quantities in the TRACER array + + ! Loop over number of satellites + DO s = 1, sat + + IF( TYPE == 1 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, DAYS + DO J = 1, JJPAR + DO I = 1, IIPAR + ! average over all days, add all days in IDL + TRACER(I,J,L,s) = GET_MODEL(I,J,L,s) + ENDDO + ENDDO + ENDDO + +!$OMP END PARALLEL DO + + ELSEIF( TYPE == 2 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L) + DO L = 1, DAYS + DO J = 1, JJPAR + DO I = 1, IIPAR + ! average over all days, add all days in IDL + TRACER(I,J,L,s) = GET_OBS(I,J,L,s) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + print*, 'obs#:', s + print*, 'min obs:',minval(tracer(:,:,:,s)) + print*, 'max obs:',maxval(tracer(:,:,:,s)) + + ELSEIF( TYPE == 3 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, DAYS + DO J = 1, JJPAR + DO I = 1, IIPAR + ! average over all days, add all days in IDL + TRACER(I,J,L,s) = GET_MODEL_BIAS(I,J,L,s) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! (zhe, dkh, 02/04/11) + ELSEIF( TYPE == 7 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, DAYS + DO J = 1, JJPAR + DO I = 1, IIPAR + ! average over all days, add all days in IDL + TRACER(I,J,L,s) = GET_FORCING(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + + ENDIF ! TYPE + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, s, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, DAYS, I0+1, + & J0+1, 1, TRACER(:,:,:,s) ) + + ENDDO ! s = 1,SAT + + + IF (TYPE .EQ. 6 ) THEN + + DO s = 1, sat + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, DAYS + DO J = 1, JJPAR + DO I = 1, IIPAR + ! average over all days, add all days in IDL + TRACER(I,J,L,s) = GET_DOFS(I,J,L,s) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, s, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, DAYS, I0+1, + & J0+1, 1, TRACER(:,:,:,s) ) + + ENDDO ! s = 1,SAT + ENDIF !TYPE == 6 + + ! Comment for now and later decide if we want it (mak,6/22/09) +c$$$ IF( TYPE == 4 ) THEN +c$$$ ALLOCATE (TRACER_EMS(IIPAR,JJPAR,MMSCL)) +c$$$ TRACER_EMS = 0e0 +c$$$ +c$$$ ! The following taken from ND29 +c$$$ UNIT = 'kg/box/h' +c$$$ CATEGORY ='CO--SRCE' +c$$$ NN = TINDEX(29,1) +c$$$ +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, M) +c$$$ DO M = 1, MMSCL +c$$$ DO J = 1, JJPAR +c$$$ DO I = 1, IIPAR +c$$$ ! average over all days, add all days in IDL +c$$$ TRACER_EMS(I,J,M) = GET_EMS_ORIG(I,J,M)*EMS_ICS(I,J,M,1) +c$$$ & /DBLE(GET_CT_EMIS() ) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO +c$$$ +c$$$ CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +c$$$ & HALFPOLAR, CENTER180, CATEGORY, NN, +c$$$ & UNIT, GET_TAU(), GET_TAU(), RESERVED, +c$$$ & IIPAR, JJPAR, MMSCL, I0+1, +c$$$ & J0+1, 1, TRACER_EMS ) +c$$$ +c$$$ +c$$$ IF( ALLOCATED( TRACER_EMS ) ) DEALLOCATE(TRACER_EMS) +c$$$ +c$$$ ENDIF ! TYPE=4 + + IF( TYPE == 5 ) THEN + + !ALLOCATE (TRACER_COST(IFDSIZE, JFDSIZE, LFDSIZE )) + ALLOCATE (TRACER_COST(IIPAR, JJPAR, DAYS )) + TRACER_COST = 0e0 + + ! The following taken from ND29 + UNIT = 'unitless' + CATEGORY ='COSTF' + NN = 8301 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L) + DO L = 1, DAYS !LFDSIZE + DO J = 1, JJPAR !JFDSIZE + DO I = 1, IIPAR !IFDSIZE + ! COST_ARRAY + TRACER_COST(I,J,L) = COST_ARRAY(I,J,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !print*, 'min/max of COST_ARRAY going to file:' + !print*, minval(TRACER_COST), maxval(TRACER_COST) + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NN, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, DAYS, I0+1, + & J0+1, 1, TRACER_COST ) + + PRINT*, 'FINISHED STORING COSTF' + + IF( ALLOCATED( TRACER_COST ) ) DEALLOCATE(TRACER_COST) + + ALLOCATE (TRACER_COST(IIPAR,JJPAR,1)) + TRACER_COST = 0e0 + + ! The following taken from ND29 + UNIT = 'unitless' + CATEGORY ='OBSCT' + NN = 8401 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L) + DO L = 1, 1 + DO J = 1, JJPAR + DO I = 1, IIPAR + ! OBS_COUNT ARRAY + TRACER_COST(I,J,1) = OBS_COUNT(I,J) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NN, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER_COST ) + + print*, 'finished saving OBSCT, tot obs#:',sum(obs_count) + +#if defined (MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS) + + ! store OBS_HOUR, but note that it's only for the last day of sim + CATEGORY ='OBSHR' + NN = 8501 + TRACER_COST(:,:,:) = 0e0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L) + DO L = 1, 1 + DO J = 1, JJPAR + DO I = 1, IIPAR + ! OBS_COUNT ARRAY + TRACER_COST(I,J,1) = OBS_HOUR_MOPITT(I,J) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NN, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER_COST ) + + PRINT*, 'FINISHED OBS HOUR MOPITT' +#endif + +#if defined(AIRS_CO_OBS) + ! store OBS_HOUR, but note that it's only for the last day of sim + CATEGORY ='OBSHR' + NN = 8502 + TRACER_COST(:,:,:) = 0e0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L) + DO L = 1, 1 + DO J = 1, JJPAR + DO I = 1, IIPAR + ! OBS_COUNT ARRAY + TRACER_COST(I,J,1) = OBS_HOUR_AIRS_CO(I,J) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, NN, + & UNIT, GET_TAU(), GET_TAU(), RESERVED, + & IIPAR, JJPAR, 1, I0+1, + & J0+1, 1, TRACER_COST ) + + PRINT*, 'FINISHED storing OBS_HOUR_AIRS_CO' +#endif + + IF( ALLOCATED( TRACER_COST ) ) DEALLOCATE(TRACER_COST) + + ENDIF ! TYPE=5 + + ! Close file + CLOSE( IU_RST ) + + !### Debug + IF( LPRT ) CALL DEBUG_MSG( '### MAKE_SAT_DIAG_FILE: wrote file') + + ENDIF !SDFLAG + + + ! Return to calling program + END SUBROUTINE MAKE_SAT_DIAG_FILE + +!------------------------------------------------------------------------------ +! Now move this in adj_arrays_mod.f (dkh, 10/15/09) +! +! SUBROUTINE EXPAND_NAME( FILENAME, N_ITRN ) +!! +!!****************************************************************************** +!! Subroutine EXPAND_DATE replaces "NN" token within +!! a filename string with the actual values. (bmy, 6/27/02, 12/2/03) +!! (dkh, 9/22/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) FILENAME (CHARACTER) : Filename with tokens to replace +!! (2 ) N_ITRN (INTEGER ) : Current iteration number +!! +!! +!! Arguments as Output: +!! ============================================================================ +!! (1 ) FILENAME (CHARACTER) : Modified filename +!! +!! NOTES: +!! (1 ) Based on EXPAND_DATE +!! +!!****************************************************************************** +!! +! ! References to F90 modules +! USE CHARPAK_MOD, ONLY : STRREPL +! USE ERROR_MOD, ONLY : ERROR_STOP +! +!# include "define.h" +! +! ! Arguments +! CHARACTER(LEN=*), INTENT(INOUT) :: FILENAME +! INTEGER, INTENT(IN) :: N_ITRN +! +! ! Local variables +! CHARACTER(LEN=2) :: NN_STR +! +! !================================================================= +! ! EXPAND_NAME begins here! +! !================================================================= +! +!#if defined( LINUX_PGI ) +! +! ! Use ENCODE statement for PGI/Linux (bmy, 9/29/03) +! ENCODE( 2, '(i2.2)', NN_STR ) N_ITRN +! +!#else +! +! ! For other platforms, use an F90 internal write (bmy, 9/29/03) +! WRITE( NN_STR, '(i2.2)' ) N_ITRN +! +!#endif +! +! ! Replace NN token w/ actual value +! CALL STRREPL( FILENAME, 'NN', NN_STR ) +! +! +! ! Return to calling program +! END SUBROUTINE EXPAND_NAME +! +!!----------------------------------------------------------------------------- + + SUBROUTINE DISPLAY_STUFF( LOCATION ) +! +!******************************************************************************** +! Subroutine DISPLAY_STUFF writes output to the screen during optimization +! (dkh, 11/28/04) +! +! NOTES +! (1 ) Rearragne the structure so that LOCATION is outermost selection, then +! ACTIVE_VARS == xx is subselection. Add support for LOCATION 4 ( final +! iteration ). dkh, 02/17/05 +! (2 ) Update to v8 and new interface/var names (mak, 6/19/09) +! (3 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!******************************************************************************** +! + ! References to f90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC_SAV + USE ADJ_ARRAYS_MOD, ONLY : FD_DIFF + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, MFD, LFD, NFD, EMSFD + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ_FD + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, EMS_SF + USE ADJ_ARRAYS_MOD, ONLY : NNEMS, ICSFD + USE ADJ_ARRAYS_MOD, ONLY : STRFD + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF, RATE_SF0 + USE ADJ_ARRAYS_MOD, ONLY : RATFD + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE LOGICAL_ADJ_MOD, ONLY : LFDTEST, LADJ_EMS, LICS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size params + + ! Argument + INTEGER :: LOCATION + + ! Local variables + INTEGER :: I_DUM + INTEGER :: N + REAL*8 :: FINAL_ADJ_GRAD + REAL*8 :: FINAL_FD_GRAD + + !============================================================ + ! DISPLAY_STUFF starts here! + !============================================================ + + + SELECT CASE ( LOCATION ) + + ! Read/Write an iteration + CASE( 1 ) + + IF ( LICS ) THEN + + WRITE(6,*) ' ICS_SF(1,1,1,:) is ', ICS_SF(1,1,1,:) + WRITE(6,*) ' ICS_SF(:,:,1,1) range is ', + & MINVAL(ICS_SF(:,:,1,1) ), + & ' to ', MAXVAL(ICS_SF(:,:,1,1) ) + + WRITE(6,*) ' ICS_SF(1,1,:,1) range is ', + & MINVAL(ICS_SF(1,1,:,1) ), + & ' to ', MAXVAL(ICS_SF(1,1,:,1) ) + + ELSEIF( LADJ_EMS ) THEN + + ! Nothing + + ELSEIF( LFDTEST ) THEN + + IF (LICS) THEN + WRITE(6,*) ' ICS_SF(FD) is ',ICS_SF(IFD,JFD,LFD,ICSFD) + ENDIF + IF (LADJ_EMS) THEN + WRITE(6,*) ' EMS_SF(FD) is ',EMS_SF(IFD,JFD,LFD,EMSFD) + + ! Strat prod and loss (hml) + IF (LADJ_STRAT) THEN + WRITE(6,*) ' PROD_SF(FD) is ' + & ,PROD_SF(IFD,JFD,LFD,STRFD) + WRITE(6,*) ' LOSS_SF(FD) is ' + & ,LOSS_SF(IFD,JFD,LFD,STRFD) + ENDIF + + ! Reaction rates (tww) + IF (LADJ_RRATE) THEN + WRITE(6,*) ' RATE_SF(FD) is ' + & , RATE_SF(IFD,JFD,LFD,RATFD) + ENDIF + + ENDIF + + ELSE + CALL ERROR_STOP( 'ACTIVE_VARS not defined!', + & 'DISPLAY_STUFF' ) + ENDIF + + ! After loading gradient + CASE( 2 ) + + IF ( LICS .AND. LADJ_EMS ) THEN + + WRITE(6,*) ' ICS_SF(:,:,1,1) range is ', + & MINVAL( ICS_SF(:,:,1,1) ), ' to ', + & MAXVAL( ICS_SF(:,:,1,1) ) + + + WRITE(6,*) ' EMS_SF(:,:,1,1) range is ', + & MINVAL( EMS_SF(:,:,1,1) ), ' to ', + & MAXVAL( EMS_SF(:,:,1,1) ) + + print*, ' GRADNT range is', + & MINVAL( GRADNT ), ' to ', + & MAXVAL( GRADNT ) + + ELSEIF ( LFDTEST .AND. LICS ) THEN + + ! for now, the I_DUM calculation is only supported for LICS, + ! not LADJ_EMS (mak, 6/22/09) + I_DUM = IFD + ( IIPAR * ( JFD - 1) ) + & + ( IIPAR * JJPAR * ( LFD - 1 ) ) + & + ( IIPAR * JJPAR * LLPAR * ( ICSFD - 1 ) ) + + WRITE(6,*) ' GRADNT(FD) = ', GRADNT(I_DUM) + + WRITE(6,*) ' MIN/MAX ICS_SF_ADJ = ', + & MINVAL(ICS_SF_ADJ(:,:,:,:)), + & MAXVAL(ICS_SF_ADJ(:,:,:,:)) + + ELSEIF ( LFDTEST .AND. LADJ_EMS ) THEN + + WRITE(6,*) ' MIN/MAX EMS_SF_ADJ = ', + & MINVAL(EMS_SF_ADJ(:,:,:,:)), + & MAXVAL(EMS_SF_ADJ(:,:,:,:)) + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + WRITE(6,*) ' MIN/MAX PROD_SF_ADJ = ', + & MINVAL(PROD_SF_ADJ(:,:,:,:)), + & MAXVAL(PROD_SF_ADJ(:,:,:,:)) + + WRITE(6,*) ' MIN/MAX LOSS_SF_ADJ = ', + & MINVAL(LOSS_SF_ADJ(:,:,:,:)), + & MAXVAL(LOSS_SF_ADJ(:,:,:,:)) + ENDIF + + ! Reaction rates (tww) + IF ( LADJ_RRATE ) THEN + WRITE(6,*) ' MIN/MAX RATE_SF_ADJ = ', + & MINVAL(RATE_SF_ADJ(:,:,:,:)), + & MAXVAL(RATE_SF_ADJ(:,:,:,:)) + ENDIF + + ELSEIF ( LICS ) THEN + +! print*, 'gradnt', gradnt(1), +! & gradnt(1+iipar*jjpar*llpar*(1)) , +! & gradnt(1+iipar*jjpar*llpar*2), +! & gradnt(1+iipar*jjpar*llpar*3) + + ELSEIF ( LADJ_EMS ) THEN + + WRITE(6,*) ' EMS_SF(:,:,1,1) range is ', + & MINVAL( EMS_SF(:,:,1,1) ), ' to ', + & MAXVAL( EMS_SF(:,:,1,1) ) + + print*, ' GRADNT range is', + & MINVAL( GRADNT ), ' to ', + & MAXVAL( GRADNT ) + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + WRITE(6,*) ' PROD_SF(:,:,1,1) range is ', + & MINVAL( PROD_SF(:,:,1,1) ), ' to ', + & MAXVAL( PROD_SF(:,:,1,1) ) + + WRITE(6,*) ' LOSS_SF(:,:,1,1) range is ', + & MINVAL( LOSS_SF(:,:,1,1) ), ' to ', + & MAXVAL( LOSS_SF(:,:,1,1) ) + + print*, ' PROD_GRADNT range is', + & MINVAL( GRADNT_P ), ' to ', + & MAXVAL( GRADNT_P ) + + print*, ' LOSS_GRADNT range is', + & MINVAL( GRADNT_L ), ' to ', + & MAXVAL( GRADNT_L ) + ENDIF + + ! Reaction rates (tww) + IF ( LADJ_RRATE ) THEN + WRITE(6,*) ' RATE_SF(:,:,1,1) range is ', + & MINVAL( RATE_SF(:,:,1,1) ), ' to ', + & MAXVAL( RATE_SF(:,:,1,1) ) + ENDIF + + ELSE + CALL ERROR_STOP( 'ACTIVE VARS not defined!', + & 'DISPLAY_STUFF, inverse_mod.f' ) + ENDIF + + ! For all values of ACTIVE_VARS... + WRITE(6,*) ' cost function', COST_FUNC + IF ( N_CALC > 1 ) THEN + WRITE(6,*) ' local change = ', + & COST_FUNC / COST_FUNC_SAV(N_CALC - 1), + & ' = current / previous ' + ENDIF + WRITE(6,*) ' total change so far = ', + & COST_FUNC / COST_FUNC_SAV(1), + & ' = currrent / initial ' + + + ! Compute an iteration + CASE( 3 ) + + WRITE(6,*) ' COMPUTING NEW VALUES FOR N_CALC = ', + & N_CALC + + IF( LFDTEST .AND. LICS) THEN + + WRITE(6,*) ' COMPUTING NEW VALUES FOR N_CALC = ', + & N_CALC + IF (LICS) THEN + WRITE(6,*) ' CURRENT ICS_SF(FD) IS ', + & ICS_SF(IFD,JFD,LFD,ICSFD) + ENDIF + IF (LADJ_EMS) THEN + WRITE(6,*) ' CURRENT EMS_SF(FD) IS ', + & EMS_SF(IFD,JFD,MFD,EMSFD) + ENDIF + + + ELSEIF ( LICS ) THEN + WRITE(6,*) ' CURRENT ICS_SF(1,1,1,:) IS ', + & ICS_SF(1,1,1,:) + + WRITE(6,*) ' ICS_SF(:,:,1,1) range is ', + & MINVAL(ICS_SF(:,:,1,1) ), + & ' to ', MAXVAL(ICS_SF(:,:,1,1) ) + + WRITE(6,*) ' ICS_SF(1,1,:,1) range is ', + & MINVAL(ICS_SF(1,1,:,1) ), + & ' to ', MAXVAL(ICS_SF(1,1,:,1) ) + + WRITE(6,*) ' RANGE OF ICS_SF(:,:,:,:) IS ', + & MINVAL(ICS_SF), ' TO ', + & MAXVAL(ICS_SF) + + ELSEIF( LADJ_EMS ) THEN + + ! Nothing + + ELSE + CALL ERROR_STOP( 'ACTIVE VARS not defined!', + & 'DISPLAY_STUFF, inverse_mod.f' ) + ENDIF + + !After the final iteration + CASE( 4 ) + + ! For all values of ACTIVE_VARS... + WRITE(6,*) 'COST_FUNC = ', COST_FUNC + IF ( COST_FUNC_SAV(1) > 0d0 ) + & WRITE(6,*) 'COST_FUNC reduction = ', + & COST_FUNC / COST_FUNC_SAV(1) + + ! Add gradient diagnostics (dkh, 06/24/09) + IF ( LICS ) THEN + DO N = 1, N_TRACERS + WRITE(6,*) 'MIN ICS_SF_ADJ = ', + & MINVAL(ICS_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MAX ICS_SF_ADJ = ', + & MAXVAL(ICS_SF_ADJ(:,:,:,N)), N + ENDDO + ENDIF + IF ( LADJ_EMS ) THEN + DO N = 1, NNEMS + WRITE(6,*) 'MIN EMS_SF_ADJ = ', + & MINVAL(EMS_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MAX EMS_SF_ADJ = ', + & MAXVAL(EMS_SF_ADJ(:,:,:,N)), N + ENDDO + + ! strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + DO N = 1, NSTPL + WRITE(6,*) 'MIN PROD_SF_ADJ = ', + & MINVAL(PROD_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MAX PROD_SF_ADJ = ', + & MAXVAL(PROD_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MIN LOSS_SF_ADJ = ', + & MINVAL(LOSS_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MAX LOSS_SF_ADJ = ', + & MAXVAL(LOSS_SF_ADJ(:,:,:,N)), N + ENDDO + ENDIF + + ! reaction rates (tww) + IF ( LADJ_RRATE ) THEN + DO N = 1, NRRATES + WRITE(6,*) 'MIN RATE_SF_ADJ = ', + & MINVAL(RATE_SF_ADJ(:,:,:,N)), N + WRITE(6,*) 'MAX RATE_SF_ADJ = ', + & MAXVAL(RATE_SF_ADJ(:,:,:,N)), N + ENDDO + ENDIF + ENDIF + + ! Compile statistics from the finite difference test. + ! Calculate final gradients after two iterations. + ! Now only do this for a SPOT test (dkh, 02/21/11) + !IF ( LFDTEST .AND. N_CALC == 2 ) THEN + IF ( LFD_SPOT .AND. N_CALC == 2 ) THEN + + IF ( LADJ_EMS ) THEN + ! Determine the gradient calculated using the adjoint method + ! as an average of the gradient at FD_PERT [ STT_ADJ_FD(1) ] + ! and FD_PERT + FD_DIFF [ STT_ADJ_FD(2) ]. + STT_ADJ_FD(2) = EMS_SF_ADJ(IFD,JFD,MFD,EMSFD) + FINAL_ADJ_GRAD = .5d0 + & * ( STT_ADJ_FD(1) + STT_ADJ_FD(2) ) + ELSEIF ( LICS ) THEN + ! Determine the gradient calculated using the adjoint method + ! as an average of the gradient at FD_PERT [ STT_ADJ_FD(1) ] + ! and FD_PERT + FD_DIFF [ STT_ADJ_FD(2) ]. + STT_ADJ_FD(2) = ICS_SF_ADJ(IFD,JFD,LFD,ICSFD) + FINAL_ADJ_GRAD = .5d0 + & * ( STT_ADJ_FD(1) + STT_ADJ_FD(2) ) + + ENDIF + + + ! The finite difference gradient is + ! [ J( FD_PERT + FD_DIFF ) - J( FD_PERT ) ] / FD_DIFF + FINAL_FD_GRAD = ( COST_FUNC - COST_FUNC_SAV(1) ) + & / ( FD_DIFF ) + + ! Echo results to the screen + WRITE(6,*) ' ADJOINT gradient = ', FINAL_ADJ_GRAD + WRITE(6,*) ' FN DIFF gradient = ', FINAL_FD_GRAD + WRITE(6,*) ' ADJ / FD = ', + & FINAL_ADJ_GRAD / FINAL_FD_GRAD + + ENDIF +! + WRITE(6,*) 'FORCE EXIT AFTER ', N_CALC_STOP,' ITERATIONS.' + + CASE DEFAULT + ! Nothing +! + END SELECT + + + END SUBROUTINE DISPLAY_STUFF + +! needs to be updated +!!---------------------------------------------------------------------- +!! +!! SUBROUTINE INIT_REGIONAL_EMS +!! +!!******************************************************************************** +!! Subroutine INIT_REGIONAL_EMS initializes spatially dependent emissions factors +!! (dkh, 12/04/04) +!! +!! NOTES +!! (1 ) Updated to add random noise. (dkh, 08/27/06) +!!******************************************************************************** +!! +!# include "CMN_SIZE" ! Size params +! +! ! Local variables +! INTEGER :: I, J +! DOUBLE PRECISION :: RAN +! +! !============================================================ +! ! INIT_REGIONAL_EMS begins here! +! !============================================================ +! WRITE(6,*) ' U S E S P A T I A L L Y V A R I A B L E ' +! WRITE(6,*) ' E M I S S I O N S S C A L I N G S F O R ' +! WRITE(6,*) ' R E F E R E N C E C A L C U L A T I O N ' +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, RAN ) +! DO I = 1, IIPAR +! DO J = 1, JJPAR +! +! ! Nor Am +! IF ( I < 28 .AND. J > 28 ) THEN +! EMS_SF(I,J,1,IDADJEMS_ESOx1) = 0.8D0 +! EMS_SF(I,J,1,IDADJEMS_ESOx2) = 0.8D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx1) = 0.85D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx2) = 0.85D0 +! +! ! Europe +! ELSEIF ( I > 27 .AND. I < 48 .AND. J > 28 ) THEN +! EMS_SF(I,J,1,IDADJEMS_ESOx1) = 0.7D0 +! EMS_SF(I,J,1,IDADJEMS_ESOx2) = 0.7D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx1) = 0.95D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx2) = 0.95D0 +! +! ! Asia / India +! ELSEIF ( I > 47 .AND. J > 20 ) THEN +! EMS_SF(I,J,1,IDADJEMS_ESOx1) = 1.3D0 +! EMS_SF(I,J,1,IDADJEMS_ESOx2) = 1.3D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx1) = 1.2D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx2) = 1.2D0 +! +! ! The rest of the Southern Hemisphere +! ELSE +! EMS_SF(I,J,1,IDADJEMS_ESOx1) = 0.75D0 +! EMS_SF(I,J,1,IDADJEMS_ESOx2) = 0.75D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx1) = 0.77D0 +! EMS_SF(I,J,1,IDADJEMS_ENOx2) = 0.77D0 +! +! ENDIF +! +! RAN = DRAN(I+J) +! +! ! add a small bit of random variation +! EMS_SF(I,J,1,IDADJEMS_ESOx1) = EMS_SF(I,J,1,IDADJEMS_ESOx1) +! & + RAN / 20 +! EMS_SF(I,J,1,IDADJEMS_ESOx2) = EMS_SF(I,J,1,IDADJEMS_ESOx2) +! & + RAN / 20 +! EMS_SF(I,J,1,IDADJEMS_ENOx1) = EMS_SF(I,J,1,IDADJEMS_ENOx1) + +! & + RAN / 20 +! EMS_SF(I,J,1,IDADJEMS_ENOx2) = EMS_SF(I,J,1,IDADJEMS_ENOx2) + +! & + RAN / 20 +! +! ENDDO +! ENDDO +!!OMP END PARALLEL DO +! END SUBROUTINE INIT_REGIONAL_EMS +!!---------------------------------------------------------------------- + SUBROUTINE SET_SF_FORFD +! +!***************************************************************************** +! Subroutine SET_SF_FORFD is used to initialize ICS_SF during the second +! iteration to the orginal value + FD_DIFF. dkh, 02/17/05 +! +! NOTES: +! (1 ) Add support for 2nd order FD calculation +! (2 ) Add support for FD_GLOB option (dkh, 10/11/08) +! (3 ) Now initialize EMS_SF to FD_BKGRND (dkh, 10/11/08) +! (4 ) Change name to SET_SF_FORFD, replace CMN_ADJ, simplify the definition +! of the FD pert (dkh, ks, mak, cs 06/07/09) +! (5 ) Now support strat fluxes LADJ_STRAT and add flags to avoid accessing +! unallocated arrays (hml, dkh, 02/20/12, adj32_025) +!***************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF, ICS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF, EMS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : IFD,JFD,LFD,NFD + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, PROD_SF0 + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF, LOSS_SF0 + USE ADJ_ARRAYS_MOD, ONLY : MFD, EMSFD + USE ADJ_ARRAYS_MOD, ONLY : FD_DIFF + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : ICSFD + USE ADJ_ARRAYS_MOD, ONLY : STRFD + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF, RATE_SF0 + USE ADJ_ARRAYS_MOD, ONLY : RATFD + + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + + +# include "CMN_SIZE" ! Size params + + !================================================================= + ! SET_SF_FORFD begins here! + !================================================================= + + ICS_SF(:,:,:,:) = ICS_SF0(:,:,:,:) + IF ( LADJ_EMS ) EMS_SF(:,:,:,:) = EMS_SF0(:,:,:,:) + IF ( LADJ_STRAT ) THEN + PROD_SF(:,:,:,:) = PROD_SF0(:,:,:,:) + LOSS_SF(:,:,:,:) = LOSS_SF0(:,:,:,:) + ENDIF + IF ( LADJ_RRATE ) THEN + RATE_SF(:,:,:,:) = RATE_SF0(:,:,:,:) + ENDIF + + ! Nudge the scaling factor value only in the FD cell + IF ( LFD_SPOT ) THEN + + ! for initial conditions : + IF ( LICS ) THEN + + IF ( N_CALC == 2 ) THEN + ICS_SF(IFD,JFD,LFD,ICSFD) = ICS_SF(IFD,JFD,LFD,ICSFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + ICS_SF(IFD,JFD,LFD,ICSFD) = ICS_SF(IFD,JFD,LFD,ICSFD) + & - FD_DIFF + ENDIF + + ! for boundary conditions : + ELSEIF ( LADJ_EMS ) THEN + + ! Strat prod and loss (hml) + IF ( .NOT. LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + IF ( N_CALC == 2 ) THEN + EMS_SF(IFD,JFD,MFD,EMSFD) = EMS_SF(IFD,JFD,MFD,EMSFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + EMS_SF(IFD,JFD,MFD,EMSFD) = EMS_SF(IFD,JFD,MFD,EMSFD) + & - FD_DIFF + ENDIF + + ELSEIF ( LADJ_STRAT ) THEN + IF ( N_CALC == 2 ) THEN + LOSS_SF(IFD,JFD,MFD,STRFD) = LOSS_SF(IFD,JFD,MFD,STRFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + LOSS_SF(IFD,JFD,MFD,STRFD) = LOSS_SF(IFD,JFD,MFD,STRFD) + & - FD_DIFF + ENDIF + + ! Reaction rates (tww) + ELSEIF ( LADJ_RRATE ) THEN + IF ( N_CALC == 2 ) THEN + RATE_SF(IFD,JFD,LFD,RATFD) = RATE_SF(IFD,JFD,LFD,RATFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + RATE_SF(IFD,JFD,LFD,RATFD) = RATE_SF(IFD,JFD,LFD,RATFD) + & - FD_DIFF + ENDIF + ENDIF + + ENDIF + + ! Perturb thoughout model domain. + ELSEIF ( LFD_GLOB ) THEN + + ! for test with no transport: + print*, 'PERTURB GLOBALLY !!!!' + + IF ( LICS ) THEN + + IF ( N_CALC == 2 ) THEN + ICS_SF(:,:,LFD,ICSFD) = ICS_SF(:,:,LFD,ICSFD) + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + ICS_SF(:,:,LFD,ICSFD) = ICS_SF(:,:,LFD,ICSFD) - FD_DIFF + ENDIF + + ELSEIF ( LADJ_EMS ) THEN + + ! Strat prod and loss (hml) + IF ( .NOT. LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + IF ( N_CALC == 2 ) THEN + EMS_SF(:,:,MFD,EMSFD) = EMS_SF(:,:,MFD,EMSFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + EMS_SF(:,:,MFD,EMSFD) = EMS_SF(:,:,MFD,EMSFD) + & - FD_DIFF + ENDIF + + ! Make RRATE default when both turned on (hml, 06/08/13) + !ELSEIF ( LADJ_STRAT ) THEN + ELSEIF ( LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + + IF ( N_CALC == 2 ) THEN + LOSS_SF(:,:,MFD,STRFD) = LOSS_SF(:,:,MFD,STRFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + LOSS_SF(:,:,MFD,STRFD) = LOSS_SF(:,:,MFD,STRFD) + & - FD_DIFF + ENDIF + + ! Reaction rates (tww) + ELSEIF ( LADJ_RRATE ) THEN + IF ( N_CALC == 2 ) THEN + RATE_SF(:,:,LFD,RATFD) = RATE_SF(:,:,LFD,RATFD) + & + FD_DIFF + ELSEIF ( N_CALC == 3 ) THEN + RATE_SF(:,:,LFD,RATFD) = RATE_SF(:,:,LFD,RATFD) + & - FD_DIFF + ENDIF + + ENDIF + ENDIF + + ENDIF + + + ! Return to calling program + END SUBROUTINE SET_SF_FORFD + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_CFN_FILE( ) +! +!****************************************************************************** +! Subroutine MAKE_CFN_FILE creates a cfn.NN file which stores the current +! iteration number and cost function value. (dkh, 02/13/06) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! +! Module Variable as Output: +! ============================================================================ +! (1 ) COST_FUNC : Current cost function value +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE FILE_MOD, ONLY : IOERROR + +# include "CMN_SIZE" + + ! Local variables + CHARACTER(LEN=80) :: OUTPUT_CFN_FILE + CHARACTER(LEN=120) :: REMOVE_CFN_FILE_CMD + CHARACTER(LEN=80) :: FILENAME + INTEGER :: IOS + + !================================================================= + ! MAKE_CFN_FILE begins here! + !================================================================= + + ! Make file name + OUTPUT_CFN_FILE = 'cfn.NN' + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_CFN_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the OPTDATA_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + !================================================================= + ! Open the cfn file for output + !================================================================= + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_CFN_FILE: Writing ', a ) + + ! Remove any previous cfn files for the current iteration + REMOVE_CFN_FILE_CMD = 'rm ' // TRIM (FILENAME) + + CALL SYSTEM ( TRIM( REMOVE_CFN_FILE_CMD ) ) + + + ! Open file for input + OPEN( 65, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL', + & POSITION='APPEND' ) + + ! Error check + IF ( IOS /= 0 ) CALL IOERROR( IOS, 65, 'write_cost_func:1') + + ! Write iteration number and cost function + WRITE( 65, *) N_CALC, COST_FUNC + + + ! Return to calling program + END SUBROUTINE MAKE_CFN_FILE +!------------------------------------------------------------------------------ + + SUBROUTINE READ_CFN_FILE( ) +! +!****************************************************************************** +! Subroutine READ_CFN_FILE reads the value fo the cost function at iteration +! NN from the cfn.NN file. (dkh, 02/13/06) +! +! Module Variable as Input: +! ============================================================================ +! (1 ) N_CALC : Current iteration number +! +! Module variable as Output: +! ============================================================================ +! (1 ) COST_FUNC : Cost function value +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE FILE_MOD, ONLY : IOERROR + USE ERROR_MOD, ONLY : ERROR_STOP + +# include "CMN_SIZE" + + ! Local variables + CHARACTER(LEN=80) :: OUTPUT_CFN_FILE + CHARACTER(LEN=80) :: FILENAME + INTEGER :: N, N_TMP, IOS + REAL*8 :: CFN_TMP, COST_FUNC_check + LOGICAL :: FOUND = .FALSE. + + !================================================================= + ! READ_CFN_FILE begins here! + !================================================================= + + ! Make file name + OUTPUT_CFN_FILE = 'cfn.NN' + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_CFN_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the OPTDATA_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + !================================================================= + ! Open the cost function file for input + !================================================================= + + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_CFN_FILE: Reading ', a ) + + ! Open file for input -- readonly + OPEN( 65, FILE=TRIM( FILENAME ), STATUS='UNKNOWN', + & IOSTAT=IOS, FORM='FORMATTED', ACCESS='SEQUENTIAL', + & POSITION='REWIND') + + ! Error check + IF ( IOS /= 0 ) CALL IOERROR( IOS, 65, 'read_cost_func:1') + + ! Read values in file + READ( 65, *) N_TMP, CFN_TMP + + ! Check to make sure that we're reading the correct file. If so, update + ! COST_FUNC with the value from the file. + IF ( N_TMP == N_CALC) THEN + COST_FUNC = CFN_TMP + FOUND = .TRUE. + ENDIF + + ! Error check + IF ( .NOT. FOUND ) THEN + CALL ERROR_STOP('Cost function value missing', 'inverse_mod' ) + ENDIF + + ! Return to calling program + END SUBROUTINE READ_CFN_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE SET_OPT_RANGE( ) +! +!****************************************************************************** +! Subroutine SET_OPT_RANGE sets the range of the emissions which we +! wish to optimize by setting all others to zero. (dkh, 10/17/06) +! +! +! Module variables as Input: +! ============================================================================ +! (1 ) EMS_SF_ADJ : All emissions gradients +! (2 ) ICS_SF_ADJ : All tracer gradients +! (3 ) OPT_THIS_EMS : Logial array of emissions to optimize +! (4 ) OPT_THIS_ICS : Logial array of initial conditions to optimize +! +! Module variables as Output: +! ============================================================================ +! (1 ) EMS_SF_ADJ : All emissions gradients +! (2 ) ICS_SF_ADJ : All tracer gradients +! +! NOTES: +! (1 ) Replace CMN_ADJ, update naming, add spatial filter from ks +! (dkh, ks, mak, cs 06/07/09) +! (2 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : ICS_SF_ADJ, EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NNEMS + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_EMS, OPT_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_PROD + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_LOSS + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_ADJ_MOD, ONLY : LICS, LADJ_EMS + USE TRACER_MOD, ONLY : N_TRACERS + ! added for reaction rates (tww, 05/15/12) + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : OPT_THIS_RATE + USE ADJ_ARRAYS_MOD, ONLY : NRRATES, RATFD + USE LOGICAL_ADJ_MOD, ONLY : LADJ_RRATE + + +# include "CMN_SIZE" ! Size params + + ! Local variables + INTEGER I, J, M, N + + !================================================================= + ! SET_OPT_RANGE begins here! + !================================================================= + + ! dkh debug + print*, ' SET_OPT_RANGE: MIN / MAX ICS_SF_ADJ = ', + & MINVAL(ICS_SF_ADJ), MAXVAL(ICS_SF_ADJ) + + IF ( LICS ) THEN + DO N = 1, N_TRACERS + IF ( .not. OPT_THIS_TRACER(N) ) THEN + ICS_SF_ADJ(:,:,:,N) = 0d0 + ENDIF + ENDDO + ENDIF + + ! dkh debug + print*, ' SET_OPT_RANGE 2 : MIN / MAX ICS_SF_ADJ = ', + & MINVAL(ICS_SF_ADJ), MAXVAL(ICS_SF_ADJ) + + ! Zero the gradients of the species we don't want to optimize + IF ( LADJ_EMS ) THEN + DO N = 1, NNEMS + IF ( .not. OPT_THIS_EMS(N) ) THEN + EMS_SF_ADJ(:,:,:,N) = 0d0 + ENDIF + ENDDO + + ! Strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + DO N = 1, NSTPL + IF ( .not. OPT_THIS_PROD(N) ) THEN + PROD_SF_ADJ(:,:,:,N) = 0d0 + ENDIF + IF ( .not. OPT_THIS_LOSS(N) ) THEN + LOSS_SF_ADJ(:,:,:,N) = 0d0 + ENDIF + ENDDO + ENDIF + + ! reaction rates (tww, 05/15/12) + IF ( LADJ_RRATE ) THEN + ! tww debug + print*, ' SET_OPT_RANGE 3 : MIN / MAX RATE_SF_ADJ = ', + & MINVAL(RATE_SF_ADJ), MAXVAL(RATE_SF_ADJ) + print*, 'OPT_THIS_RATE = ', OPT_THIS_RATE(:) + print*, 'RATFD = ', RATFD + + DO N = 1, NRRATES + IF ( .not. OPT_THIS_RATE(N) ) THEN + RATE_SF_ADJ(:,:,:,N) = 0d0 + ENDIF + ENDDO + + ! tww debug + print*,' SET_OPT_RANGE 4 : MIN / MAX RATE_SF_ADJ = ', + & MINVAL(RATE_SF_ADJ), MAXVAL(RATE_SF_ADJ) + ! tww debug + print*,' SET_OPT_RANGE 5 : MIN / MAX RATE_SF_ADJ(RATFD) = ', + & MINVAL(RATE_SF_ADJ(:,:,:,RATFD)), + & MAXVAL(RATE_SF_ADJ(:,:,:,RATFD)) + ENDIF + + + + ENDIF + + +! ! Only consider gradients in specific spatial range +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M, N ) +! DO N = 1, NNEMS +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Zero the gradients which we don't +! ! want to optimize +!! IF ( (( I < 42 .and. I > 34 ) .and. ! IN +!! & ( J > 32 .and. J < 39 )) ! EUROPE +!! IF ( (( I > 18 .and. I < 23 ) .and. ! IN +!! & ( J > 30 .and. J < 35 )) ! Eastern US +!! IF ( (( I < 19 .or. I > 22 ) .or. ! not IN +!! & ( J < 31 .or. J > 34 )) ! Eastern US +! IF ( (( I < 12 .or. I > 22 ) .or. ! not IN +! & ( J < 31 .or. J > 34 )) ! US +! & .or. +! & ( .not. OPT_THIS_EMS(N) ) ) THEN +! +! EMS_SF_ADJ(I,J,M,N) = 0d0 +! +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! + +! old code from ks +!#if defined ( TES_O3_OBS ) +! +! ! Zero the gradients above NLEVS +! ICS_FD_ADJ(:,:,NLEVS+1:LLPAR,:) = 0d0 +! +! ! Smoothly drive gradients to zero at poles +! IF (NLAT_TO_IGNORE > 0) THEN +! +! DO N = 1, N_TRACERS +! DO L = 1, NLEVS +! DO J = 1, NLAT_TO_IGNORE +! DO I = 1, IIPAR +! TEMP = NLAT_TO_IGNORE - J +! FACTOR = COS( (TEMP / ( NLAT_TO_IGNORE - 1 ) ) +! & * ( pi / 2 )**2 +! ICS_FD_ADJ(I,J,L,N) = ICS_FD_ADJ(I,J,L,N) * FACTOR +! ENDDO +! ENDDO +! ENDDO +! ENDDO +! +! DO N = 1, N_TRACERS +! DO L = 1, NLEVS +! DO J = JJPAR - NLAT_TO_IGNORE + 1, JJPAR +! DO I = 1,IIPAR +! TEMP = NLAT_TO_IGNORE - J +! FACTOR = COS( (TEMP / ( NLAT_TO_IGNORE - 1 ) ) +! & * ( pi / 2 )**2 +! ICS_FD_ADJ(I,J,L,N) = ICS_FD_ADJ(I,J,L,N) * FACTOR +! ENDDO +! ENDDO +! ENDDO +! ENDDO +! +! ENDIF +!#endif + + ! Return to calling program + END SUBROUTINE SET_OPT_RANGE + +!------------------------------------------------------------------------------ + DOUBLE PRECISION FUNCTION DRAN(K) +C +C RANDOM NUMBER GENERATOR - BASED ON ALGORITHM 266 BY PIKE AND +C HILL (MODIFIED BY HANSSON), COMMUNICATIONS OF THE ACM, +C VOL. 8, NO. 10, OCTOBER 1965. +C +C THE SINGLE PRECISION VERSION OF THIS SUBPROGRAM IS INTENDED +C FOR USE ON COMPUTERS WITH FIXED POINT WORDLENGTH OF AT +C LEAST 29 BITS. IT IS BEST IF THE FLOATING POINT +C SIGNIFICAND HAS AT MOST 29 BITS. +C +C FOLLOWING CODY AND WAITE'S RECOMMENDATION (P .14), WE +C PRODUCE A PAIR OF RANDOM NUMBERS AND USE RAN1 + +C 2**(-29)*RAN2 IN AN ATTEMPT TO GENERATE ABOUT 58 RANDOM BITS. +C + INTEGER IY,J,K + DATA IY /100001/ +C + J = K + IY = IY * 125 + IY = IY - (IY/2796203) * 2796203 + DRAN = DBLE(FLOAT(IY)) / 2796203.0D+00 +C + IY = IY * 125 + IY = IY - (IY/2796203) * 2796203 + DRAN = DRAN + (DBLE(FLOAT(IY)) / 2796203.0D+00) / 536870912.0D+00 + RETURN +C ---------- LAST CARD OF DRAN ---------- + END FUNCTION DRAN +! needs to be updated: +!-------------------------------------------------------------------------------- +! +! SUBROUTINE UPDATE_HESSIAN( ) +! +!****************************************************************************** +! Subroutine UPDATE_HESSIAN constructs an approximation of the inverse +! Hessian using the DFP formula (see Muller and Stavrakou, 2005, eqn 18). +! +! This routine is set up to be used offline so that the Hessian is +! only approximated at the end of a convered optimization. To implement, +! uncomment code in 3 places in inverse.f +! +! The initial estimate can be identiy matrix or initial estimate of uncertainty +! +! It takes too long to consider all possible correlations, so we apply the +! following filters: +! - Only consider corelations between emissions of +! - anth SOx (surface and stack) +! - anth NOx (surface and stack) +! - anth NH3 +! - natural NH3 +! - Only within the U.S. +! - Only in places where ADJ_EMS at first iteration is > 1d-4 +! +! If these filters are changes, the array diminsion HMAX will need to be +! updated. To determine the size of the MASD parameter, do a dry run, +! then go back and update. +! +! NOTES: +! +!****************************************************************************** +! +! +! print*, ' SUBROUTINE UPDATE_HESSIAN needs to be updated ' +! print*, ' SUBROUTINE UPDATE_HESSIAN needs to be updated ' +! print*, ' SUBROUTINE UPDATE_HESSIAN needs to be updated ' +! print*, ' SUBROUTINE UPDATE_HESSIAN needs to be updated ' +! +! ! Reference to f90 modules +! +!# include "CMN_SIZE" +! +! ! Arguments +! +! ! Local variables +! INTEGER, PARAMETER :: HMAX = 3675 +! +! INTEGER :: I, J, M, N, II, JJ, NITR +! +! REAL*8, SAVE :: USA_MASK(IIPAR,JJPAR) +! +! INTEGER, SAVE :: IIMAP(IIPAR,JJPAR,MMSCL,NNEMS) = 0d0 +! INTEGER, SAVE :: MAPI(HMAX), MAPJ(HMAX) +! INTEGER, SAVE :: MAPM(HMAX), MAPN(HMAX) +! +! REAL*8, SAVE :: EMS_SF_OLD(IIPAR,JJPAR,MMSCL,NNEMS) +! REAL*8, SAVE :: ADJ_EMS_OLD(IIPAR,JJPAR,MMSCL,NNEMS) +! REAL*8, SAVE :: HINV(HMAX,HMAX) +! LOGICAL, SAVE :: FIRST = .TRUE. +! +! REAL*8 :: S(HMAX), Y(HMAX), YTS, YTHINVY +! REAL*8 :: YTS_INV, YTHINVY_INV +! REAL*8 :: SST(HMAX,HMAX), HINVY(HMAX), YTHINV(HMAX) +! REAL*8 :: HINVYYTHINV(HMAX,HMAX) +! +! !================================================================= +! ! UPDATE_HESSIAN begins here! +! !================================================================= +! +! PRINT*, ' UPDATE HESSIAN AT ITERATE ', N_CALC +! +! +! IF ( FIRST ) THEN +! +! ! Initialize HINV to the identity matrix (or initial unc. est) +! HINV(:,:) = 0d0 +! +! DO JJ = 1, HMAX +! DO II = 1, HMAX +! +! IF ( II == JJ ) HINV(II,II) = 0.3d0 +! +! ENDDO +! ENDDO +! +! ! Get USA mask +! CALL READ_USA_MASK( USA_MASK ) +! +! ! dkh debug +! print*, ' yea yea eya' +! +! II = 0 +! +! DO N = 1, NNEMS +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Spatial filter +! ! Only in US: +!! IF ( USA_MASK(I,J) == 0d0 ) CYCLE +! ! Only in places where emissions are nonzero +! IF ( ABS(ADJ_EMS(I,J,M,N)) < 1d-4 ) CYCLE +! +! IF ( +! & N == IDADJEMS_ESOx1 .or. +! & N == IDADJEMS_ESOx2 .or. +! & N == IDADJEMS_ENOx1 .or. +! & N == IDADJEMS_ENOx2 .or. +! & N == IDADJEMS_ENH3_an .or. +! & N == IDADJEMS_ENH3_na +! & ) THEN +! +! +! ! Update vector index +! II = II + 1 +! +! ! Save mapping arrays +! IIMAP(I,J,M,N) = II +! MAPI(II) = I +! MAPJ(II) = J +! MAPM(II) = M +! MAPN(II) = N +! +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +! ENDDO +! +! +! EMS_ICS_OLD(:,:,:,:) = EMS_ICS(:,:,:,:) +! ADJ_EMS_OLD(:,:,:,:) = ADJ_EMS(:,:,:,:) +! print*, ' UPDATE HESSIAN, pts founds = ', II +! CALL MAKE_HESS_FILE( HINV, USA_MASK , HMAX, IIMAP , 1 ) +! FIRST = .FALSE. +! +! +! print*, 'EMS_ICS = ', EMS_ICS(19,33,1,IDADJEMS_ESOx2) +! print*, 'EMS_ICS_OLD = ', EMS_ICS_OLD(19,33,1,IDADJEMS_ESOx2) +! print*, 'ADJ_EMS = ', ADJ_EMS(19,33,1,IDADJEMS_ESOx2) +! print*, 'ADJ_EMS_OLD = ', ADJ_EMS_OLD(19,33,1,IDADJEMS_ESOx2) +! +! RETURN +! ENDIF +! +! +! DO II = 1, HMAX +! +! I = MAPI(II) +! J = MAPJ(II) +! M = MAPM(II) +! N = MAPN(II) +! +! ! find s_k = f_{k+1} - f_{k} +! S(II) = EMS_ICS(I,J,M,N) - EMS_ICS_OLD(I,J,M,N) +! +! ! find y_k = grad_{k+1} - grad_{k} +! Y(II) = ADJ_EMS(I,J,M,N) - ADJ_EMS_OLD(I,J,M,N) +! +! ENDDO +! +! print*, ' UPDATE HESSIAN, pts founds = ', II +! +! print*, 'EMS_ICS = ', EMS_ICS(19,33,1,IDADJEMS_ESOx2) +! print*, 'EMS_ICS_OLD = ', EMS_ICS_OLD(19,33,1,IDADJEMS_ESOx2) +! print*, 'ADJ_EMS = ', ADJ_EMS(19,33,1,IDADJEMS_ESOx2) +! print*, 'ADJ_EMS_OLD = ', ADJ_EMS_OLD(19,33,1,IDADJEMS_ESOx2) +! +! ! Rotate +! EMS_ICS_OLD(:,:,:,:) = EMS_ICS(:,:,:,:) +! ADJ_EMS_OLD(:,:,:,:) = ADJ_EMS(:,:,:,:) +! +! !---------------------------------------------------------- +! ! Update inverse Hessian +! !---------------------------------------------------------- +! +! ! y^T*s +! YTS = 0d0 +! DO II = 1, HMAX +! +! YTS = YTS + Y(II) * S(II) +! +! ENDDO +! +! print*, ' YTS = ', YTS , N_CALC +! +! ! s * s^T / YTS +! DO II = 1, HMAX +! DO JJ = 1, HMAX +! +! SST(II,JJ) = S(II) * S(JJ) +! +! ENDDO +! ENDDO +! +! ! HINV * y +! DO II = 1, HMAX +! +! HINVY(II) = 0D0 +! +! DO JJ = 1, HMAX +! +! HINVY(II) = HINVY(II) + HINV(II,JJ) * Y(JJ) +! +! ENDDO +! ENDDO +! +! ! y^T * HINV +! DO JJ = 1, HMAX +! +! YTHINV(JJ) = 0d0 +! +! DO II = 1, HMAX +! +! YTHINV(JJ) = YTHINV(JJ) + Y(II) * HINV(II,JJ) +! +! ENDDO +! ENDDO +! +! +! ! HINVY * YTHINV +! DO JJ = 1, HMAX +! DO II = 1, HMAX +! +! HINVYYTHINV(II,JJ) = HINVY(II) * YTHINV(JJ) +! +! ENDDO +! ENDDO +! +! +! ! YT * HINVY +! YTHINVY = 0d0 +! DO II = 1, HMAX +! YTHINVY = YTHINVY + Y(II) * HINVY(II) +! ENDDO +! print*, 'YTHINVY = ', YTHINVY +! +! ! HINV = HINV + SST * (1/YTS) - HINVYYTHINV * (1/YTHINVY) +! YTS_INV = 1 / YTS +! YTHINVY_INV = 1 / YTHINVY +! DO JJ = 1, HMAX +! DO II = 1, HMAX +! +! HINV(II,JJ) = HINV(II,JJ) +! & + SST(II,JJ) * YTS_INV +! & - HINVYYTHINV(II,JJ) * YTHINVY_INV +! +! ENDDO +! ENDDO +! +! print*, ' MAX HINV = ', MAXVAL(HINV(:,:)) +! print*, ' MIN HINV = ', MINVAL(HINV(:,:)) +! +! NITR = N_CALC +! +! CALL MAKE_HESS_FILE( HINV, USA_MASK , HMAX, IIMAP , NITR ) +! +! ! Return to calling program +! END SUBROUTINE UPDATE_HESSIAN +!!------------------------------------------------------------------------------ +! needs to be updated +! +! SUBROUTINE MAKE_HESS_FILE( HINV, USA_MASK , HMAX, IIMAP, NITR ) +!! +!!****************************************************************************** +!! Subroutine MAKE_HESS_FILE creates a binary file of selected elements +!! of the approximate inverse hessian. (dkh, 05/15/07) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) HINV : Current estimate of inverse hessian +!! +!! Module Variable as Input: +!! ============================================================================ +!! (1 ) N_CALC : Current iteration number +!! +!! NOTES: +!! (1 ) Just like MAKE_GDT_FILE except +!! - pass NITR as an argument +!!****************************************************************************** +!! +! +! ! References to F90 modules +! USE BPCH2_MOD +! USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP +! USE FILE_MOD, ONLY : IU_RST, IOERROR +! USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET +! USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_SETUP" ! +!# include "CMN" ! LPRT +!# include "CMN_ADJ" ! NADJ, OPTDATA_DIR, ACTIVE_VARS +! +! +! ! Arguments +! INTEGER :: HMAX +! REAL*8 :: HINV(HMAX,HMAX) +! REAL*8 :: USA_MASK(IIPAR,JJPAR) +! INTEGER :: IIMAP(IIPAR,JJPAR,MMSCL,NNEMS) +! INTEGER :: NITR +! +! ! Local Variables +! INTEGER :: I, I0, IOS, J, J0, L, M, N, II, JJ +! INTEGER :: YYYY, MM, DD, HH, SS +! REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) +! REAL*4 :: EMS_3D(IIPAR,JJPAR,MMSCL) +! CHARACTER(LEN=255) :: FILENAME +! +! ! For binary punch file, version 2.0 +! REAL*4 :: LONRES, LATRES +! INTEGER, PARAMETER :: HALFPOLAR = 1 +! INTEGER, PARAMETER :: CENTER180 = 1 +! +! CHARACTER(LEN=20) :: OUTPUT_GDT_FILE +! CHARACTER(LEN=20) :: MODELNAME +! CHARACTER(LEN=40) :: CATEGORY +! CHARACTER(LEN=40) :: UNIT +! CHARACTER(LEN=40) :: RESERVED = '' +! CHARACTER(LEN=80) :: TITLE +! +! !================================================================= +! ! MAKE_HESS_FILE begins here! +! !================================================================= +! +! ! Clear intermediate arrays +! EMS_3D(:,:,:) = 0d0 +! +! ! Hardwire output file for now +!#if defined( GEOS_1 ) || defined( GEOS_STRAT ) +! OUTPUT_GDT_FILE = 'gctm.invhess.NN' +!#else +! OUTPUT_GDT_FILE = 'gctm.invhess.NN' +!#endif +! +! ! Define variables for BINARY PUNCH FILE OUTPUT +! TITLE = 'GEOS-CHEM Adjoint File: ' // +! & 'Inverse hessian ' +! UNIT = 'none' +! CATEGORY = 'IJ-INVH-' +! LONRES = DISIZE +! LATRES = DJSIZE +! +! ! Call GET_MODELNAME to return the proper model name for +! ! the given met data being used (bmy, 6/22/00) +! MODELNAME = GET_MODELNAME() +! +! ! Get the nested-grid offsets +! I0 = GET_XOFFSET( GLOBAL=.TRUE. ) +! J0 = GET_YOFFSET( GLOBAL=.TRUE. ) +! +! !================================================================= +! ! Open the adjoint file for output -- binary punch format +! !================================================================= +! +! ! Copy the output observation file name into a local variable +! FILENAME = TRIM( OUTPUT_GDT_FILE ) +! +! ! Append the iteration number suffix to the file name +! CALL EXPAND_NAME( FILENAME, NITR ) +! +! ! Add the OPTDATA_DIR prefix to the file name +! FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) +! +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - MAKE_HESS_FILE: Writing ', a ) +! +! ! Open checkpoint file for output +! CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) +! +!! IF ( ACTIVE_VARS == 'TRACERS'.OR. +!! & ACTIVE_VARS == 'FDTEST' ) THEN +! IF ( ACTIVE_VARS == 'TRACERS' ) THEN +! +! CALL ERROR_STOP( 'inverse hessian not supported ', +! & ' MAKE_HESS_FILE, inverse_mod.f') +! +! ELSEIF ( ACTIVE_VARS == 'EMISSIONS' .OR. +! & ACTIVE_VARS == 'FDTEST' ) THEN +! +! ! Reset CATEGORY as labeling in gamap is different +! CATEGORY = 'IJ-INVH-' +! +! !================================================================= +! ! Write each observed quantity to the observation file +! !================================================================= +! DO N = 1, NNEMS +! +! !Temporarily store quantities in the TRACER array +! EMS_3D(I,J,M) = 0d0 +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M, II ) +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! +! II = IIMAP(I,J,M,N) +! IF ( II == 0 ) CYCLE +! +! IF ( HINV(II,II) > 0 ) THEN +! EMS_3D(I,J,M) = REAL(SQRT(HINV(II,II))) +! ELSE +! print*, I, J, M, N, II +! CALL ERROR_STOP('non positive hessian diagonal ', +! & 'inverse_mod.f') +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ENDDO +! +! ! Reset CATEGORY as labeling in gamap is different +! CATEGORY = 'IJ-COREL' +! +! !================================================================= +! ! Write correlation for a given cell +! !================================================================= +! DO N = 1, NNEMS +! +! ! target cell +! JJ = IIMAP(13,33,1,IDADJEMS_ENH3_an) +! +! !Temporarily store quantities in the TRACER array +! EMS_3D(I,J,M) = 0d0 +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, M, II ) +! DO M = 1, MMSCL +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! +! II = IIMAP(I,J,M,N) +! !IF ( II == 0 ) CYCLE +! IF ( II == 0 ) THEN +! EMS_3D(I,J,M) = 0d0 +! ELSE +! EMS_3D(I,J,M) = REAL(HINV(II,JJ)/(SQRT(HINV(II,II)) +! & * SQRT(HINV(JJ,JJ)))) +! ENDIF +! +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, MMSCL, I0+1, +! & J0+1, 1, EMS_3D ) +! +! ENDDO +! ELSE +! CALL ERROR_STOP( 'ACTIVE_VARS not defined!', +! & 'MAKE_HESS_FILE' ) +! ENDIF +! +! ! Close file +! CLOSE( IU_RST ) +! +! !### Debug +! IF ( LPRT ) CALL DEBUG_MSG( '### MAKE_HESS_FILE: wrote file' ) +! +! ! Return to calling program +! END SUBROUTINE MAKE_HESS_FILE + +!------------------------------------------------------------------------------ +! SUBROUTINE READ_USA_MASK( USA_MASK ) +!! +!!****************************************************************************** +!! Subroutine READ_USA_MASK reads the USA mask from disk. The USA mask is +!! the fraction of the grid box (I,J) which lies w/in the continental USA. +!! (rch, bmy, 11/10/04, 10/3/05) +!! +!! NOTES: +!! (1 ) Now can read data for GEOS and GCAP grids (bmy, 8/16/05) +!! (2 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!!****************************************************************************** +!! +! ! Reference to F90 modules +! !USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! +!#include "CMN_SIZE" +! +! ! Local variables +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*8 :: XTAU +! REAL*8 :: USA_MASK(IGLOB,JGLOB) +! CHARACTER(LEN=255) :: FILENAME +! +! +! !================================================================= +! ! READ_USA_MASK begins here! +! !================================================================= +! +! ! File name +! ! Argg - haven't initialized the forward model yet, so DATA_DIR undefined +! ! Just put the mask in the home directory +!! FILENAME = TRIM( DATA_DIR ) // +!! & 'EPA_NEI_200411/usa_mask.' // GET_NAME_EXT_2D() // +! FILENAME = +! & 'usa_mask.geos' // +! & '.' // GET_RES_EXT() +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_USA_MASK: Reading ', a ) +! +! ! Get TAU0 for Jan 1985 +! XTAU = GET_TAU0( 1, 1, 1985 ) +! +! ! USA mask is stored in the bpch file as #2 +! CALL READ_BPCH2( FILENAME, 'LANDMAP', 2, +! & XTAU, IGLOB, JGLOB, +! & 1, ARRAY, QUIET=.TRUE. ) +! +! ! Cast to REAL*8 +! !CALL TRANSFER_2D( ARRAY(:,:,1), USA_MASK ) +! USA_MASK(:,:) = ARRAY(:,:,1) +! +! ! Return to calling program +! END SUBROUTINE READ_USA_MASK +! +!!------------------------------------------------------------------------------ + SUBROUTINE CALC_NOPT + +! +!****************************************************************************** +! Subroutine CALC_NOPT calculates the number of paramteres to optimize +! +! NOTES: +! (1 ) Set NOPT for initial conditions to 3D: IIPAR*JJPAR*LLPAR*N_TRACERS to +! be consistent with other parts of the code (mak, 6/18/09) +! (2 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NOPT + USE ADJ_ARRAYS_MOD, ONLY : MMSCL, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_ADJ_MOD, ONLY : LADJ_EMS, LICS + USE TRACER_MOD, ONLY : N_TRACERS, ITS_A_TAGCO_SIM + +# include "CMN_SIZE" + + !================================================================= + ! CALC_NOPT begins here! + !================================================================= + + ! if optimizing both initial emissions and initial conditions + IF ( LADJ_EMS .AND. LICS ) THEN + NOPT = IIPAR * JJPAR * MMSCL * NNEMS + + & IIPAR * JJPAR * LLPAR * N_TRACERS + + ! if optimizing emissions only + ELSEIF ( LADJ_EMS ) THEN + + NOPT = IIPAR * JJPAR * MMSCL * NNEMS + + IF ( ITS_A_TAGCO_SIM() .AND. NNEMS == 2 ) THEN + NOPT = IIPAR * JJPAR * MMSCL + 1 + ENDIF + + ! Strat prod and loss (hml) + !!IF ( LADJ_STRAT .AND. .NOT. LADJ_RRATE ) THEN + IF ( LADJ_STRAT ) THEN + NOPT = NOPT + IIPAR * JJPAR * MMSCL * NSTPL * 2 + !!NOPT = IIPAR * JJPAR * MMSCL * ( NSTPL * 2 + NNEMS ) + ENDIF + + ! Reaction rates (tww) + !!! To avoid double counting (hml, 06/11/13) + !!IF ( LADJ_RRATE .AND. LADJ_STRAT ) THEN + IF ( LADJ_RRATE ) THEN + NOPT = NOPT + IIPAR * JJPAR * LLPAR * NRRATES + ENDIF + !!NOPT = IIPAR * JJPAR * LLPAR + !! * ( NRRATES+ NNEMS + NSTPL*2 ) + !!ELSEIF ( LADJ_RRATE .AND. .NOT. LADJ_STRAT ) THEN + !!NOPT = IIPAR * JJPAR * LLPAR * ( NRRATES + NNEMS ) + !!ENDIF + + ! if optimizing initial conditions only + ELSEIF ( LICS ) THEN + + NOPT = IIPAR * JJPAR * LLPAR * N_TRACERS + + ENDIF + + PRINT*, 'Max size of control vector is:', NOPT + + ! Return to calling program + END SUBROUTINE CALC_NOPT + +!------------------------------------------------------------------------------ + + SUBROUTINE ITER_CONDITION( IT ) +! +!****************************************************************************** +! Subroutine ITER_CONDITION output information which will be used +! to determine whether the convergence has been reached (zhe 11/28/10) +! +! Variable as Input: +! ============================================================================ +! (1 ) IT : Current iteration number +! +! NOTES: +! (1 ) Place output in DIAGADJ_DIR instead of OPTDATA_DIR (dkh, 02/04/11) +! (2 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : COST_FUNC_SAV + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE + USE LOGICAL_ADJ_MOD, ONLY : LATF + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER :: IT + + + ! Local variables + INTEGER :: I + REAL*4 :: PG, NG, PS, NS + CHARACTER(LEN=255) :: FILENAME + LOGICAL, SAVE :: FIRST = .TRUE. + + ! For strat prod and loss (hml) + REAL*4 :: PG_P, PG_L, NG_P, NG_L + REAL*4 :: PS_P, PS_L, NS_P, NS_L + + !================================================================= + ! ITER_CONDITION begins here! + !================================================================= + + PG = 0.0 + NG = 0.0 + PS = 0.0 + NS = 0.0 + + ! For strat prod and loss (hml) + PG_P = 0.0 + NG_p = 0.0 + PS_P = 0.0 + NS_P = 0.0 + PG_L = 0.0 + NG_L = 0.0 + PS_L = 0.0 + NS_L = 0.0 + + FILENAME = 'gctm.iteration' + FILENAME = TRIM( DIAGADJ_DIR ) // TRIM( FILENAME ) + + IF ( FIRST ) THEN + OPEN (99, FILE = FILENAME, STATUS ='REPLACE') + WRITE(99, 1001) + WRITE(99, 1002) + FIRST = .FALSE. + ENDIF + + ! For strat prod and loss (hml) + IF ( LADJ_STRAT ) THEN + + DO I = 1, IIPAR * JJPAR + IF ( GRADNT_P(I) .GT. 0 .AND. GRADNT_L(I) .GT. 0 ) THEN + PG_P = PG_P + GRADNT_P(I) + PG_L = PG_L + GRADNT_L(I) + ELSE + NG_P = NG_P + GRADNT_P(I) + NG_L = NG_L + GRADNT_L(I) + ENDIF + + IF ( XP(I) .GT. 1 .AND. XL(I) .GT. 1 ) THEN + PS_P = PS_P + XP(I) - 1 + PS_L = PS_L + XL(I) - 1 + ELSE + NS_P = NS_P + XP(I) - 1 + NS_L = NS_L + XL(I) - 1 + ENDIF + ENDDO + + WRITE(99, 1005) IT, LATF, COST_FUNC_SAV(IT), + & COST_FUNC_SAV(IT)/COST_FUNC_SAV(1), PG_P, PG_L, + & NG_P, NG_L, PS_P, PS_L, NS_P, NS_L + + ELSE + + DO I = 1, IIPAR * JJPAR + IF ( GRADNT(I) .GT. 0 ) THEN + PG = PG + GRADNT(I) + ELSE + NG = NG + GRADNT(I) + ENDIF + + IF ( X(I) .GT. 1 ) THEN + PS = PS + X(I) - 1 + ELSE + NS = NS + X(I) - 1 + ENDIF + ENDDO + + WRITE(99, 1003) IT, LATF, COST_FUNC_SAV(IT), + & COST_FUNC_SAV(IT)/COST_FUNC_SAV(1), PG, NG, PS, NS + + ENDIF + + 1001 format ('GEOS-CHEM ADJOINT CONVERGNECE CONDITION',/,/, + + 'IT = iteration number',/, + + 'A = accepted iteration',/, + + 'F = cost fun',/, + + 'FdF0 = cost fun reduction',/, + + 'PG = total positive gradient',/, + + 'NG = total negative gradient',/, + + 'PS = total underestimated scaling factor',/, + + 'NS = total overestimated scaling factor',/) + + 1002 format (/,3x,'IT',2x,'A',7x,'F',10x,'FdF0',9x,'PG',12x,'NG', + + 10x,'PS',10x,'NS') + 1003 format (3x,i2,2x,L1,2x,E12.6,2x,F8.6,2x,E11.5,2x, + + E12.5,2x,F9.2,2x,F10.2) + +! Strat prod and loss (hml) + 1004 format (/,3x,'IT',2x,'A',7x,'F',10x,'FdF0',9x,'PG_P',12x,'PG_L', + + 12x,'NG_P',10x,'NG_L',10x,'PS_P',10x,'PS_L',10x,'NS_P', + + 10x,'NS_L') + 1005 format (3x,i2,2x,L1,2x,E12.6,2x,F8.6,2x,E11.5,2x,E11.5,2x, + + E12.5,2x,E12.5,2x,F9.2,2x,F9.2,2x,F10.2,2x,F10.2) + + ! Return to calling program + END SUBROUTINE ITER_CONDITION + +!-------------------------------------------------------------------------------- + + SUBROUTINE MAYBE_DO_GEOS_CHEM_ADJ( ) +! +!****************************************************************************** +! Subroutine MAYBE_DO_GEOS_CHEM_ADJ is called for FDTESTS and determines +! whether or not the adjoint model needs to be run. (dkh, 02/21/11) +! +! Module variables as Input: +! ============================================================================ +! (1 ) LFD_GLOB (LOGICAL) : Switch to perform global finite diff test +! (2 ) LFD_SPOT (LOGICAL) : Switch to perform spot finite diff test +! (3 ) N_CALC_STOP (INTEGER) : Current iteration number +! +! NOTES: +! +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : N_CALC_STOP + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_ADJ_MOD, ONLY : LFD_GLOB + USE LOGICAL_ADJ_MOD, ONLY : LFD_SPOT + USE GEOS_CHEM_ADJ_MOD, ONLY : DO_GEOS_CHEM_ADJ + + !================================================================= + ! MAYBE_DO_GEOS_CHEM_ADJ begins here! + !================================================================= + + ! For global finite difference test we compare the average of + ! two finite difference sensitivities with an adjoint sensitivity + ! around the base case. + IF ( LFD_GLOB ) THEN + + ! Only calculate the adjoint during the first iteration + IF ( N_CALC_STOP == 1 ) THEN + + CALL DO_GEOS_CHEM_ADJ + + ! Don't bother with more than 3 iterations + ELSEIF ( N_CALC_STOP > 3 ) THEN + + CALL ERROR_STOP('To many iterations for FD_GLOB', + & 'inverse_mod.f' ) + ENDIF + + + ! For SPOT finite difference test we compare the average of + ! two adjoint sensitivities with a finite difference sensitivity + ! around the base case + 1/2 FD_DIFF + ELSEIF ( LFD_SPOT ) THEN + + ! calculate the adjoint during the first and second iteration + IF ( N_CALC_STOP == 1 .or. N_CALC_STOP == 2 ) THEN + + CALL DO_GEOS_CHEM_ADJ + + ! Don't bother with more than 2 iteratoins + ELSEIF ( N_CALC_STOP > 2 ) THEN + + CALL ERROR_STOP('To many iterations for FD_SPOT', + & 'inverse_mod.f' ) + ENDIF + + ENDIF + + ! Return to calling program + END SUBROUTINE MAYBE_DO_GEOS_CHEM_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_SAT_DIAGS( ) +! +!****************************************************************************** +! Subroutine DO_SAT_DIAGS writes satellite diagnostics +! (mkeller, 06/15) +! +! NOTES: +! +!****************************************************************************** +! +# include "define_adj.h" ! Obs operator flags + + ! References to F90 modules +#if defined(TES_O3_OBS) || defined(MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS ) + USE HDF5 +#endif + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, N_CALC_STOP + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE LOGICAL_ADJ_MOD, ONLY : LSAT_HDF_L2, LSAT_HDF_L3, LDCOSAT + +#if defined(OMI_NO2_OBS) + !USE OMI_NO2_OBS_MOD, ONLY : MAKE_OMI_BIAS_FILE_HDF5 +#endif + +#if defined(TES_O3_OBS) + USE TES_O3_MOD, ONLY : MAKE_TES_BIAS_FILE_HDF5 +#endif + +#if defined(MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS ) + USE MOPITT_OBS_MOD, ONLY : MAKE_MOPITT_BIAS_FILE_HDF5 +#endif + + ! Local variables + CHARACTER(LEN=255) :: FILENAME_HDF5 + INTEGER :: FILE_ID + INTEGER :: HDF_ERR + + !================================================================= + ! DO_SAT_DIAGS begins here! + !================================================================= + +#if defined(TES_O3_OBS) || defined(MOPITT_V5_CO_OBS) || defined (MOPITT_V6_CO_OBS ) + ! HDF based diagnostics (mkeller, 06/15) + IF ( LSAT_HDF_L2 .or. LSAT_HDF_L3 ) THEN + + FILENAME_HDF5 = TRIM("satellite_diagnostics.NN.h5") + + CALL EXPAND_NAME( FILENAME_HDF5, N_CALC ) + + FILENAME_HDF5 = TRIM( DIAGADJ_DIR ) // + & TRIM( FILENAME_HDF5 ) + + ! create satellite diagnostic file + CALL H5FCREATE_F( FILENAME_HDF5, H5F_ACC_TRUNC_F, FILE_ID, + & HDF_ERR ) + + +#if defined( OMI_NO2_OBS ) + !CALL MAKE_OMI_BIAS_FILE_HDF5( FILE_ID ) +#endif + +#if defined( TES_O3_OBS ) + CALL MAKE_TES_BIAS_FILE_HDF5( FILE_ID ) +#endif + +#if defined( MOPITT_V5_CO_OBS ) || defined (MOPITT_V6_CO_OBS ) + CALL MAKE_MOPITT_BIAS_FILE_HDF5( FILE_ID ) +#endif + + CALL H5FCLOSE_F( FILE_ID, HDF_ERR ) + + ENDIF +#endif + + !============================================================== + ! Diagnostics (original from mak, non HDF output) + !============================================================== + + ! store satellite diagnostics + ! for now CO, but subroutines all general, just need linking + ! (mak 6/19/09) + IF ( LDCOSAT ) THEN + !Store FORCING, MOP_MOD_DIFF and MODEL_BIAS + !CALL MAKE_FORCING_FILE + !CALL MAKE_MOPMOD_FILE + ! store model, mopitt and model bias to files + ! model + CALL MAKE_SAT_DIAG_FILE( 1 ) + + ! obs and DOFs + IF( N_CALC_STOP == 1) THEN + CALL MAKE_SAT_DIAG_FILE( 2 ) + ENDIF + CALL MAKE_SAT_DIAG_FILE( 6 ) + + CALL MAKE_SAT_DIAG_FILE( 7 ) + + ! model bias (wrt satellite data) + CALL MAKE_SAT_DIAG_FILE( 3 ) + + ! store COST_ARRAY, OBS_COUNT, OBS_HOUR* + CALL MAKE_SAT_DIAG_FILE( 5 ) + + ENDIF + + END SUBROUTINE DO_SAT_DIAGS + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_INVERSE +! +!****************************************************************************** +! Subroutine INIT_INVERSE initializes and zeros all allocatable arrays +! declared in "inverse_mod.f" (dkh, 1/26/05) +! +! NOTES: +! (1 ) Now also allocate EMS_ICS_orig (dkh, 03/29/05) +! (2 ) Now check for incompatible preproc. definitions and ACTIVE_VARS. (dkh, 10/17/06) +! (3 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : NOPT + USE ADJ_ARRAYS_MOD, ONLY : RATE_SF + USE ADJ_ARRAYS_MOD, ONLY : NSTPL, NRRATES + + USE ADJ_ARRAYS_MOD, ONLY : MMSCL + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT, LADJ_RRATE, LADJ + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: IS_INIT = .FALSE. + INTEGER :: AS, I + + !================================================================= + ! INIT_INVERSE begins here! + !================================================================= + + ! Return if we have already initialized + IF ( IS_INIT ) RETURN + + !fp + IF ( LADJ ) THEN + + !Allocate arrays + ALLOCATE( GRADNT( NOPT ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GRADNT' ) + + ENDIF + + ALLOCATE( X( NOPT ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'X' ) + + IF ( LADJ_STRAT ) THEN + ALLOCATE( GRADNT_P( IIPAR*JJPAR*MMSCL*NSTPL ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GRADNT_P' ) + + ALLOCATE( GRADNT_L( IIPAR*JJPAR*MMSCL*NSTPL ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GRADNT_L' ) + + ALLOCATE( XP( IIPAR*JJPAR*MMSCL*NSTPL ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'XP' ) + + ALLOCATE( XL( IIPAR*JJPAR*MMSCL*NSTPL ), STAT = AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'XL' ) + + ENDIF + + END SUBROUTINE INIT_INVERSE + +!------------------------------------------------------------------------------ + + + ! Return to calling program + SUBROUTINE CLEANUP_INVERSE +! +!****************************************************************************** +! Subroutine CLEANUP_INVERE deallocates all previously allocated arrays +! for inverse_mod -- call at the end of the program (dkh, 1/26/05) +! +! NOTES: +! (1 ) Now also deallocate EMS_ICS_orig (dkh, 03/29/05) +! (2 ) No longer make EMS_ICS an array in this module (dkh, 06/08/09) +! (3 ) Now support strat fluxes LADJ_STRAT (hml, dkh, 02/20/12, adj32_025) +!****************************************************************************** +! + !================================================================= + ! CLEANUP_INVERSE begins here! + !================================================================= + IF ( ALLOCATED( GRADNT ) ) DEALLOCATE( GRADNT ) + IF ( ALLOCATED( X ) ) DEALLOCATE( X ) + + ! Return to calling program + END SUBROUTINE CLEANUP_INVERSE + +!------------------------------------------------------------------------------ + + END MODULE INVERSE_MOD + + diff --git a/code/adjoint/linoz_adj_mod.f b/code/adjoint/linoz_adj_mod.f new file mode 100644 index 0000000..927eae7 --- /dev/null +++ b/code/adjoint/linoz_adj_mod.f @@ -0,0 +1,352 @@ +!$Id: linoz_adj_mod.f,v 1.6 2012/05/08 02:18:25 nicolas Exp $ + MODULE LINOZ_ADJ_MOD + +C Revision 2.10 2000/03/23 20:41:45 pjc +C Initial version adapted heavily from McLinden's original file. + +c +c----------------------------------------------------------------------- + + + CONTAINS + + !============================================================ + + subroutine do_linoz_adj + + USE TIME_MOD + +# include "CMN_SIZE" + + ! Local variables + ! Chem time step in seconds for linoz (dbj,bdf 6/24/03) + REAL*8 :: NSCHEM + + NSCHEM = GET_TS_CHEM()*60D0 ! Linoz needs time step in seconds + CALL LINOZ_CHEM3_ADJ(NSCHEM) + + end subroutine do_linoz_adj + +!------------------------------------------------------------------- + SUBROUTINE LINOZ_CHEM3_ADJ( DTCHEM ) + +! +!*************************************************************** +! Subroutine LINOZ_CHEM3_ADJ is the adjont of LINOZ_CHEM3, +! manually derived to account for strat flux adjoints. +! +! This replaces an older version of this routine that was +! based on TAMC code. ( hml, dkh, 02/20/12, adj32_025) +! +!*************************************************************** + USE TIME_MOD, ONLY : GET_NHMS + USE TIME_MOD, ONLY : GET_NYMD + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : T + USE ERROR_MOD, ONLY : ERROR_STOP + USE TRACER_MOD, ONLY : TCVV + USE TRACER_MOD, ONLY : STT_TMP + USE TRACER_MOD, ONLY : ITS_A_TAGOX_SIM + USE TRACERID_MOD, ONLY : IDTOX + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TROPOPAUSE_MOD, ONLY : GET_TPAUSE_LEVEL + USE TROPOPAUSE_MOD, ONLY : GET_MAX_TPAUSE_LEVEL + USE PRESSURE_MOD, ONLY : GET_PEDGE + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE CHECKPOINT_MOD, ONLY : READ_UPBDFLX_CHKFILE + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ, LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ID_LOSS, NSTPL + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + + + IMPLICIT NONE + +# include "CMN_SIZE" +# include "CMN" +!# include "../new/linoz.com" + + REAL*8, INTENT(IN) :: DTCHEM ! Time step [seconds] + + +C============================================== +C define arguments +C============================================== + + ! hml: add for strat prod & loss sense + INTEGER :: IMX, JM, LM + INTEGER :: I, J, L + INTEGER :: NS, NSL + INTEGER :: LBOT, L_OVERWRLD + INTEGER :: NTRACER, NUM_TRACER, LPOS, ITRC + INTEGER :: NHMS, NYMD + + REAL*8 :: CLIMO3, CLIMPML, PMLTOT + REAL*8 :: DCO3, DERO3, DERTMP + REAL*8 :: DERCO3, DMASS, DTMP + REAL*8 :: SSO3 + + REAL*8 :: TAU + REAL*8 :: P, k, M0 + REAL*8 :: P_ADJ, k_ADJ, M0_ADJ + REAL*8 :: LOSS_ADJ, PROD_ADJ + REAL*8 :: PROD, LOSS + REAL*8 :: PROD_0, LOSS_0 + + ! Arrays + REAL*8 :: DCOLO3(IIPAR,JJPAR,LLPAR) + REAL*8 :: COLO3(IIPAR,JJPAR,LLPAR) + REAL*8 :: OUT_DATA(IIPAR,JJPAR,LLPAR) + REAL*8 :: TLSTT(JJPAR,LLPAR,7) + + REAL*8 :: STT_ADJ_IN(IIPAR,JJPAR,LLPAR) + + ! Assign values for local IMX and JM (dbj 6/24/03) + IMX = IIPAR + JM = JJPAR + LM = LLPAR ! dbj + + L_OVERWRLD = GET_MAX_TPAUSE_LEVEL() + + NTRACER = IDTOX + + ! READING STT and TLSTT IN REVERSE MODE + NHMS = GET_NHMS() + NYMD = GET_NYMD() + CALL READ_UPBDFLX_CHKFILE( NYMD, NHMS ) + + DO L = 1,LLPAR + DO J = 1,JJPAR + DO I = 1,7 + TLSTT(J,L,I) = STT_TMP(I,J,L,1) + ENDDO + ENDDO + ENDDO + + ! don't overwrite (hml, 10/15/11) + !STT(:,:,:,NTRACER) = STT_TMP(:,:,:,2) + + WRITE(6,*) '-----------------------------------------------------' + write(6,*) ' doing adjoint linoz stratospheric chemistry ' + WRITE(6,*) '-----------------------------------------------------' + + STT_ADJ_IN(:,:,:) = STT_ADJ(:,:,:,IDTOX) + + !OUT_DATA = 0d0 + + ! Initialize arrays (hml, 10/17/11) + LOSS = 0d0 + PROD = 0d0 + + ! NEW: + ! Now use this format at all times (dkh, 04/20/12) + !! For strat P & L optimization (hml, 10/03/11) + DO J = 1, JM + DO I = 1, IMX + LBOT = GET_TPAUSE_LEVEL(I,J)+1 + LPOS = 1 + + ! To set LFD properly (hml, 10/12/11) + IF ( I == IFD.and.J == JFD) THEN + print *, 'LBOT = ', LBOT + ENDIF + + DO WHILE (GET_PEDGE(I,J,LPOS+1) .GE. 0.3D0) + LPOS = LPOS +1 + ENDDO + LPOS = LPOS-1 + + !--------------------------------------------------------- + ! dbj: for now, set tagged stratospheric tracer to total + ! O3 in the overworld to avoid issues with spin ups + !--------------------------------------------------------- + IF ( ITS_A_TAGOX_SIM() ) THEN + STT_TMP(I,J,(L_OVERWRLD+1):LLPAR,NTRACER) = + & STT_TMP(I,J,(L_OVERWRLD+1):LLPAR,1) + ENDIF + +! With this format we need to start at LLPAR so that COLO3 and DCOLO3 are correct. +!!! ! If we just loop from LPOS, rather than LLPAR, then we only deal with +!!! ! levels for which PEDGE > 0.3d0 + DO L = LM,LBOT,-1 + + IF (STT_TMP(I,J,L,2) .LE. 0.D0) CYCLE + + !--------------------------------------- + ! GET RATES - assigning PROD and LOSS + !--------------------------------------- + + !------------------------------------------------------ + ! Recalculate forward model values to get rates + !------------------------------------------------------ + + ! bdf stt is in v/v, make conversion to DU + IF ( L .EQ. LM) THEN !top model layer + ! Use checkpointed value + !DCOLO3(I,J,L) = (STT(I,J,L,NTRACER)*AD(I,J,L)/ + DCOLO3(I,J,L) = (STT_TMP(I,J,L,2)*AD(I,J,L)/ + & TCVV(NTRACER))/ GET_AREA_CM2(J) * + & 6.022d23/(28.97/TCVV(NTRACER)*1d-3)/ 2.687d16 + COLO3(I,J,L) = DCOLO3(I,J,L)*0.5 + ELSE + ! Use checkpointed value + !DCOLO3(I,J,L) = (STT(I,J,L,NTRACER)*AD(I,J,L)/ + DCOLO3(I,J,L) = (STT_TMP(I,J,L,2)*AD(I,J,L)/ + & TCVV(NTRACER))/ GET_AREA_CM2(J) * + & 6.022d23/(28.97/TCVV(NTRACER)*1d-3)/ 2.687d16 + COLO3(I,J,L) = COLO3(I,J,L+1) + + & (DCOLO3(I,J,L)+DCOLO3(I,J,L+1))*0.5 + ENDIF + + ! ++++++ climatological P-L: ++++++ + CLIMPML = TLSTT(J,L,4) ! Climatological P-L = (P-L)^o + + ! ++++++ local ozone feedback: ++++++ + DERO3 = TLSTT(J,L,5) ! Derivative w.r.t. O3. dero3=-1/(time constant) + IF ( DERO3 .EQ. 0 ) CYCLE ! Skip Linoz if lifetime is infinite. + CLIMO3 = TLSTT(J,L,1) ! Climatological O3 = f^o + DERCO3 = TLSTT(J,L,7) ! Derivative w.r.t. Column O3 + DCO3 = (COLO3(I,J,L) - TLSTT(J,L,3)) ! deviation from o3 climatology. + + ! ++++++ temperature feedback: ++++++ + DERTMP = TLSTT(J,L,6) ! Derivative w.r.t. Temperature + DTMP = (T(I,J,L) - TLSTT(J,L,2)) ! Deviation in Temperature from climatology. + + ! ++++++ calculate steady-state ozone: ++++++ + SSO3 = CLIMO3 + & - (CLIMPML + DTMP*DERTMP + DCO3*DERCO3) /DERO3 + + ! debug: recalculated DMASS just to check with fwd model + ! Use checkpointed value + !DMASS = (SSO3 - STT(I,J,L,NTRACER)) + DMASS = (SSO3 - STT_TMP(I,J,L,2)) + & * (1.0 - exp(DERO3*DTCHEM)) + + ! note: there is a factor of TC / AD * AD / TC that cancels + ! out in definition of PROD_0 + PROD_0 = - (SSO3 * DERO3) + LOSS_0 = - DERO3 + + !--------------------------------------- + ! END of GET RATES + !--------------------------------------- + + IF (GET_PEDGE(I,J,L) .LE. 0.3D0) THEN + + ! fwd: + !STT(I,J,L,NTRACER) = ( GET_PCENTER(I,J,L) + ! / GET_PCENTER(I,J,LPOS-1) ) + ! * STT(I,J,LPOS-1,NTRACER) + ! adj: + STT_ADJ(I,J,LPOS-1,NTRACER) + & = STT_ADJ(I,J,LPOS-1,NTRACER) + & + ( GET_PCENTER(I,J,L) / GET_PCENTER(I,J,LPOS-1) ) + & * STT_ADJ(I,J,L,NTRACER) + + + !otherwise just take the adjoint of the low-pressure decay + ! and the prod / loss scaling factors have no effect + ELSE + + !! Scaled prod & loss rate + IF ( LADJ_STRAT ) THEN + DO NS = 1, NSTPL + NSL = ID_LOSS(NS) ! same for ID_PROD(NS) + + IF ( NSL .EQ. IDTOx ) THEN + + !! Scaled prod & loss rate + PROD = PROD_0 * PROD_SF(I,J,1,NS) + LOSS = LOSS_0 * LOSS_SF(I,J,1,NS) + + ENDIF + + ENDDO + ELSE + + PROD = PROD_0 + LOSS = LOSS_0 + + ENDIF + + k = LOSS ! loss freq [s-1] + P = PROD * AD(I,J,L) / TCVV(NTRACER) ! production term [kg s-1] + + ! Use checkpointed value + ! Put ozone back to kg (hml, 11/06/11) + M0 = STT_TMP(I,J,L,2) + & * AD(I,J,L) / TCVV(NTRACER)! initial mass [kg] + + ! No prod or loss at all + if ( k .eq. 0d0 .and. P .eq. 0d0 ) cycle + + ! fwd code: + !STT(I,J,L,N) = M0 * exp(-k*t) + (P/k)*(1d0-exp(-k*t)) + ! adj code: note use the input value of STT_ADJ and + ! convert units of STT_ADJ to pre LINOZ_ADJ units + M0_ADJ = STT_ADJ_IN(I,J,L) * TCVV(NTRACER) / AD(I,J,L) + & * exp(-k*DTCHEM) + P_ADJ = STT_ADJ_IN(I,J,L) * TCVV(NTRACER) / AD(I,J,L) + & * (1d0 - exp(-k*DTCHEM))/k + k_ADJ = STT_ADJ_IN(I,J,L) * TCVV(NTRACER) / AD(I,J,L) + & * ( -p/(k**2) + p/(k**2)*exp(-k*DTCHEM) + & + (p*DTCHEM/k)*exp(-k*DTCHEM) + & - DTCHEM * exp(-k*DTCHEM) * M0 ) + + + ! fwd code: + !k = LOSS(I,J,L,N) ! loss freq [s-1] + !P = PROD(I,J,L,N) * AD(I,J,L) / TCVV(N) ! production term [kg s-1] + !M0 = STT(I,J,L,N) ! initial mass [kg] + ! adj code: + LOSS_ADJ = K_ADJ + PROD_ADJ = P_ADJ * AD(I,J,L) / TCVV(NTRACER) + + !!! Now calculate the update to STT_ADJ here. + STT_ADJ (I,J,L,NTRACER) = M0_ADJ / TCVV(NTRACER) + & * AD(I,J,L) + + !------------------------------------------------------ + ! adjoint with respect to PROD and LOSS scaling factors + !------------------------------------------------------ + IF ( LADJ_STRAT ) THEN + DO NS = 1, NSTPL + NSL = ID_LOSS(NS) ! same for ID_PROD(NS) + + IF ( NSL .EQ. IDTOx ) THEN + + ! fwd code: + !PROD(I,J,L,N) = PROD_0(I,J,L,N) * PROD_SF(I,J,1,N) + !LOSS(I,J,L,N) = LOSS_0(I,J,L,N) * LOSS_SF(I,J,1,N) + ! adj code: + !! Scaled prod & loss rate + PROD_SF_ADJ(I,J,1,NS) = PROD_0 * PROD_ADJ + & + PROD_SF_ADJ(I,J,1,NS) + LOSS_SF_ADJ(I,J,1,NS) = LOSS_0 * LOSS_ADJ + & + LOSS_SF_ADJ(I,J,1,NS) + + ENDIF + + ENDDO + ENDIF + + ENDIF ! PEDGE + + ENDDO ! loop over L + + ENDDO ! loop over I + ENDDO ! loop pver J + + + !write our calculated column o3 maximum + !write(6,*) 'max of columns= ',maxval(out_data) + +!!$OMP END PARALLEL DO + + END SUBROUTINE LINOZ_CHEM3_ADJ +!------------------------------------------------------------------------------ + + ! End of module + END MODULE LINOZ_ADJ_MOD diff --git a/code/adjoint/logical_adj_mod.f b/code/adjoint/logical_adj_mod.f new file mode 100644 index 0000000..5df1991 --- /dev/null +++ b/code/adjoint/logical_adj_mod.f @@ -0,0 +1,162 @@ +!$Id: logical_adj_mod.f,v 1.6 2012/08/10 22:08:22 nicolas Exp $ + + MODULE LOGICAL_ADJ_MOD +! +!****************************************************************************** +! Module LOGICAL_ADJ_MOD contains all of the logical switches used by +! adjoint GEOS-CHEM. +! (adj_group, 6/07/09) +! +! Module Variables: +! ============================================================================ +! (1 ) LADJ (LOGICAL) : ON/OFF switch for adjoint run +! (2 ) LADJ_TRAN (LOGICAL) : ON/OFF switch for adjoint transport +! (3 ) LADJ_CHEM (LOGICAL) : ON/OFF switch for adj chemistry +! (4 ) LAERO_THERM(LOGICAL) : ON/OFF switch for aerosol thermo +! (5 ) LFD_SPOT (LOGICAL) : ON/OFF switch for FD in 1 box +! (6 ) LFD_GLOB (LOGICAL) : ON/OFF switch for FD in 3d +! (7 ) LSENS (LOGICAL) : ON/OFF switch for sensitivity run +! (8 ) L4DVAR (LOGICAL) : ON/OFF switch for 4dvar run +! (9 ) L3DVAR (LOGICAL) : ON/OFF switch for 3dvar run +! (10) LAPSRC (LOGICAL) : ON/OFF switch for adding 2nd part of J +! (11) LBKCOV (LOGICAL) : ON/OFF switch for computing cov. matrix +! (12) LINVH (LOGICAL) : ON/OFF switch for computing inv. Hessian +! (13) LLINOZ (LOGICAL) : ON/OFF switch for LINOZ (fwd AND adj) +! (14) LFDTEST (LOGICAL) : ON/OFF switch for FD test SPOT or GLOBAL +! (15) LADJ_EMS (LOGICAL) : ON/OFF switch for emission optimization +! (16) LICS (LOGICAL) : ON/OFF switch for initial condi. optimization +! (17) LRXNR (LOGICAL) : ON/OFF switch for RXN rates as control vars +! (18) LADJDIAG (LOGICAL) : ON/OFF switch for saving adj diagnostics +! (19) LJSAVE (LOGICAL) : ON/OFF switch for saving .save and .save2 files +! (20) LADJ_TRAJ (LOGICAL) : ON/OFF switch for saving trajectory files +! (21) LDCOSAT (LOGICAL) : ON/OFF switch for saving CO satellite diagnostics +! (22) LHMOD (LOGICAL) : ON/OFF switch for saving H(model) +! (23) LHOBS (LOGICAL) : ON/OFF switch for saving h(obs) +! (24) LHMODIFF (LOGICAL) : ON/OFF switch for saving H(model)-h(obs) +! (25) LADJ_FORCE (LOGICAL) : ON/OFF switch for saving adjoint forcing +! (26) LMODBIAS (LOGICAL) : ON/OFF switch for saving model bias +! (27) LOBS_COUNT (LOGICAL) : ON/OFF switch for saving obs count/gridbox +! (28) LDOFS (LOGICAL) : ON/OFF switch for saving gridded DOFs +! (29) LPRINTFD (LOGICAL) : ON/OFF switch for printing adj debug +! (30) LDEL_CHKPT (LOGICAL) : ON/OFF switch for deleting checkpoint files +! (31) LITR (LOGICAL) : ON/OFF switch for saving iteration diagnostics +! (32) LDEVOC (LOGICAL) : ON/OFF switch for including CO VOCs +! (33) LATF (LOGICAL) : ON/OFF switch for saving iteration diagnostics +! (34) LMAX_OBS (LOGICAL) : ON/OFF switch for capping number of obs +! (35) LTRAJ_SCALE(LOGICAL) : ON/OFF switch for scaling STT_ADJ in *.adj.* files +! (36) LKGBOX (LOGICAL) : ON/OFF switch for cost function in kg/box +! (37) LUGM3 (LOGICAL) : ON/OFF switch for cost function in kg/box +! (38) LSTT_PPB (LOGICAL) : ON/OFF switch for cost function in ppb +! (39) LSTT_PPB_TROP_PPM (L): ON/OFF switch for cost function in ppm +! (40) LCSPEC_PPB (LOGICAL) : ON/OFF switch for cost function in cspec ppb +! (41) LCSPEC_OBS (LOGICAL) : ON/OFF switch for observing any cspec species +! (42) LTES_BLVMR (LOGICAL) : ON/OFF switch for looking at TES BLVMR +! (43) LFILL_ADJ (LOGICAL) : ON/OFF switch for filling during adj advenction +! (44) LEMS_ABS (LOGICAL) : ON/OFF switch for sense w.r.t abosulte emissions +! (45) LTES_PSO (LOGICAL) : ON/OFF switch for CH4 +! (46) LPOP_UGM3 (LOGICAL) : ON/OFF switch for sense w.r.t pop weighted conc +! (47) LAD_STRAT (LOGICAL) : ON/OFF switch for strat chem adjoint +! (48) LADJ_FDEP (LOGICAL) : ON/OFF switch for deposition-based cost function +! (49) LADJ_DDEP_TRACER (L) : ON/OFF switch for tracer dry-deposition cost function +! (50) LADJ_DDEP_CSPEC (L) : ON/OFF switch for species dry-deposition cost function +! (51) LADJ_WDEP_LS (L) : ON/OFF switch for wet LS deposit cost function +! (52) LADJ_WDEP_CV (L) : ON/OFF switch for wet CV deposit cost function +! (53) LKGNHAYR (LOGICAL) : ON/OFF switch for dep cost function unit +! (54) LFORCE_MASK(LOGICAL) : ON/OFF switch for regional forcing mask +! (55) LADJ_CL : ON/OFF switch for critical load based cost function +! (55) LADJ_CL_NDEP : ON/OFF switch for critical load based on N +! (55) LADJ_CL_ACID : ON/OFF switch for critical load based on acidification +! (56) LSAT_HDF_L2 : ON/OFF switch for Level 2 HDF Satellite Diagnostics +! (57) LSAT_HDF_L3 : ON/OFF switch for Level 3 HDF Satellite Diagnostics +! +! NOTES: +! (1 ) Added LITR, LDEVOC and LATF (zhe, dkh, 02/04/11) +! (2 ) Added lots of new flags: (dkh, 02/09/11) +! LMAX_OBS, LTRAJ_SCALE, LKGBOX, LUGM3, LSTT_PPB, LSTT_TROP_PPM, +! LCSPEC_PPB, LCSPEC_OBS, LTES_BLVMR, LFILL_ADJ, LEMS_ABS +! (3 ) Added LTES_PSO (kjw, dkh, 02/12/12, adj32_023) +! (4 ) Added LPOP_UGM3 (sev, dkh, 02/13/12, adj32_024) +! (5 ) Added LADJ_STRAT (hml, dkh, 02/14/12, adj32_025) +! (6 ) Added LINVH_BFGS (nab, 03/25/12 ) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + LOGICAL :: LADJ + LOGICAL :: LADJ_TRAN + LOGICAL :: LADJ_CHEM + LOGICAL :: LAERO_THERM + LOGICAL :: LFD_SPOT + LOGICAL :: LFD_GLOB + LOGICAL :: LSENS + LOGICAL :: L4DVAR + LOGICAL :: L3DVAR + LOGICAL :: LAPSRC + LOGICAL :: LBKCOV + LOGICAL :: LINVH + LOGICAL :: LINVH_BFGS + LOGICAL :: LISO + LOGICAL :: LLINOZ + LOGICAL :: LFDTEST + LOGICAL :: LADJ_EMS + LOGICAL :: LICS + LOGICAL :: LRXNR + LOGICAL :: LADJDIAG + LOGICAL :: LJSAVE + LOGICAL :: LADJ_TRAJ + LOGICAL :: LDCOSAT + LOGICAL :: LHMOD + LOGICAL :: LHOBS + LOGICAL :: LHMODIFF + LOGICAL :: LADJ_FORCE + LOGICAL :: LMODBIAS + LOGICAL :: LOBS_COUNT + LOGICAL :: LDOFS + LOGICAL :: LPRINTFD + LOGICAL :: LDEL_CHKPT + LOGICAL :: LITR + LOGICAL :: LDEVOC + LOGICAL :: LATF + LOGICAL :: LMAX_OBS + LOGICAL :: LKGBOX + LOGICAL :: LUGM3 + LOGICAL :: LSTT_PPB + LOGICAL :: LSTT_TROP_PPM + LOGICAL :: LCSPEC_PPB + LOGICAL :: LTRAJ_SCALE + LOGICAL :: LCSPEC_OBS + LOGICAL :: LTES_BLVMR + LOGICAL :: LFILL_ADJ + LOGICAL :: LEMS_ABS + LOGICAL :: LTES_PSO + LOGICAL :: LPOP_UGM3 + LOGICAL :: LADJ_STRAT + LOGICAL :: LADJ_RRATE + LOGICAL :: LFLX_UGM2 + LOGICAL :: FI_STRID + LOGICAL :: FI_RXNID + LOGICAL :: LADJ_FDEP + LOGICAL :: LADJ_DDEP_TRACER + LOGICAL :: LADJ_DDEP_CSPEC + LOGICAL :: LADJ_WDEP_LS + LOGICAL :: LADJ_WDEP_CV + LOGICAL :: LKGNHAYR + LOGICAL :: LKGS + LOGICAL :: LEQHAYR + LOGICAL :: LMOLECCM2S + LOGICAL :: LFORCE_MASK + LOGICAL :: LFORCE_MASK_BPCH + LOGICAL :: LFORCE_MASK_NC + LOGICAL :: LADJ_CL + LOGICAL :: LADJ_CL_NDEP + LOGICAL :: LADJ_CL_ACID + ! HDF SAT DAIG + LOGICAL :: LSAT_HDF_L2 + LOGICAL :: LSAT_HDF_L3 + + ! End of module + END MODULE LOGICAL_ADJ_MOD diff --git a/code/adjoint/lump_adj.f b/code/adjoint/lump_adj.f new file mode 100644 index 0000000..92d2644 --- /dev/null +++ b/code/adjoint/lump_adj.f @@ -0,0 +1,109 @@ +!$Id: lump_adj.f,v 1.1 2009/08/17 03:59:52 daven Exp $ + + SUBROUTINE LUMP_ADJ( NTRACER, XNUMOL, STT_ADJ ) +! +!****************************************************************************** +! Subroutine LUMP_ADJ takes adjoints of tracerst (STT_ADJ) and partitions them +! into adjoints of individual chemical species (CSPEC_ADJ). Based on +! ADJ_LUMP from the GCv6 adjoint (dkh, 07/31/09). +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTRACER (INTEGER) : Number of tracers +! (2 ) XNUMOL (REAL*8 ) : Array of molecules tracer / kg tracer +! (3 ) STT_ADJ (REAL*8 ) : Adjoint Tracer concentrations +! +! Arguments as Output: +! ============================================================================ +! (1 ) STT_ADJ (REAL*8 ) : Tracer concentrations [kg/box] +! +! Module variables included via USE as Input / Output: +! ============================================================================ +! (1 ) CSPEC_ADJ (REAL*8) : Adjoint species concentrations +! +! NOTES: +! (1 ) Disable OMP parallel loops, which were leading to small erros in +! the 7th digit. (dkh, 10/08/06) +! (2 ) Update for GCv8 (dkh, 07/31/09) +!****************************************************************************** +! + ! References to F90 modules + USE COMODE_MOD, ONLY : CSPEC, JLOP, VOLUME, CSPEC_ADJ + USE TRACERID_MOD, ONLY : IDTRMB, NMEMBER, CTRMB + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! SMVGEAR II arrays + + ! Arguments + INTEGER, INTENT(IN) :: NTRACER + REAL*8, INTENT(IN) :: XNUMOL(NNPAR) + REAL*8, INTENT(INOUT) :: STT_ADJ(IIPAR,JJPAR,LLPAR,NTRACER) + ! make this an allocatable array in comode_mod + !REAL*8, INTENT(INOUT) :: CSPEC_ADJ(ITLOOP,IGAS) ? + + ! Local variables + INTEGER :: I, J, L, N, JLOOP, KK, JJ, NN + REAL*8 :: ADCONCTMP + + !================================================================= + ! LUMP_ADJ begins here! + !================================================================= + ! note: CSPEC_ADJ is initialized to zero when it is allocated. + ! After the first call to PARTITION_ADJ it will no longer be zero + ! before this routine. + +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L, N, JLOOP, ADCONCTMP, KK, JJ, NN ) +!!$OMP+SCHEDULE( DYNAMIC ) + DO N = 1, NTRACER + + ! Get index of adj species array from index of fwd species array. + !NN = ADJ2STT(N) + NN = N + + ! Skip if not a valid tracer. + ! IDTRMB for the fwd tracer (is this BCPI, etc?), NN for the adjoint tracer. + IF ( IDTRMB(N,1) == 0 .OR. NN == 0 ) CYCLE + + DO L = 1, NPVERT + DO J = 1, NLAT + DO I = 1, NLONG + + ! Initialize + ADCONCTMP = 0.D0 + + ! Get vector index from 3-D array indicies + JLOOP = JLOP(I,J,L) + IF ( JLOOP == 0 ) CYCLE + + ! Adjoint of unit conversion ( molec/cm3/box to kg/box ) + STT_ADJ(I,J,L,NN) = STT_ADJ(I,J,L,NN) * VOLUME(JLOOP) + & / XNUMOL(N) + + ADCONCTMP = ADCONCTMP + STT_ADJ(I,J,L,NN) + + ! Reset STT_ADJ to zero. This way it won't intefere in ADJ_PARTITION + STT_ADJ(I,J,L,NN) = 0.d0 + + ! Lump adjoint values together according to families. + DO KK = 1, NMEMBER(N) + JJ = IDTRMB(N,KK) + CSPEC_ADJ(JLOOP,JJ) = CSPEC_ADJ(JLOOP,JJ) + & + ADCONCTMP * ( 1 + CTRMB(N,KK) ) + + ENDDO + + ADCONCTMP = 0.D0 + + ENDDO + ENDDO + ENDDO + ENDDO +!!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE LUMP_ADJ + diff --git a/code/adjoint/paranox_adj_mod.f b/code/adjoint/paranox_adj_mod.f new file mode 100644 index 0000000..ef9967b --- /dev/null +++ b/code/adjoint/paranox_adj_mod.f @@ -0,0 +1,676 @@ + + MODULE PARANOX_ADJ_MOD + + IMPLICIT NONE + PRIVATE +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC interpolate_lut2_adj +! +! !MODULE VARIABLES +! + ! fracnox = look up table for fraction of NOx remaining + ! for ship emissions (gvinken, 6/6/10) + ! intope = look up table for integrated Ozone Production + ! Efficiency for ship emiss (gvinken, 6/6/10) + REAL*4 :: fracnox(4, 4, 4, 12, 12, 4, 5) + REAL*4 :: intope(4, 4, 4, 12, 12, 4, 5) + + CONTAINS + +! Differentiation of interpolate_lut2 in reverse (adjoint) mode (with options i4 dr8 r8): +! gradient of useful results: int_ope fraction_nox +! with respect to varying inputs: no2 no int_ope fraction_nox +! o3 +! RW status of diff variables: no2:out no:out int_ope:in-zero +! fraction_nox:in-zero o3:out +! +! + SUBROUTINE INTERPOLATE_LUT2_ADJ(i, j, o3, o3b, no, nob, no2, no2b, + & dens,jo1d, jno2, fraction_nox, + & fraction_noxb, int_ope, int_opeb) + +! +! !USES: +! + USE ERROR_MOD, ONLY : ERROR_STOP, SAFE_DIV + USE DAO_MOD, ONLY : TS, SUNCOS, SUNCOS_5hr + USE PARANOX_MOD, ONLY : FRACNOX, INTOPE + +# include "CMN_SIZE" ! Size parameters + +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: I, J + REAL*8, INTENT(IN) :: o3, no, no2, dens, jno2, jo1d + REAL*4, INTENT(IN) :: fraction_nox, int_ope + REAL*4, INTENT(IN) :: fraction_noxb, int_opeb + +! +! !OUTPUT PARAMETERS +! + REAL*8, INTENT(OUT) :: o3b, nob, no2b + + +! +! !REVISION HISTORY: +! Aug 2013 - Yanko Davila - Initial version based on forward subroutine. +! Automatic code generated with TAPENADE 3.7 +! adBufer.f and adStack.c from ISOROPIAII +! +! !LOCAL VARIABLES: +! +! !======================================================================= +! ! temp : model temperature +! ! jno2 : J(NO2) value +! ! cao3 : concentration O3 in ambient air +! ! alfa0 : solar zenith angle 5 hours ago +! ! alfa5 : solar zenith angle at this time +! ! jo1d : ratio J(O1D)/J(NO2) +! ! canox : concentration NOx in ambient air +! ! +! ! o3 : incoming o3 concentration +! ! no : incoming no +! ! no2 : incoming no2 +! ! dens : incoming air density +! !======================================================================= + + INTEGER :: IJLOOP + INTEGER, PARAMETER :: ntemp = 4 + INTEGER, PARAMETER :: njno2 = 4 + INTEGER, PARAMETER :: ncao3 = 4 + INTEGER, PARAMETER :: nalfa0 = 12 + INTEGER, PARAMETER :: nalfa5 = 12 + INTEGER, PARAMETER :: njo1d = 4 + INTEGER, PARAMETER :: ncanox = 5 + + + REAL*4, DIMENSION(ntemp) :: templev + REAL*4, DIMENSION(njno2) :: jno2lev + REAL*4, DIMENSION(ncao3) :: cao3lev + REAL*4, DIMENSION(nalfa0) :: alfa0lev + REAL*4, DIMENSION(nalfa5) :: alfa5lev + REAL*4, DIMENSION(njo1d) :: jo1dlev + REAL*4, DIMENSION(ncanox) :: canoxlev + + ! Temporary variable storage + REAL*4 :: temp_tmp, jno2_tmp, cao3_tmp + REAL*4 :: alfa0_tmp, alfa5_tmp, jo1d_tmp + REAL*4 :: canox_tmp + + ! ADJOINT of Temporary variable storage + REAL*4 :: temp_tmpb, jno2_tmpb, cao3_tmpb + REAL*4 :: alfa0_tmpb, alfa5_tmpb, jo1d_tmpb + REAL*4 :: canox_tmpb + + ! Interpolation parameters + REAL*4, DIMENSION(2) :: xtemp, xjno2, xcao3, xalfa0 + REAL*4, DIMENSION(2) :: xalfa5, xjo1d, xcanox + + ! ADJOINT of Interpolation parameters + REAL*4, DIMENSION(2) :: xtempb, xjno2b, xcao3b, xalfa0b + REAL*4, DIMENSION(2) :: xalfa5b, xjo1db, xcanoxb + + ! For loops + INTEGER :: itemp, ijno2, icao3, ialfa0 + INTEGER :: ialfa5, ijo1d, icanox + INTEGER :: i0,i1,i2,i3,i4,i5,i6,i7 + + ! array contain temp, jno2, cao3, alfa_0, alfa_5, jo1d, canox + REAL*4, DIMENSION(7) :: var_array + + ! ADJOINT of array contain temp, jno2, cao3, alfa_0, alfa_5, jo1d, canox + REAL*4, DIMENSION(7) :: var_arrayb + + CHARACTER(len=255) :: MSG + + ! TAPENADE generated variables + INTEGER :: branch + REAL*4 :: temp3 + REAL*4 :: temp2 + REAL*4 :: temp1 + REAL*4 :: temp0 + REAL*4 :: tempb2 + REAL*4 :: tempb1 + REAL*4 :: tempb0 + REAL*4 :: temp2b1 + REAL*4 :: temp2b0 + REAL*8 :: tempb + REAL*4 :: temp2b + REAL*4 :: temp + REAL*4 :: temp4 + + !================================================================= + ! INTERPOLATE_LUT2_ADJ begins here! + !================================================================= + + ! Set the levels that were chosen in the look up table + templev = (/ 275., 280., 285., 310. /) + jno2lev = (/ 5.e-4, 0.0025, 0.0050, 0.012 /) + cao3lev = (/ 5., 20., 35., 75. /) + alfa0lev = (/ -90., -60., -45., -30., + & -15., 0., 15., 30., + & 45., 60., 75., 90. /) + alfa5lev = (/ -90., -60., -45., -30., + & -15., 0., 15., 30., + & 45., 60., 75., 90. /) + jo1dlev = (/ 5.e-4, 0.0015, 0.0025, 0.0055 /) + canoxlev = (/ 10., 200., 1000., 2000., 6000. /) + +! PRINT*,"Temperature levels are: ",templev +! PRINT*,"This is grid cell: ",I,J + + ! Temperature +! PRINT*,"Temperature here is: ",TS(I,J) +! PRINT*,"USA: ",TS(32,64) + + ! Tracer concentrations in v/v +! PRINT*,"[O3] is: ",STT(I,J,1,IDTO3)/ State_Met%AD(I,J,1) * TCVV(IDTO3) +! PRINT*,"[CO] is: ",STT(I,J,1,IDTCO)/ State_Met%AD(I,J,1) * TCVV(IDTCO) +! PRINT*,"IDTO3 is: ", IDTO3 +! PRINT*,"IDO3 is: ", IDO3 +! PRINT*,"In USA: ",STT(32,64,1,IDTO3)/State_Met%AD(32,64,1) * TCVV(IDTO3) + + ! SOLAR ZENITH ANGLES IN DEGREES +! IJLOOP = ( (J-1) * IIPAR ) + I +! PRINT*,"Local Time: ",GET_LOCALTIME(I) +! PRINT*,"Solar Zenith Angle at this location: ", +! $ ASIND(SUNCOS(IJLOOP)) +! IJLOOP = ( (64-1) * IIPAR ) + 32 +! PRINT*,"Local USA time: ", GET_LOCALTIME(32) +! PRINT*,"Solar Zenith Angle at USA: ", +! & ASIND(SUNCOS(I,J)) +! PRINT*,"Solar Zenith Angle at USA - 5: ", +! & ASIND(SUNCOS_5hr(IJLOOP)) + + ! Set the variables + IJLOOP = ( (J-1) * IIPAR ) + I + var_array(1) = TS(I,J) ! Temperature + var_array(2) = JNO2 ! J(NO2), 1/s + var_array(3) = o3 / dens * 1.E9 ! [O3] in ppbv + var_array(4) = ASIND(SUNCOS(IJLOOP)) ! alfa0 + var_array(5) = ASIND(SUNCOS_5hr(IJLOOP)) ! alfa5 + var_array(6) = SAFE_DIV( JO1D, JNO2, 0d0 ) ! J(O1D)/J(NO2) + var_array(7) = (no + no2) / dens * 1.E12 ! [NOx] in pptv + + ! prevent NaN when jvalues are 0. + IF (jno2 .EQ. 0.) THEN + var_array(6) = 0. + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + ENDIF + + ! First some error checking + ! ########### MAYBE CHECK HERE FOR NEGATIVE VALUES?########## + + ! + ! Determine reference index ( itemp, ijno2, icao3, ialfa0, + ! ialfa5, ialfa, ijo1d, icaco ) + ! + !======================================================================== + ! Find smallest temperature reference level (i) for which actual + ! temperature is smaller, then do + ! + ! x(1) = ( temperature_level(i+1) - actual temperature ) + ! ------------------------------------------------- + ! ( temperature_level(i+1) - temperature_level(i) ) + ! + ! then x(2) = 1.0 - x(1) + ! + !======================================================================== + + + !--------------------- + ! Temperature: + !--------------------- + temp_tmp = var_array(1) + + ! If temperature larger than largest in LUT, assign largest temp + IF (var_array(1) .GT. templev(ntemp)) THEN + temp_tmp = templev(ntemp) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + ENDIF + + ! If temp smaller, assign smallest temp level + IF (var_array(1) .LT. templev(1)) THEN + temp_tmp = templev(1) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + ENDIF + + DO i0=1,ntemp-1 + itemp = i0 + IF( templev( itemp+1 ) > temp_tmp ) EXIT + END DO + + xtemp(1) = ( templev( itemp+1 ) - temp_tmp ) / + $ ( templev( itemp+1 ) - templev( itemp ) ) + xtemp(2) = 1.0 - xtemp(1) + + !--------------------- + ! J(NO2): + !--------------------- + jno2_tmp = var_array(2) + + ! If larger than largest in LUT, assign largest level values + IF (var_array(2) .GT. jno2lev(njno2)) THEN + jno2_tmp = jno2lev(njno2) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + ENDIF + + ! If smaller, assign smallest level value + IF (var_array(2) .LT. jno2lev(1)) THEN + jno2_tmp = jno2lev(1) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + ENDIF + + DO i0=1,njno2-1 + ijno2 = i0 + IF( jno2lev( ijno2+1 ) > jno2_tmp ) EXIT + END DO + + xjno2(1) = ( jno2lev( ijno2+1 ) - jno2_tmp ) / + $ ( jno2lev( ijno2+1 ) - jno2lev( ijno2 ) ) + xjno2(2) = 1.0 - xjno2(1) + + !--------------------- + ! [O3]: + !--------------------- + cao3_tmp = var_array(3) + + ! If larger than largest in LUT, assign largest level values + IF (var_array(3) .GT. cao3lev(ncao3)) THEN + cao3_tmp = cao3lev(ncao3) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + ENDIF + + ! If smaller, assign smallest level value + IF (var_array(3) .LT. cao3lev(1)) THEN + cao3_tmp = cao3lev(1) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + ENDIF + + DO i0=1,ncao3-1 + icao3 = i0 + IF( cao3lev( icao3+1 ) > cao3_tmp ) EXIT + END DO + + xcao3(1) = ( cao3lev( icao3+1 ) - cao3_tmp ) / + $ ( cao3lev( icao3+1 ) - cao3lev( icao3 ) ) + xcao3(2) = 1.0 - xcao3(1) + + !--------------------- + ! alfa0: + !--------------------- + alfa0_tmp = var_array(4) + + ! If larger than largest in LUT, assign largest level values + IF (var_array(4) .GT. alfa0lev(nalfa0)) THEN + alfa0_tmp = alfa0lev(nalfa0) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + ENDIF + + ! If smaller, assign smallest level value + IF (var_array(4) .LT. alfa0lev(1)) THEN + alfa0_tmp = alfa0lev(1) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + ENDIF + + DO i0=1,nalfa0-1 + ialfa0 = i0 + IF( alfa0lev( ialfa0+1 ) > alfa0_tmp ) EXIT + END DO + + xalfa0(1) = ( alfa0lev( ialfa0+1 ) - alfa0_tmp ) / + $ ( alfa0lev( ialfa0+1 ) - alfa0lev( ialfa0 ) ) + xalfa0(2) = 1.0 - xalfa0(1) + + !--------------------- + ! alfa5: + !--------------------- + alfa5_tmp = var_array(5) + + ! If larger than largest in LUT, assign largest level values + IF (var_array(5) .GT. alfa5lev(nalfa5)) THEN + alfa5_tmp = alfa5lev(nalfa5) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + + ! If smaller, assign smallest level value + IF (var_array(5) .LT. alfa5lev(1)) THEN + alfa5_tmp = alfa5lev(1) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + + DO i0=1,nalfa5-1 + ialfa5 = i0 + IF( alfa5lev( ialfa5+1 ) > alfa5_tmp ) EXIT + END DO + + xalfa5(1) = ( alfa5lev( ialfa5+1 ) - alfa5_tmp ) / + $ ( alfa5lev( ialfa5+1 ) - alfa5lev( ialfa5 ) ) + xalfa5(2) = 1.0 - xalfa5(1) + + !--------------------- + ! jo1d: + !--------------------- + jo1d_tmp = var_array(6) + + ! If larger than largest in LUT, assign largest level values + IF (var_array(6) .GT. jo1dlev(njo1d)) THEN + jo1d_tmp = jo1dlev(njo1d) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + ENDIF + + ! If smaller, assign smallest level value + IF (var_array(6) .LT. jo1dlev(1)) THEN + jo1d_tmp = jo1dlev(1) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + ENDIF + + DO i0=1,njo1d-1 + ijo1d = i0 + IF( jo1dlev( ijo1d+1 ) > jo1d_tmp ) EXIT + END DO + + xjo1d(1) = ( jo1dlev( ijo1d+1 ) - jo1d_tmp ) / + $ ( jo1dlev( ijo1d+1 ) - jo1dlev( ijo1d ) ) + xjo1d(2) = 1.0 - xjo1d(1) + + !--------------------- + ! [NOx]: + !--------------------- + canox_tmp = var_array(7) + + ! If larger than largest in LUT, assign largest level values + IF (var_array(7) .GT. canoxlev(ncanox)) THEN + canox_tmp = canoxlev(ncanox) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + ENDIF + + ! If smaller, assign smallest level value + IF (var_array(7) .LT. canoxlev(1)) THEN + canox_tmp = canoxlev(1) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + ENDIF + + DO i0=1,ncanox-1 + icanox = i0 + IF( canoxlev( icanox+1 ) > canox_tmp ) EXIT + END DO + + xcanox(1) = ( canoxlev( icanox+1 ) - canox_tmp ) / + $ ( canoxlev( icanox+1 ) - canoxlev( icanox ) ) + xcanox(2) = 1.0 - xcanox(1) + +! PRINT*,"The i-values are:", itemp, ijno2, icao3, ialfa0, +! $ ialfa5, ijo1d, icanox +! PRINT*,"Variables are: ", var_array +! PRINT*,"For testing, xtemp: ", xtemp + + !====================== + ! Linear interpolation + !====================== + + + xcanoxb = 0.0_4 + xtempb = 0.0_4 + xcao3b = 0.0_4 + xjo1db = 0.0_4 + xalfa0b = 0.0_4 + xjno2b = 0.0_4 + xalfa5b = 0.0_4 + + DO i1=2,1,-1 + DO i2=2,1,-1 + DO i3=2,1,-1 + DO i4=2,1,-1 + DO i5=2,1,-1 + DO i6=2,1,-1 + DO i7=2,1,-1 + + !IF ENCOUNTER -999 IN THE LUT PRINT ERROR!! + IF ( ( fracnox( itemp+i1-1, ijno2+i2-1, icao3+i3-1, + $ ialfa0+i4-1, ialfa5+i5-1, ijo1d+i6-1, + $ icanox+i7-1 ) < 0. ) .or. + $ ( fracnox( itemp+i1-1, ijno2+i2-1, icao3+i3-1, + $ ialfa0+i4-1, ialfa5+i5-1, ijo1d+i6-1, + $ icanox+i7-1 ) > 1. ) ) THEN + + PRINT*, 'INTERPOLATE_LUT2_ADJ: fracnox = ', + $ fracnox( itemp+i1-1, ijno2+i2-1, icao3+i3-1, + $ ialfa0+i4-1, ialfa5+i5-1, ijo1d+i6-1, + $ icanox+i7-1 ) + + MSG = 'LUT error: Fracnox should be between 0 and 1!' + CALL ERROR_STOP( MSG, + $ 'INTERPOLATE_LUT2_ADJ ("paranox_adj_mod.F")' ) + ENDIF + + temp1 = xalfa5(i5) * xjo1d(i6) + temp0 = xcao3(i3) * xalfa0(i4) + temp = xtemp(i1) * xjno2(i2) + + tempb2 = fracnox( itemp+i1-1, ijno2+i2-1, icao3+i3-1, + & ialfa0+i4-1, ialfa5+i5-1,ijo1d+i6-1, + & icanox+i7-1 ) * fraction_noxb + + tempb0 = temp0 * temp1 * tempb2 + tempb1 = temp * xcanox(i7) * tempb2 + temp4 = xalfa5(i5) * xjo1d(i6) + temp3 = xcao3(i3) * xalfa0(i4) + temp2 = xtemp(i1) * xjno2(i2) + + temp2b = intope( itemp+i1-1, ijno2+i2-1, icao3+i3-1, + & ialfa0+i4-1, ialfa5+i5-1,ijo1d+i6-1, + & icanox+i7-1 ) * int_opeb + + temp2b0 = temp3 * temp4 * temp2b + temp2b1 = temp2 * xcanox(i7) * temp2b + + xtempb(i1) = xtempb(i1) + & + xcanox(i7) * xjno2(i2) * tempb0 + & + xcanox(i7) * xjno2(i2) * temp2b0 + + xjno2b(i2) = xjno2b(i2) + & + xcanox(i7) * xtemp(i1) * tempb0 + & + xcanox(i7) * xtemp(i1) * temp2b0 + + xcanoxb(i7) = xcanoxb(i7) + & + temp * tempb0 + & + temp2 * temp2b0 + + xcao3b(i3) = xcao3b(i3) + & + temp1 * xalfa0(i4) * tempb1 + & + temp4 * xalfa0(i4) * temp2b1 + + xalfa0b(i4) = xalfa0b(i4) + & + temp1 * xcao3(i3) * tempb1 + & + temp4 * xcao3(i3) * temp2b1 + + xalfa5b(i5) = xalfa5b(i5) + & + temp0 * xjo1d(i6) * tempb1 + & + temp3 * xjo1d(i6) * temp2b1 + + xjo1db(i6) = xjo1db(i6) + & + temp0 * xalfa5(i5) * tempb1 + & + temp3 * xalfa5(i5) * temp2b1 + + END DO + END DO + END DO + END DO + END DO + END DO + END DO + + !--------------------- + ! [NOx]: ADJOINT + !--------------------- + xcanoxb(1) = xcanoxb(1) - xcanoxb(2) + xcanoxb(2) = 0.0_4 + canox_tmpb = -( xcanoxb(1)/ + & ( canoxlev(icanox+1) - canoxlev(icanox) ) ) + + CALL POPCONTROL1B(branch) + IF (branch .NE. 0) canox_tmpb = 0.0_4 + + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) canox_tmpb = 0.0_4 + + var_arrayb = 0.0_4 + var_arrayb(7) = var_arrayb(7) + canox_tmpb + + !--------------------- + ! jo1d: ADJOINT + !--------------------- + xjo1db(1) = xjo1db(1) - xjo1db(2) + xjo1db(2) = 0.0_4 + jo1d_tmpb = -( xjo1db(1)/ + & ( jo1dlev(ijo1d+1) - jo1dlev(ijo1d) ) ) + + CALL POPCONTROL1B(branch) + IF (branch .NE. 0) jo1d_tmpb = 0.0_4 + + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) jo1d_tmpb = 0.0_4 + + var_arrayb(6) = var_arrayb(6) + jo1d_tmpb + + !--------------------- + ! alfa5: ADJOINT + !--------------------- + xalfa5b(1) = xalfa5b(1) - xalfa5b(2) + xalfa5b(2) = 0.0_4 + + alfa5_tmpb = -( xalfa5b(1)/ + & ( alfa5lev(ialfa5+1) - alfa5lev(ialfa5) ) ) + + CALL POPCONTROL1B(branch) + IF (branch .NE. 0) alfa5_tmpb = 0.0_4 + + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) alfa5_tmpb = 0.0_4 + + var_arrayb(5) = var_arrayb(5) + alfa5_tmpb + + !--------------------- + ! alfa0: ADJOINT + !--------------------- + xalfa0b(1) = xalfa0b(1) - xalfa0b(2) + xalfa0b(2) = 0.0_4 + + alfa0_tmpb = -( xalfa0b(1)/ + & ( alfa0lev(ialfa0+1) - alfa0lev(ialfa0) ) ) + + CALL POPCONTROL1B(branch) + IF (branch .NE. 0) alfa0_tmpb = 0.0_4 + + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) alfa0_tmpb = 0.0_4 + + var_arrayb(4) = var_arrayb(4) + alfa0_tmpb + + !--------------------- + ! [O3]: ADJOINT + !--------------------- + xcao3b(1) = xcao3b(1) - xcao3b(2) + xcao3b(2) = 0.0_4 + + cao3_tmpb = -( xcao3b(1)/ + & ( cao3lev(icao3+1) - cao3lev(icao3) ) ) + + CALL POPCONTROL1B(branch) + IF (branch .NE. 0) cao3_tmpb = 0.0_4 + + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) cao3_tmpb = 0.0_4 + + var_arrayb(3) = var_arrayb(3) + cao3_tmpb + + !--------------------- + ! J(NO2): ADJOINT + !--------------------- + xjno2b(1) = xjno2b(1) - xjno2b(2) + xjno2b(2) = 0.0_4 + + jno2_tmpb = -( xjno2b(1)/ + & ( jno2lev(ijno2+1) - jno2lev(ijno2) ) ) + + CALL POPCONTROL1B(branch) + IF (branch .NE. 0) jno2_tmpb = 0.0_4 + + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) jno2_tmpb = 0.0_4 + var_arrayb(2) = var_arrayb(2) + jno2_tmpb + + !--------------------- + ! Temperature: ADJOINT + !--------------------- + xtempb(1) = xtempb(1) - xtempb(2) + xtempb(2) = 0.0_4 + + temp_tmpb = -( xtempb(1)/ + & ( templev(itemp+1) - templev(itemp) ) ) + + CALL POPCONTROL1B(branch) + IF (branch .NE. 0) temp_tmpb = 0.0_4 + + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) temp_tmpb = 0.0_4 + + var_arrayb(1) = var_arrayb(1) + temp_tmpb + + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) var_arrayb(6) = 0.0_4 + + + tempb = 1.e12*var_arrayb(7)/dens + nob = tempb + no2b = tempb + + var_arrayb(7) = 0.0_4 + var_arrayb(6) = 0.0_4 + var_arrayb(5) = 0.0_4 + var_arrayb(4) = 0.0_4 + + o3b = 1.e9*var_arrayb(3)/dens + + !int_opeb = 0.0_4 + !fraction_noxb = 0.0_4 + + END SUBROUTINE INTERPOLATE_LUT2_ADJ + + END MODULE PARANOX_ADJ_MOD + + diff --git a/code/adjoint/partition_adj.f b/code/adjoint/partition_adj.f new file mode 100644 index 0000000..5bfae0a --- /dev/null +++ b/code/adjoint/partition_adj.f @@ -0,0 +1,477 @@ +!$Id: partition_adj.f,v 1.3 2012/05/09 22:31:56 nicolas Exp $ +! + SUBROUTINE PARTITION_ADJ( STT_ADJ, STT, NTRACER, XNUMOL ) +! +!****************************************************************************** +! Subroutine PARTITION_ADJ is the adjoint of the fwd routine PARTITION. +! (dkh, 08/01/05) +! Based on ADJ_PARTITION from the GCv6 adjoint (dkh, 07/31/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) STT (REAL*8 ) : Tracer concentrations [kg/box] +! (2 ) NTRACER (INTEGER) : Number of tracers +! (3 ) XNUMOL (REAL*8 ) : Array of molecules tracer / kg tracer +! (4 ) STT_ADJ (REAL*8 ) : Array of adjoint concentrations +! +! Arguments as Output: +! ============================================================================ +! (1 ) STT_ADJ (REAL*8 ) : Updated adjoint concentrations +! +! NOTES: +! (1 ) See fwd version for additional notes. +! (2 ) Disable OMP parallel loops, which were leading to small errors +! in the 7th digit. (dkh, 10/08/06) +! (3 ) Update to GCv8 (dkh, 07/31/09) +! (4 ) Tighten filter to 1d-10 (jkoo, dkh, boun, 05/08/12) +!****************************************************************************** +! + ! References to F90 modules + USE COMODE_MOD, ONLY : CSPEC, JLOP, VOLUME + USE COMODE_MOD, ONLY : CSPEC_PRIOR, CSPEC_ADJ + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE CHECKPT_MOD, ONLY : PART_CASE + USE TRACERID_MOD + + IMPLICIT NONE + +# include "CMN_SIZE" +# include "comode.h" + + ! Arguments + INTEGER, INTENT(IN) :: NTRACER + REAL*8, INTENT(INOUT) :: STT(IIPAR,JJPAR,LLPAR,NNPAR) + REAL*8, INTENT(INOUT) :: STT_ADJ(IIPAR,JJPAR,LLPAR,NTRACER) + REAL*8, INTENT(IN) :: XNUMOL(NNPAR) + + ! Local variables + INTEGER :: I, J, L, N, JLOOP, IPL, JJ, KK + INTEGER :: CSAVEID(IGAS) + INTEGER :: CSAVEID_JJ(IGAS) + INTEGER :: CS, IDNUM, AS + REAL*8 :: CONCTMP, CONCNOX, SUM, SUM1 + REAL*8 :: CSAVE( ITLOOP, IGAS ) + ! UPDATE: Add this so we don't overwrite CSPEC. (dkh, 10/10/08) + REAL*8 :: CSPEC_TMP(IGAS) + + + ! Adjoint varialbes + INTEGER :: NN + REAL*8 :: ADCONCNOX + REAL*8 :: ADCONCTMP + REAL*8 :: ADSUM, ADSUM1 + REAL*8 :: ADCSAVE( ITLOOP, IGAS ) + + + !================================================================= + ! PARTITION_ADJ begins here! + !================================================================= + + ! Move this to further down below so that it happens every time + ! through the loop. (dkh, 10/10/08) + !! Reset local adjoint variables to zero + !ADSUM = 0.d0 + !ADSUM1 = 0.d0 + !ADCONCNOX = 0.d0 + !ADCONCTMP = 0.d0 + + ADCSAVE(:,:) = 0.d0 + + + ! Copy values of CSPEC that need to be saved (bdf, 3/30/99) + !================================================================= + IDNUM = 0 + + DO N = 1, NTRACER + + ! Skip if this is not a valid tracer + IF ( IDTRMB(N,1) == 0 ) CYCLE + + ! Handle all other tracers except Ox + IF ( N /= IDTOX ) THEN + DO KK = 1, NMEMBER(N) + IDNUM = IDNUM + 1 + JJ = IDTRMB(N,KK) + CSAVEID(JJ) = IDNUM + CSAVEID_JJ(IDNUM) = JJ + ENDDO + + ! Handle Ox + ELSE IF ( IDTOX /= 0 ) THEN + JJ = IDTRMB(N,1) + IDNUM = IDNUM + 1 + CSAVEID(JJ) = IDNUM + CSAVEID_JJ(IDNUM) = JJ + + ENDIF + ENDDO + + ! Loop over tracer members and boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, JLOOP ) +!$OMP+SCHEDULE( DYNAMIC ) + DO N = 1, IDNUM + DO L = 1, NPVERT + DO J = 1, NLAT + DO I = 1, NLONG + + ! 1-D SMVGEAR grid box index + JLOOP = JLOP(I,J,L) + IF ( JLOOP == 0 ) CYCLE + + ! Store into CSAVE + CSAVE(JLOOP,N) = CSPEC(JLOOP,CSAVEID_JJ(N)) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Split each tracer up into its components (if any) + ! Family tracers are partitioned among members according to + ! initial ratios. In tracer sequence, OX must be after NOX, + ! otherwise, adjust the code + !================================================================= + + ! BUG FIX: Loop from NTRACER to 1 by -1. (dkh, 10/10/08) + ! OLD CODE: + !DO N = 1, NTRACER + ! NEW CODE: + DO N = NTRACER, 1, -1 + + ! Get STT_ADJ tracer ID + !NN = ADJ2STT(N) + NN = N + + ! Skip if it's not a valid tracer + IF ( IDTRMB(N,1) == 0 .OR. NN == 0 ) CYCLE + + !### Debug + !WRITE(6,*) 'IN PARTITION N= ', N + + ! Loop over grid boxes +! UPDATE: reinstate OMP parallelization here (dkh, 10/11/08) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, JLOOP, CONCTMP, SUM, KK, JJ, SUM1, CONCNOX ) +!$OMP+PRIVATE( ADCONCTMP, ADCONCNOX, ADSUM, ADSUM1 ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, NPVERT + DO J = 1, NLAT + DO I = 1, NLONG + + ! BUG FIX: Reset adjoint variables here. (dkh, 10/10/08) + ! Reset local adjoint variables to zero + ADSUM = 0.d0 + ADSUM1 = 0.d0 + ADCONCNOX = 0.d0 + ADCONCTMP = 0.d0 + + ! 1-D SMVGEAR grid box index + JLOOP = JLOP(I,J,L) + IF ( JLOOP == 0 ) CYCLE + + ! Update: don't overwrite STT here (dkh, 10/10/08) + ! OLD: + ! Convert tracer concentration from [kg/box] to [molec/cm3/box] + !STT(I,J,L,N) = STT(I,J,L,N) / VOLUME(JLOOP) * XNUMOL(N) + ! + ! Store concentration in CONCTMP + !CONCTMP = STT(I,J,L,N) + ! NEW: + CONCTMP = STT(I,J,L,N) / VOLUME(JLOOP) * XNUMOL(N) + + + ! Adjoint depends on which family was partitioned first, Ox or NOx + SELECT CASE ( PART_CASE(JLOOP) ) + + ! Partition NOx first + CASE ( 1 ) + + !=========================================================== + ! First, find sum of starting concentrations + !=========================================================== + + !------------------------ + ! All tracers except Ox + !------------------------ + IF ( N /= IDTOX ) THEN + SUM = 0.d0 + + DO KK = 1, NMEMBER(N) + JJ = IDTRMB(N, KK) + + ! Error check + IF ( JJ == 0 ) THEN + PRINT *,JJ,JLOOP,N,KK,IDTRMB(N, KK) + ENDIF + + SUM = SUM + & + CSAVE(JLOOP,CSAVEID(JJ)) * (CTRMB(N,KK)+1) + ENDDO + ENDIF + + ! Begin TAMC generated adjoint code. Manual modifications + ! are capitalized. + if (n .ne. idtox) then + do kk = 1, nmember(n) + ! Update: Avoid divide by sum**2, + ! which leads to NaNs (dkh, 10/10/08) + IF ( SUM .GT. 1d-10 ) THEN + jj = idtrmb(n,kk) + adconctmp = adconctmp+cspec_adj(jloop,jj)* + $(csave(jloop,csaveid(jj))/sum) + adcsave(jloop,csaveid(jj)) = adcsave(jloop, + $csaveid(jj))+cspec_adj(jloop,jj)/sum*conctmp + adsum = adsum-cspec_adj(jloop,jj)*csave(jloop, + $csaveid(jj))/(sum*sum)*conctmp + ENDIF + cspec_adj(jloop,jj) = 0. + end do + else if (idtox .ne. 0 .and. idtnox .ne. 0) then + jj = ido3 + adconctmp = adconctmp+cspec_adj(jloop,jj) + adsum1 = adsum1-cspec_adj(jloop,jj) + cspec_adj(jloop,jj) = 0. + else + print*, ' big error here ' + endif + if (n .ne. idtox) then + do kk = 1, nmember(n) + jj = idtrmb(n,kk) + adcsave(jloop,csaveid(jj)) = adcsave(jloop, + $csaveid(jj))+adsum*(1+ctrmb(n,kk)) + end do + adsum = 0. + else if (idtox .ne. 0) then + do kk = 2, nmember(n) + jj = idtrmb(n,kk) + cspec_adj(jloop,jj) = cspec_adj(jloop,jj) + &+adsum1*(1+ctrmb(n,kk)) + end do + adsum1 = 0. + endif + + ! Partition Ox first + CASE ( 2 ) + + !=========================================================== + ! First, find sum of starting concentrations + !=========================================================== + + !------------------------ + ! All tracers except Ox + !------------------------ + IF ( N /= IDTOX ) THEN + SUM = 0.d0 + + DO KK = 1, NMEMBER(N) + JJ = IDTRMB(N, KK) + + ! Error check + IF ( JJ == 0 ) THEN + PRINT *,JJ,JLOOP,N,KK,IDTRMB(N, KK) + ENDIF + + SUM = SUM + & + CSAVE(JLOOP,CSAVEID(JJ)) * (CTRMB(N,KK)+1) + ENDDO + + !------------------------ + ! Ox + !------------------------ + ELSE IF ( IDTOX /= 0 ) THEN + JJ = IDTRMB(N,1) + SUM = CSAVE(JLOOP,CSAVEID(JJ)) * (CTRMB(N,1)+1) +! Case 1 stuff. dkh +! SUM1 = 0.d0 + + + ! SUM = sum of starting values for all Ox species (incl. O3) + ! SUM1 = sum of new values for all Ox species except O3, + ! based on NOx partitioning + DO KK = 2, NMEMBER(N) + JJ = IDTRMB(N,KK) + SUM = SUM + & + CSAVE(JLOOP,CSAVEID(JJ))*(CTRMB(N,KK)+1) +! Case 1 stuff. dkh +! SUM1 = SUM1+ CSPEC(JLOOP,JJ) * (CTRMB(N,KK)+1) + ENDDO + + ENDIF + + ! Begin TAMC generated adjoint of partioning for Case 2 + if (n .ne. idtox) then + do kk = 1, nmember(n) + IF ( SUM .gt. 1d-10 ) THEN + jj = idtrmb(n,kk) + adconctmp = adconctmp+cspec_adj(jloop,jj)* + $(csave(jloop,csaveid(jj))/sum) + adcsave(jloop,csaveid(jj)) = adcsave(jloop, + $csaveid(jj))+cspec_adj(jloop,jj)/sum*conctmp + adsum = adsum-cspec_adj(jloop,jj)*csave(jloop, + $csaveid(jj))/(sum*sum)*conctmp + ENDIF + cspec_adj(jloop,jj) = 0. + end do + else if (idtox .ne. 0 .and. idtnox .ne. 0) then + do kk = 1, nmember(n) + jj = idtrmb(n,kk) + ! Update: don't overwrite CSPEC (dkh, 10/10/08) + !cspec(jloop,jj) = csave(jloop,csaveid(jj))/sum* + CSPEC_TMP(jj) = csave(jloop,csaveid(jj))/sum* + $conctmp + end do + sum = 0.d0 + sum1 = 0.d0 + do kk = 1, nmember(idtnox) + jj = idtrmb(idtnox,kk) + if (jj .eq. idno .or. jj .eq. idhno2) then + sum = sum+csave(jloop,csaveid(jj))*(ctrmb(idtnox,kk)+1) + else + ! Update: use CSPEC_TMP (dkh, 10/10/08) + !sum1 = sum1+cspec(jloop,jj)*(ctrmb(idtnox,kk)+1) + sum1 = sum1+CSPEC_TMP(jj)*(ctrmb(idtnox,kk)+1) + endif + end do + !---------------------------------- + ! BUG FIX: need to convert units + ! of concnox here (jkoo, dkh, 09/30/10) + ! old code: + !concnox = stt(i,j,l,idtnox) + ! new code: + concnox = stt(i,j,l,idtnox) + & / VOLUME(JLOOP) * XNUMOL(IDTNOX) + !---------------------------------- + do kk = 1, nmember(idtnox) + jj = idtrmb(idtnox,kk) + if (jj .eq. idno .or. jj .eq. idhno2) then + !IF ( sum .gt. 0d0 ) THEN + IF ( sum .gt. 1d-10 ) THEN + adconcnox = adconcnox+cspec_adj(jloop,jj) + &*(csave(jloop,csaveid(jj))/sum) + adcsave(jloop,csaveid(jj)) = adcsave(jloop,csaveid(jj))+ + $cspec_adj(jloop,jj)/sum*(concnox-sum1) + adsum = adsum-cspec_adj(jloop,jj)*csave(jloop,csaveid(jj)) + $/(sum*sum) + $*(concnox-sum1) + adsum1 = adsum1-cspec_adj(jloop,jj)*(csave(jloop,csaveid(jj))/sum) + ENDIF + cspec_adj(jloop,jj) = 0. + endif + end do + STT_ADJ(i,j,l,idtnox) = + & STT_ADJ(i,j,l,idtnox)+adconcnox + adconcnox = 0. + do kk = 1, nmember(idtnox) + jj = idtrmb(idtnox,kk) + if (jj .eq. idno .or. jj .eq. idhno2) then + adcsave(jloop,csaveid(jj)) = adcsave(jloop,csaveid(jj))+adsum*(1+ + $ctrmb(idtnox,kk)) + else + cspec_adj(jloop,jj) = cspec_adj(jloop,jj) + & +adsum1*(1+ctrmb(idtnox,kk)) + endif + end do + adsum1 = 0. + adsum = 0. + !sum = sumk + if (n .ne. idtox) then + sum = 0.d0 + do kk = 1, nmember(n) + jj = idtrmb(n,kk) + sum = sum+csave(jloop,csaveid(jj))*(ctrmb(n,kk)+1) + end do + else if (idtox .ne. 0) then + jj = idtrmb(n,1) + sum = csave(jloop,csaveid(jj))*(ctrmb(n,1)+1) + do kk = 2, nmember(n) + jj = idtrmb(n,kk) + sum = sum+csave(jloop,csaveid(jj))*(ctrmb(n,kk)+1) + end do + endif + do kk = 1, nmember(n) + !IF ( sum .gt. 0d0 ) THEN + IF ( sum .gt. 1d-10 ) THEN + jj = idtrmb(n,kk) + adconctmp = adconctmp+cspec_adj(jloop,jj)* + $(csave(jloop,csaveid(jj))/sum) + adcsave(jloop,csaveid(jj)) = adcsave(jloop, + $csaveid(jj))+cspec_adj(jloop,jj)/sum*conctmp + adsum = adsum-cspec_adj(jloop,jj)*csave(jloop, + $csaveid(jj))/(sum*sum)*conctmp + ENDIF + cspec_adj(jloop,jj) = 0. + end do + endif + if (n .ne. idtox) then + do kk = 1, nmember(n) + jj = idtrmb(n,kk) + adcsave(jloop,csaveid(jj)) = adcsave(jloop, + $csaveid(jj))+adsum*(1+ctrmb(n,kk)) + end do + adsum = 0. + else if (idtox .ne. 0) then + do kk = 2, nmember(n) + jj = idtrmb(n,kk) + adcsave(jloop,csaveid(jj)) = adcsave(jloop, + $csaveid(jj))+adsum*(1+ctrmb(n,kk)) + end do + jj = idtrmb(n,1) + adcsave(jloop,csaveid(jj)) = + $adcsave(jloop,csaveid(jj))+adsum*(1+ctrmb(n,1)) + adsum = 0. + endif + + CASE DEFAULT + WRITE(6,*) I, J, L, JLOOP + CALL ERROR_STOP( 'bad PART_CASE', 'PARTITION_ADJ' ) + + END SELECT + + STT_ADJ(i,j,l,NN) = STT_ADJ(i,j,l,NN)+adconctmp + adconctmp = 0. + STT_ADJ(i,j,l,NN) = STT_ADJ(i,j,l,NN) + & /volume(jloop)*xnumol(n) + + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDDO + + ! BUG FIX: add this part to pass sensitivities to ADJ_CSPEC + ! which then get fed back to STT_ADJ in subroutine LUMP_ADJ + ! (dkh, 10/11/08) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, JLOOP ) +!$OMP+SCHEDULE( DYNAMIC ) + DO N = 1, IDNUM + DO L = 1, NPVERT + DO J = 1, NLAT + DO I = 1, NLONG + + ! 1-D SMVGEAR grid box index + JLOOP = JLOP(I,J,L) + IF ( JLOOP == 0 ) CYCLE + + ! fwd code: + !CSAVE(JLOOP,N) = CSPEC(JLOOP,CSAVEID_JJ(N)) + ! adj code: + CSPEC_ADJ(JLOOP,CSAVEID_JJ(N)) = CSPEC_ADJ(JLOOP,CSAVEID_JJ(N)) + & + ADCSAVE(JLOOP,N) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE PARTITION_ADJ + diff --git a/code/adjoint/pbl_mix_adj_mod.f b/code/adjoint/pbl_mix_adj_mod.f new file mode 100644 index 0000000..7084bfc --- /dev/null +++ b/code/adjoint/pbl_mix_adj_mod.f @@ -0,0 +1,248 @@ +! $Id: pbl_mix_adj_mod.f,v 1.3 2009/11/12 00:45:48 daven Exp $ + MODULE PBL_MIX_ADJ_MOD +! +!****************************************************************************** +! Module PBL_MIX_MOD_ADJ contains adjoint routines and variables used to compute the +! planetary boundary layer (PBL) height and to mix tracers underneath the +! PBL top. (ks, dkh, 07/08/09) +! +! Module Routines: +! ============================================================================ +! (1 ) DO_PBL_MIX_ADJ : Driver routine for PBL mixing +! (2 ) TURBDAY_ADJ : Adjoint of TURBDAY +! +! NOTES: +! (1 ) Now modified for GCAP and GEOS-5 met fields (bmy, 5/24/05) +! (2 ) Remove reference to "CMN" and XTRA2. (bmy, 8/30/05) +! (3 ) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +! (4 ) Now recalculate IMIX, FPBL rather than checkpoint (dkh, 07/08/09) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "pbl_mix_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: DO_PBL_MIX_ADJ + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_PBL_MIX_ADJ( DO_TURBDAY ) +! +!****************************************************************************** +! Subroutine DO_PBL_MIX is the driver routine for planetary boundary layer +! mixing. The PBL layer height and related quantities are always computed. +! Complete mixing of tracers underneath the PBL top is toggled by the +! DO_TURBDAY switch. (bmy, 2/11/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) DO_TURBDAY (LOGICAL) : Switch which turns on PBL mixing of tracers +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE LOGICAL_MOD, ONLY : LTURB + USE PBL_MIX_MOD, ONLY : COMPUTE_PBL_HEIGHT + USE TRACER_MOD, ONLY : N_TRACERS, TCVV + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + LOGICAL, INTENT(IN) :: DO_TURBDAY + + !================================================================= + ! DO_PBL_MIX_ADJ begins here! + !================================================================= + + ! Now recompute these rather than checkpoint. (dkh, 07/08/09) + ! Compute PBL height and related quantities + CALL COMPUTE_PBL_HEIGHT + + ! Do complete mixing of tracers in the PBL (if necessary) + IF ( DO_TURBDAY ) CALL TURBDAY_ADJ( N_TRACERS, TCVV ) + + ! Return to calling program + END SUBROUTINE DO_PBL_MIX_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE TURBDAY_ADJ(NTRC, TCVV) +! +!****************************************************************************** +! Subroutine TURBDAY_ADJ executes the adjoint of the GEOS-CTM dry convection +! / boundary layer mixing algorithm from TURBDAY. It is a combination of the +! forward code TURBDAY with TAMC generated adjoint of the loop over N. +! See notes in turbday.f for info about the original forward code, and +! below for notes on modifications made for the adjoint version. +! (dkh, 10/30/04) +! +! Arguments as Input: +! =========================================================================== +! (1 ) NTRC : Number of tracers used in computation [1 to NNPAR] +! (2 ) TCVV : mol. wt. air / mol. wt. tracer +! +! Modue variable Input / Output +! ====================================================================== +! (1 ) STT_ADJ : Adjoint tracer array +! +! NOTES: +! (1 ) Rather than save / write / read the info from the forward run of TURBDAY, +! we will just recompute most of it, hence most of the original code for +! TURBDAY is part of ADJ_TURBDAY. However, some alterations were made to +! the forward code. +! Changes to forward code: +! - argument list just NTRC and TCVV, which are passed +! the values of NADJ and ADJ_TCVV, respectfully. +! - add reference to CMN_ADJ for ADJ_STT +! - no ND15 diagnostic update, so get rid of USE DAO_MOD +! - get rid of XTRA2, LTURB +! - get rid of initial print out +! (2 ) TAMC (and modified TAMC) code is lower case. +! Changes to TAMC code: +! - The varialbes TC_IN and TC_OUT were used to construct the +! adjoint, but they are not needed here. Just replace them +! with ADJ_STT +! - Replade multiple do loops with ":" operator (so no longer +! need integers ip1,ip2,ip3,ip4) +! - Force variables explicitly to double precision using .d0 +! - Initialize and update global adjoint variables (adtc, addtc) +! before and after the PARALLEL DO loop +! (3 ) Updated for v8 adjoint (dkh, 07/14/09) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE DAO_MOD, ONLY : AD, PBL + USE GRID_MOD, ONLY : GET_AREA_M2 + USE TIME_MOD, ONLY : GET_TS_CONV + USE PBL_MIX_MOD, ONLY : GET_IMIX + USE PBL_MIX_MOD, ONLY : GET_FPBL + USE PRESSURE_MOD, ONLY : GET_PEDGE + + ! dkh debug + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD + + IMPLICIT NONE + +# include "CMN_SIZE" + + ! Argument variables + INTEGER, INTENT(IN) :: NTRC + REAL*8, INTENT(IN) :: TCVV(NTRC) + + ! Local variables + INTEGER :: I, J, L, LTOP, N + REAL*8 :: AA, CC, CC_AA, BLTOP + REAL*8 :: PW, PS, AREA_M2, DTCONV + REAL*8 :: P(0:LLPAR) + REAL*8 :: A(IIPAR,JJPAR) + REAL*8 :: DTC(IIPAR,JJPAR,LLPAR,NTRC) + + ! Adjoint variables + real*8 adcc + real*8 adcc_aa + real*8 adtc(iipar,jjpar,llpar,ntrc) + real*8 adtc_in(iipar,jjpar,llpar,ntrc) + real*8 adtc_out(iipar,jjpar,llpar,ntrc) + + !================================================================= + ! TURBDAY_ADJ begins here! + !================================================================= + + ! Echo some input to the screen + WRITE( 6, '(a)' ) ' -- TURBDAY_ADJ' + + ! Don't need DTCONV for adjoint calculation + ! Convection timestep [s] + !DTCONV = GET_TS_CONV() * 60d0 + + ! We assume full mixing in the boundary layer, so the A + ! coefficients are 1 everywhere, day & night (bmy, 2/11/03) + A(:,:) = 1d0 + + !---------------------------------------------- + ! SET GLOBAL ADJOINT VARIABLES + !---------------------------------------------- + adtc(:,:,:,:) = 0.d0 + adtc_in(:,:,:,:) = 0.d0 + adtc_out(:,:,:,:) = STT_ADJ(:,:,:,:) + + ! Loop over Lat/Long grid boxes (I,J) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, AA, CC, CC_AA ) +!$OMP+PRIVATE( adcc, adcc_aa) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Calculate air mass within PBL at grid box (I,J,L) + AA = 0.d0 + DO L = 1, GET_IMIX(I,J)-1 + AA = AA + AD(I,J,L) + ENDDO + + L = GET_IMIX(I,J) + AA = AA + AD(I,J,L) * GET_FPBL(I,J) + + ! Loop over tracers + DO N = 1, NTRC + + !---------------------------------------------- + ! RESET LOCAL ADJOINT VARIABLES + !---------------------------------------------- + adcc = 0.d0 + adcc_aa = 0.d0 + + !---------------------------------------------- + ! ADJOINT ROUTINE BODY + !---------------------------------------------- + l = GET_IMIX(i,j) + adtc(i,j,:,n) = adtc(i,j,:,n)+adtc_out(i,j,:,n) + adtc_out(i,j,:,n) = 0.d0 + adcc_aa = adcc_aa+adtc(i,j,l,n)*a(i,j)*GET_FPBL(i,j) + adtc(i,j,l,n) = adtc(i,j,l,n)*(1.d0-a(i,j)*GET_FPBL(i,j)) + do l = 1, GET_IMIX(i,j)-1 + adcc_aa = adcc_aa+adtc(i,j,l,n)*a(i,j) + adtc(i,j,l,n) = adtc(i,j,l,n)*(1.d0-a(i,j)) + end do + adcc = adcc+adcc_aa/aa + adcc_aa = 0.d0 + l = GET_IMIX(i,j) + adtc(i,j,l,n) = adtc(i,j,l,n)+adcc*ad(i,j,l)*GET_FPBL(i,j) + do l = 1, GET_IMIX(i,j)-1 + adtc(i,j,l,n) = adtc(i,j,l,n)+adcc*ad(i,j,l) + end do + adtc_in(i,j,:,n) = adtc_in(i,j,:,n)+adtc(i,j,:,n) + adtc(i,j,:,n) = 0.d0 + + ENDDO !N + ENDDO !I + ENDDO !J +!$OMP END PARALLEL DO + + ! Update global adjoint variables + STT_ADJ(:,:,:,:) = adtc_in(:,:,:,:) + adtc_in(:,:,:,:) = 0d0 + + ! Return to calling program + END SUBROUTINE TURBDAY_ADJ + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE PBL_MIX_ADJ_MOD diff --git a/code/adjoint/rpmares_adj_mod.f b/code/adjoint/rpmares_adj_mod.f new file mode 100644 index 0000000..5ee07c5 --- /dev/null +++ b/code/adjoint/rpmares_adj_mod.f @@ -0,0 +1,3960 @@ +! $Id: rpmares_adj_mod.f,v 1.1 2009/09/09 06:12:55 daven Exp $ + MODULE RPMARES_ADJ_MOD +! +!****************************************************************************** +! Module RPMARES_ADJ_MOD is used to call the aerosol thermo adjoint +! subroutines (dkh, 09/08/09) +! +! Module Routines: +! ============================================================================ +! (1 ) DO_RPMARES_ADJ : Driver which calls adjoint thermo routines +! (2 ) adactcof : adjoint of actcof +! (3 ) adawater : adjoint of awater +! (4 ) adrpmares_11 : adjoint of rpmares exit=11 +! (5 ) adrpmares_12 : adjoint of rpmares exit=12 +! (6 ) adrpmares_2 : adjoint of rpmares exit=2 +! (7 ) adrpmares_3 : adjoint of rpmares exit=3 +! (8 ) adrpmares_4 : adjoint of rpmares exit=4 +! (9 ) adrpmares_6 : adjoint of rpmares exit=6 (old) +! (10) adrpmares_7 : adjoint of rpmares exit=7 +! (11) adrpmares_8 : adjoint of rpmares exit=8 +! (12) adcubic : adjoint of cubic +! (13) adrpmares_6_D5 : adjoint of rpmares exit=6 (correct) +! +! GEOS-CHEM modules referenced by chemistry_mod.f +! ============================================================================ +! (1 ) checkpt_mod : Module w/ routines for checkpointing +! (2 ) dao_mod : Module containing arrays for DAO met fields +! (3 ) rpmares_mod : Module w/ routines for aerosol thermodynamics +! (4 ) tracerid_mod : Module containing pointers to tracers & emissions +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 09/09/09) +! +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_RPMARES_ADJ ( ) +! +!****************************************************************************** +! Subroutine DO_RPMARES_ADJ is the driver for the TAMC generated adjoint of the +! aerosol thermodynamic routine RPMARES +! (dkh, 8/27/04, 09/08/09) +! +! Passed via checkpoint_mod.f +! ============================================================================ +! +! NOTES: +! (1 ) Add error checking. Add ADJ_NAN, FIRST, ADJ_NAN_COUNT, ADJ_MAX... +! Check ADJ_STT for NAN and for large increases after calls to adrpmares. +! Now reference IT_IS_NAN. (dkh, 02/08/05) +! (2 ) Move paramters NCTOT and NPAR from CMN_ADJ to here. Replace many uses +! of NADJ with NCTOT. Initialize ADJ_TMP after initializing ADJ_STT_LOCAL. +! ADJ_STT_LOCAL is now dim = 8, not dim = NOBS, as NOBS may be much larger. +! Remove IS_DURING_OBSERVATION argument +! No longer force adjoints in this routine, do it in ???. (dkh, 03/03/05) +! (3 ) Now the ITS_TIME_FOR_CHEM section uses ADJ_STT [kg], so switch to +! [ug/m3] for this portion, and switch back at the end. (dkh, 03/10/05) +! (4 ) Replace the adjoint code for the high ratio case ( NRETURN = 6 ) with +! improved code that is more accurate and requires less checkpointing. +! (dkh, 06/01/05) +! (5 ) Now reference ADJ_CONVERT_UNITS from dao_mod.f (dkh, 11/03/05) +! (6 ) Udpated to GCv8, renamed from ADJ_AEROSOL to DO_RPMARES_ADJ. +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE CHECKPT_MOD, ONLY : RP_IN, RP_OUT + USE DAO_MOD, ONLY : AIRVOL + USE ERROR_MOD, ONLY : ERROR_STOP, IT_IS_NAN + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE TRACERID_MOD, ONLY : IDTSO4, IDTNH3, IDTNH4, IDTHNO3 + USE TRACERID_MOD, ONLY : IDTNIT + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT + + +# include "CMN_SIZE" ! Size params + + ! Parameters + INTEGER, PARAMETER :: MAX_ALLOWED_NAN = 10 + INTEGER, PARAMETER :: MAX_ALLOWED_EXPLD = 10 + REAL*8, PARAMETER :: MAX_ALLOWED_INCREASE = 10.0D10 + + INTEGER, PARAMETER :: NPAR = 2 ! Number of input variables to RPMARES that are + ! parameters, i.e. temp and rh + + INTEGER, PARAMETER :: NCTOT = 5 ! Number of input variables to RPMARES that are + ! total concentrations, = NRPIN - NPAR + + ! Local variables + REAL*8 :: CTOT_P(NCTOT) ! Same size as argument of the ad_rpmares routines + REAL*8 :: PAR_P(NPAR) + REAL*8 :: ADJ_STT_LOCAL(8) ! Same size as argument of the ad_rpmares routines + REAL*8 :: ADJ_CTOT(NCTOT) + INTEGER :: I, J, L, N + INTEGER :: NRETURN + REAL*8 :: ADJ_TMP(NCTOT) ! Temp storage for resetting bad adjs to original value + REAL*8 :: MAX_ADJ_TMP ! Temp max value used for error checking + LOGICAL :: ADJ_NAN = .FALSE. + INTEGER :: ADJ_NAN_COUNT, ADJ_EXPLD_COUNT + LOGICAL, SAVE :: FIRST = .TRUE. + REAL*8 :: AVOL + + !================================================================ + ! DO_RPMARES_ADJ begins here! + !================================================================ + + ! Initialize ADJ_NAN_COUNT the first time through + IF ( FIRST ) THEN + ADJ_NAN_COUNT = 0 + ADJ_EXPLD_COUNT = 0 + + FIRST = .FALSE. + ENDIF + + ! Save maximum adjoint for error checking later + MAX_ADJ_TMP = MAXVAL( ABS(STT_ADJ) ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) +!$OMP+PRIVATE( CTOT_P, PAR_P, NRETURN, ADJ_STT_LOCAL ) +!$OMP+PRIVATE( ADJ_TMP, ADJ_CTOT ) +!$OMP+PRIVATE( AVOL ) + DO L = 1, LLTROP + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Skip if we are in the stratosphere (bmy, 4/3/08) + IF ( ITS_IN_THE_STRAT( I, J, L ) ) CYCLE + + ! air volume + AVOL = AIRVOL(I,J,L) + + ! Load IN from RP_IN + CTOT_P(:) = RP_IN(I,J,L,1:NCTOT) + + ! Load parameters from RP_IN + PAR_P(:) = RP_IN(I,J,L,6:7) + + ! Find out where RPMARES exited during the forward run + NRETURN = RP_OUT(I,J,L,9) + + + ! Initialize the independent and dependent variables to 0 + ADJ_CTOT(:) = 0.D0 + ADJ_STT_LOCAL(:) = 0.D0 + + ! Copy current value of ADJ variable to ADJ_STT_LOCAL + ! Always update the local adjoint input to the current adjoint tracer + ! values + ADJ_STT_LOCAL(3) = STT_ADJ(I,J,L,IDTNIT) * AVOL * 1.d-9 + ADJ_STT_LOCAL(5) = STT_ADJ(I,J,L,IDTNH4) * AVOL * 1.d-9 + ADJ_STT_LOCAL(7) = STT_ADJ(I,J,L,IDTHNO3) * AVOL * 1.d-9 + ADJ_STT_LOCAL(8) = STT_ADJ(I,J,L,IDTNH3) * AVOL * 1.d-9 + ! Since thermo doesn't modify total sulfate, don't need to + ! pass it initial adjoint values for SO4 ? + ADJ_STT_LOCAL(6) = 0d0 + + ! The forcing for these species is also zero + ADJ_STT_LOCAL(1) = 0.d0 + ADJ_STT_LOCAL(2) = 0.d0 + ADJ_STT_LOCAL(4) = 0.d0 + + ! Store original values in ADJ_TMP + ADJ_TMP(1) = STT_ADJ(I,J,L,IDTSO4) + ADJ_TMP(2) = STT_ADJ(I,J,L,IDTHNO3) + ADJ_TMP(3) = STT_ADJ(I,J,L,IDTNH3) + ADJ_TMP(4) = STT_ADJ(I,J,L,IDTNIT) + ADJ_TMP(5) = STT_ADJ(I,J,L,IDTNH4) + + IF ( LPRINTFD + & .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN + print*, 'before ', CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL + print*, 'NRETURN = ', NRETURN + ENDIF + + !============================================================ + ! CALCULATE ADJOINT THERMO + ! + ! The thermodynamic routine is broken into several regimes. + ! The regime from the forward calculation is marked by the + ! NRETURN flag. Use this flag to push the adjoint calculation + ! into the same regime. + !============================================================ + + IF (NRETURN == 1) THEN + ! the adjoint variables are unchanged in this case + ADJ_CTOT(:) = ADJ_TMP(:) + + ELSEIF (NRETURN == 2) THEN + CALL adrpmares_2( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL, + & I, J, L ) + ELSEIF (NRETURN == 3 .OR. NRETURN == 5) THEN + CALL adrpmares_3( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL, + & I, J, L ) + ELSEIF (NRETURN == 4) THEN + CALL adrpmares_4( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL, + & I, J, L ) + ELSEIF (NRETURN == 6) THEN + CALL adrpmares_6_D5( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL, + & I, J, L ) + ELSEIF (NRETURN == 7) THEN + CALL adrpmares_7( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL, + & I, J, L ) + ELSEIF (NRETURN == 8 .OR. NRETURN == 9 + & .OR. NRETURN == 10) THEN + CALL adrpmares_8( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL, + & I, J, L ) + ELSEIF (NRETURN == 11) THEN + CALL adrpmares_11( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL, + & I, J, L ) + ELSEIF (NRETURN == 12) THEN + CALL adrpmares_12( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL, + & I, J, L ) + ELSE + print*, ' NRETURN = ', NRETURN , I, J, L + CALL ERROR_STOP + & ('ERROR: NRETURN ill defined ','ADJ_AEROSOL') + ENDIF + + IF ( LPRINTFD .AND. + & J == JFD .AND. L == LFD .AND. I == IFD) THEN + print*, 'after ', CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL + ENDIF + + ! Check for NAN. + DO N = 1, NCTOT + + IF ( IT_IS_NAN( ADJ_CTOT(N) ) ) THEN + + ! Echo location of NAN (probably leave this commented out + ! unless you are getting lots of ADJ_NAN warnings + !WRITE(6,*) 'FOUND A NAN AT I,J,L,N = ',I,J,L,N + +!$OMP CRITICAL + ! Set ADJ_NAN flag so that a warning is echod to screen + ADJ_NAN = .TRUE. +!$OMP END CRITICAL + + ! Replace the NAN with the original value and continue + ADJ_CTOT(N) = ADJ_TMP(N) + ENDIF + + ENDDO + + ! Update ADJ_STT array + STT_ADJ(I,J,L,IDTHNO3) = ADJ_CTOT(2) * 1.d9 / AVOL + STT_ADJ(I,J,L,IDTNH3) = ADJ_CTOT(3) * 1.d9 / AVOL + STT_ADJ(I,J,L,IDTNIT) = ADJ_CTOT(4) * 1.d9 / AVOL + STT_ADJ(I,J,L,IDTNH4) = ADJ_CTOT(5) * 1.d9 / AVOL + + ! Becuase we don't initiate the sulfate adjoint with STT_ADJ, + ! do not overwrite. + STT_ADJ(I,J,L,IDTSO4) = STT_ADJ(I,J,L,IDTSO4) + & + ADJ_CTOT(1) * 1.d9 / AVOL + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ! Error checking + IF ( ADJ_NAN ) THEN + + ! Echo a warning to the screen + WRITE(6,*) + & ' *** - WARNING: ADJ_NAN in routine ADJ_AEROSOL' + + ! keep track of how many times NANs have occured + ADJ_NAN_COUNT = ADJ_NAN_COUNT + 1 + + IF ( ADJ_NAN_COUNT > MAX_ALLOWED_NAN ) + & CALL ERROR_STOP('Too many NANs', 'ADJ_AEROSOL') + + ENDIF + + ! More error checking: warn of exploding adjoit values, except + ! the first jump up from zero (MAX_ADJ_TMP = 0 first few times) + IF ( MAXVAL(ABS(STT_ADJ)) > (MAX_ADJ_TMP * MAX_ALLOWED_INCREASE) + & .AND. ( MAX_ADJ_TMP > 0d0 ) ) THEN + + WRITE(6,*)' *** - WARNING: EXPLODING adjoints in ADJ_AEROSOL' + WRITE(6,*)' *** - MAX(ADJ_STT) before = ',MAX_ADJ_TMP + WRITE(6,*)' *** - MAX(ADJ_STT) after = ',MAXVAL(ABS(STT_ADJ)) + + ADJ_EXPLD_COUNT = ADJ_EXPLD_COUNT + 1 + + IF (ADJ_EXPLD_COUNT > MAX_ALLOWED_EXPLD ) + & CALL ERROR_STOP('Too many exploding adjoints', + & 'ADJ_AEROSOL, adjoint_mod.f') + + ENDIF + + ! Return to calling program + END SUBROUTINE DO_RPMARES_ADJ +!------------------------------------------------------------------------------ + +C DISCLAIMER +C +C This file was generated by TAMC version 5.3.2 +C +C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES +C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, +C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS +C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS. +C +C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION +C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS +C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT +C ALLOWED. +C +C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT +C info@FastOpt.com +C + subroutine adactcof( cat, an, adcat, adan, adgama ) +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + +C============================================== +C define parameters +C============================================== + integer nan + parameter ( nan = 3 ) + integer ncat + parameter ( ncat = 2 ) + +C============================================== +C define common blocks +C============================================== + common /actcofsv/ pname, xmsg, zm, zp + character*(16) :: pname = ' driver program name' + character*(120) :: xmsg = ' ' + real*8 :: zm(nan) = (/2.d0,1.d0,1.d0/) + real*8 :: zp(ncat) = (/1.d0,1.d0/) + +C============================================== +C define arguments +C============================================== + real*8 adan(nan) + real*8 adcat(ncat) + real*8 adgama(ncat,nan) + real*8 an(nan) + real*8 cat(ncat) + +C============================================== +C define local variables +C============================================== + real*8 adbgama(ncat,nan) + real*8 adf1(nan) + real*8 adf2(ncat) + real*8 adfgama + real*8 adi + real*8 adlgama0(ncat,nan) + real*8 adm(ncat,nan) + real*8 adsri + real*8 adta + real*8 adtc + real*8 adtexpv + real*8 adtrm + real*8 adtwoi + real*8 adtwosri + real*8 adx(ncat,nan) + real*8 ady(nan,ncat) + real*8 adzot1 + real*8 beta0(ncat,nan) + real*8 beta1(ncat,nan) + real*8 bgama(ncat,nan) + real*8 cgama(ncat,nan) + integer exit + real*8 f1(nan) + real*8 f2(ncat) + real*8 fgama + real*8 i + integer ian + integer icat + integer ip1 + integer ip2 + real*8 lgama0(ncat,nan) + real*8 m(ncat,nan) + real*8 sri + real*8 ta + real*8 tb + real*8 tc + real*8 texpv + real*8 trm + real*8 twoi + real*8 twosri + real*8 v1(ncat,nan) + real*8 v2(ncat,nan) + real*8 x(ncat,nan) + real*8 y(nan,ncat) + real*8 zbar + real*8 zbar2 + real*8 zot1 + +C============================================== +C define data +C============================================== + data beta0(1,1)/2.98d-2/ + data beta1(1,1)/0.0d0/ + data cgama(1,1)/4.38d-2/ + data beta0(1,2)/1.2556d-1/ + data beta1(1,2)/2.8778d-1/ + data cgama(1,2)/-5.59d-3/ + data beta0(1,3)/2.0651d-1/ + data beta1(1,3)/5.556d-1/ + data cgama(1,3)/0.0d0/ + data beta0(2,1)/4.6465d-2/ + data beta1(2,1)/-0.54196d0/ + data cgama(2,1)/-1.2683d-3/ + data beta0(2,2)/-7.26224d-3/ + data beta1(2,2)/-1.168858d0/ + data cgama(2,2)/3.51217d-5/ + data beta0(2,3)/4.494d-2/ + data beta1(2,3)/2.3594d-1/ + data cgama(2,3)/-2.962d-3/ + data v1(1,1),v2(1,1)/2.0d0,1.0d0/ + data v1(2,1),v2(2,1)/2.0d0,1.0d0/ + data v1(1,2),v2(1,2)/1.0d0,1.0d0/ + data v1(2,2),v2(2,2)/1.0d0,1.0d0/ + data v1(1,3),v2(1,3)/1.0d0,1.0d0/ + data v1(2,3),v2(2,3)/1.0d0,1.0d0/ + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + do ip2 = 1, nan + do ip1 = 1, ncat + adbgama(ip1,ip2) = 0. + end do + end do + do ip1 = 1, nan + adf1(ip1) = 0. + end do + do ip1 = 1, ncat + adf2(ip1) = 0. + end do + adfgama = 0. + adi = 0. + do ip2 = 1, nan + do ip1 = 1, ncat + adlgama0(ip1,ip2) = 0. + end do + end do + do ip2 = 1, nan + do ip1 = 1, ncat + adm(ip1,ip2) = 0. + end do + end do + adsri = 0. + adta = 0. + adtc = 0. + adtexpv = 0. + adtrm = 0. + adtwoi = 0. + adtwosri = 0. + do ip2 = 1, nan + do ip1 = 1, ncat + adx(ip1,ip2) = 0. + end do + end do + do ip2 = 1, ncat + do ip1 = 1, nan + ady(ip1,ip2) = 0. + end do + end do + adzot1 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + exit = 0 + if (exit .eq. 0) then + i = 0.d0 + endif + do icat = 1, ncat + if (exit .eq. 0) then + i = i+cat(icat)*zp(icat)*zp(icat) + endif + end do + do ian = 1, nan + if (exit .eq. 0) then + i = i+an(ian)*zm(ian)*zm(ian) + endif + end do + if (exit .eq. 0) then + i = 0.5d0*i + endif + if (i .eq. 0.d0) then + if (exit .eq. 0) then + exit = 1 + endif + endif + if (exit .eq. 0) then + sri = sqrt(i) + twosri = 2.d0*sri + twoi = 2.d0*i + texpv = 1.d0-exp(-twosri)*(1.d0+twosri-twoi) + zot1 = 0.511d0*sri/(1.d0+sri) + fgama = -(0.392d0*(sri/(1.d0+1.2d0*sri)+2.d0/1.2d0*log(1.d0+ + $1.2d0*sri))) + do icat = 1, ncat + do ian = 1, nan + bgama(icat,ian) = 2.d0*beta0(icat,ian)+2.d0*beta1(icat,ian)/ + $(4.d0*i)*texpv + m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian) + $)**(1.d0/(v1(icat,ian)+v2(icat,ian))) + lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*2.d0* + $v1(icat,ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, + $ian)+m(icat,ian)*m(icat,ian)*2.d0*(v1(icat,ian)*v2(icat,ian))** + $1.5d0/(v1(icat,ian)+v2(icat,ian))*cgama(icat,ian))/2.302585093d0 + end do + end do + do ian = 1, nan + do icat = 1, ncat + zbar = (zp(icat)+zm(ian))*0.5d0 + zbar2 = zbar*zbar + y(ian,icat) = zbar2*an(ian)/i + x(icat,ian) = zbar2*cat(icat)/i + end do + end do + do ian = 1, nan + f1(ian) = 0.d0 + do icat = 1, ncat + f1(ian) = f1(ian)+x(icat,ian)*lgama0(icat,ian)+zot1*zp(icat) + $*zm(ian)*x(icat,ian) + end do + end do + do icat = 1, ncat + f2(icat) = 0.d0 + do ian = 1, nan + f2(icat) = f2(icat)+y(ian,icat)*lgama0(icat,ian)+zot1* + $zp(icat)*zm(ian)*y(ian,icat) + end do + end do + do ian = 1, nan + adta = 0. + adtc = 0. + adtrm = 0. + do icat = 1, ncat + adta = 0. + adtc = 0. + adtrm = 0. + ta = -(zot1*zp(icat)*zm(ian)) + tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian)) + tc = f2(icat)/zp(icat)+f1(ian)/zm(ian) + trm = ta+tb*tc + if (trm .gt. 30.d0) then + adgama(icat,ian) = 0. + else + adtrm = adtrm+adgama(icat,ian)*10.d0**trm*dlog(10.d0) + adgama(icat,ian) = 0. + endif + adta = adta+adtrm + adtc = adtc+adtrm*tb + adtrm = 0. + adf1(ian) = adf1(ian)+adtc/zm(ian) + adf2(icat) = adf2(icat)+adtc/zp(icat) + adtc = 0. + adzot1 = adzot1-adta*zp(icat)*zm(ian) + adta = 0. + end do + end do + do icat = 1, ncat + do ian = 1, nan + adlgama0(icat,ian) = adlgama0(icat,ian)+adf2(icat)*y(ian, + $icat) + ady(ian,icat) = ady(ian,icat)+adf2(icat)*(lgama0(icat,ian)+ + $zot1*zp(icat)*zm(ian)) + adzot1 = adzot1+adf2(icat)*zp(icat)*zm(ian)*y(ian,icat) + end do + adf2(icat) = 0. + end do + do ian = 1, nan + do icat = 1, ncat + adlgama0(icat,ian) = adlgama0(icat,ian)+adf1(ian)*x(icat, + $ian) + adx(icat,ian) = adx(icat,ian)+adf1(ian)*(lgama0(icat,ian)+ + $zot1*zp(icat)*zm(ian)) + adzot1 = adzot1+adf1(ian)*zp(icat)*zm(ian)*x(icat,ian) + end do + adf1(ian) = 0. + end do + do ian = 1, nan + do icat = 1, ncat + zbar = (zp(icat)+zm(ian))*0.5d0 + zbar2 = zbar*zbar + adcat(icat) = adcat(icat)+adx(icat,ian)*(zbar2/i) + adi = adi-adx(icat,ian)*(zbar2*cat(icat)/(i*i)) + adx(icat,ian) = 0. + adan(ian) = adan(ian)+ady(ian,icat)*(zbar2/i) + adi = adi-ady(ian,icat)*(zbar2*an(ian)/(i*i)) + ady(ian,icat) = 0. + end do + end do + do icat = 1, ncat + do ian = 1, nan + bgama(icat,ian) = 2.d0*beta0(icat,ian)+2.d0*beta1(icat,ian)/ + $(4.d0*i)*texpv + m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian) + $)**(1.d0/(v1(icat,ian)+v2(icat,ian))) + adbgama(icat,ian) = adbgama(icat,ian)+adlgama0(icat,ian)* + $(m(icat,ian)*(2.d0*v1(icat,ian)*v2(icat,ian)/(v1(icat,ian)+ + $v2(icat,ian)))/2.302585093d0) + adfgama = adfgama+adlgama0(icat,ian)*(zp(icat)*zm(ian)/ + $2.302585093d0) + adm(icat,ian) = adm(icat,ian)+adlgama0(icat,ian)*((2.d0* + $v1(icat,ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, + $ian)+2*m(icat,ian)*2.d0*(v1(icat,ian)*v2(icat,ian))**1.5d0/ + $(v1(icat,ian)+v2(icat,ian))*cgama(icat,ian))/2.302585093d0) + adlgama0(icat,ian) = 0. + + ! The next two IF statements added to avoid divide by zero + ! segmentation fault (dkh) + IF (adm(icat,ian)*cat(icat)**v1(icat,ian)* + $v2(icat,ian)*an(ian) .NE. 0.D0 .AND. + $ (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian)) .NE. 0.D0) + $ adan(ian) = adan(ian)+adm(icat,ian)*cat(icat)**v1(icat,ian)* + $v2(icat,ian)*an(ian)**(v2(icat,ian)-1)*1.d0/(v1(icat,ian)+v2(icat, + $ian))*(cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))**(1.d0/ + $(v1(icat,ian)+v2(icat,ian))-1) + IF (adm(icat,ian)*v1(icat,ian)* + $cat(icat) .NE. 0.D0 .AND. (cat(icat)**v1(icat,ian)*an(ian)** + $v2(icat,ian)) .NE. 0.D0) + $ adcat(icat) = adcat(icat)+adm(icat,ian)*v1(icat,ian)* + $cat(icat)**(v1(icat,ian)-1)*an(ian)**v2(icat,ian)*1.d0/(v1(icat, + $ian)+v2(icat,ian))*(cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian)) + $**(1.d0/(v1(icat,ian)+v2(icat,ian))-1) + adm(icat,ian) = 0. + adi = adi-adbgama(icat,ian)*8*beta1(icat,ian)/(16*i*i)*texpv + adtexpv = adtexpv+adbgama(icat,ian)*(2.d0*beta1(icat,ian)/ + $(4.d0*i)) + adbgama(icat,ian) = 0. + end do + end do + adsri = adsri-0.392d0*adfgama*(1/(1.d0+1.2d0*sri)-1.2d0*sri/ + $((1.d0+1.2d0*sri)*(1.d0+1.2d0*sri))+2*(1./(1.d0+1.2d0*sri))) + adfgama = 0. + adsri = adsri+adzot1*(0.511d0/(1.d0+sri)-0.511d0*sri/((1.d0+sri) + $*(1.d0+sri))) + adzot1 = 0. + adtwoi = adtwoi+adtexpv*exp(-twosri) + adtwosri = adtwosri-adtexpv*(exp(-twosri)-(1.d0+twosri-twoi)* + $exp(-twosri)) + adtexpv = 0. + adi = adi+2*adtwoi + adtwoi = 0. + adsri = adsri+2*adtwosri + adtwosri = 0. + adi = adi+adsri*(1./(2.*sqrt(i))) + adsri = 0. + endif + exit = 0 + if (i .eq. 0.d0) then + if (exit .eq. 0) then + do ian = 1, nan + do icat = 1, ncat + adgama(icat,ian) = 0. + end do + end do + endif + endif + if (exit .eq. 0) then + adi = 0.5d0*adi + endif + do ian = 1, nan + if (exit .eq. 0) then + adan(ian) = adan(ian)+adi*zm(ian)*zm(ian) + endif + end do + do icat = 1, ncat + if (exit .eq. 0) then + adcat(icat) = adcat(icat)+adi*zp(icat)*zp(icat) + endif + end do + + end SUBROUTINE ADACTCOF +!----------------------------------------------------------------------------- + + subroutine adawater( irhx, mso4, mnh4, mno3, admso4, admnh4, + $admno3, adwh2o ) + + ! Reference other f90 modules + USE RPMARES_MOD, ONLY : POLY4, POLY6 + +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + +C============================================== +C define parameters +C============================================== + real*8 mwnh4 + parameter ( mwnh4 = 18.0985d0 ) + real*8 mwso4 + parameter ( mwso4 = 96.0636d0 ) + real*8 mw2 + parameter ( mw2 = mwso4+2.d0*mwnh4 ) + real*8 mwno3 + parameter ( mwno3 = 62.0649d0 ) + real*8 mwano3 + parameter ( mwano3 = mwno3+mwnh4 ) + +C============================================== +C define common blocks +C============================================== + common /awatersv/ c0, c1, c15, c2, kno3, kso4 + real*8 :: c0(4) = (/0.798079d0,-1.574367d0,2.536686d0,- + $1.735297d0/) + real*8 :: c1(4) = (/0.9995178d0,-0.7952896d0,0.99683673d0,- + $1.143874d0/) + real*8 :: c15(4) = (/1.697092d0,-4.045936d0,5.833688d0,- + $3.463783d0/) + real*8 :: c2(4) = (/2.085067d0,-6.024139d0,8.967967d0,- + $5.002934d0/) + real*8 :: kno3(6) = (/0.2906d0,6.83665d0,-26.9093d0,46.6983d0,- + $38.803d0,11.8837d0/) + real*8 :: kso4(6) = (/2.27515d0,-11.147d0,36.3369d0,-64.2134d0, + $56.8341d0,-20.0953d0/) + +C============================================== +C define arguments +C============================================== + real*8 admnh4 + real*8 admno3 + real*8 admso4 + real*8 adwh2o + integer irhx + real*8 mnh4 + real*8 mno3 + real*8 mso4 + +C============================================== +C define local variables +C============================================== + real*8 adawc + real*8 adtnh4 + real*8 adtno3 + real*8 adtso4 + real*8 adx + real*8 ady + real*8 ady40 + real*8 adyc + real*8 aw + real*8 awc + integer irh + real*8 mfs0 + real*8 mfs1 + real*8 mfs15 + real*8 mfsno3 + real*8 mfsso4 + real*8 tnh4 + real*8 tno3 + real*8 tso4 + real*8 x + real*8 y + real*8 y0 + real*8 y1 + real*8 y140 + real*8 y15 + real*8 y1540 + real*8 y2 + real*8 y3 + real*8 y40 + real*8 yc + +!C============================================== +!C define external procedures and functions +!C============================================== +! double precision poly4 +! external poly4 +! double precision poly6 +! external poly6 +! +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adawc = 0. + adtnh4 = 0. + adtno3 = 0. + adtso4 = 0. + adx = 0. + ady = 0. + ady40 = 0. + adyc = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + irh = irhx + irh = max(1,irh) + irh = min(irh,100) + aw = dble(irh)/100.d0 + tso4 = max(mso4,0.d0) + tnh4 = max(mnh4,0.d0) + tno3 = max(mno3,0.d0) + x = 0.d0 + if (tso4 .gt. 0.d0) then + x = tnh4/tso4 + else + if (tno3 .gt. 0.d0 .and. tnh4 .gt. 0.d0) then + x = 10.d0 + endif + endif + if (x .lt. 1.d0) then + mfs0 = poly4(c0,aw) + mfs1 = poly4(c1,aw) + y0 = (1.d0-mfs0)/mfs0 + y1 = (1.d0-mfs1)/mfs1 + y = (1.d0-x)*y0+x*y1 + else if (x .lt. 1.5d0) then + if (irh .ge. 40) then + mfs1 = poly4(c1,aw) + mfs15 = poly4(c15,aw) + y1 = (1.d0-mfs1)/mfs1 + y15 = (1.d0-mfs15)/mfs15 + y = 2.d0*(y1*(1.5d0-x)+y15*(x-1.d0)) + else + awc = 0.8d0*(x-1.d0) + y = 0.d0 + if (aw .ge. awc) then + mfs1 = poly4(c1,0.4d0) + mfs15 = poly4(c15,0.4d0) + y140 = (1.d0-mfs1)/mfs1 + y1540 = (1.d0-mfs15)/mfs15 + y40 = 2.d0*(y140*(1.5d0-x)+y1540*(x-1.d0)) + yc = 2.d0*y1540*(x-1.d0) + y = y40-(y40-yc)*(0.4d0-aw)/(0.4d0-awc) + endif + endif + else if (x .lt. 2.d0) then + y = 0.d0 + if (irh .ge. 40) then + mfs15 = poly4(c15,aw) + y15 = (1.d0-mfs15)/mfs15 + mfsso4 = poly6(kso4,aw) + y2 = (1.d0-mfsso4)/mfsso4 + y = 2.d0*(y15*(2.d0-x)+y2*(x-1.5d0)) + endif + else + y2 = 0.d0 + y3 = 0.d0 + if (irh .ge. 40) then + mfsso4 = poly6(kso4,aw) + mfsno3 = poly6(kno3,aw) + y2 = (1.d0-mfsso4)/mfsso4 + y3 = (1.d0-mfsno3)/mfsno3 + endif + endif + if (x .lt. 2.d0) then + adtnh4 = adtnh4+adwh2o*y*mwnh4 + adtso4 = adtso4+adwh2o*y*mwso4 + ady = ady+adwh2o*(tso4*mwso4+mwnh4*tnh4) + adwh2o = 0. + else + adtno3 = adtno3+adwh2o*y3*mwano3 + adtso4 = adtso4+adwh2o*y2*mw2 + adwh2o = 0. + endif + if (x .lt. 1.d0) then + adx = adx+ady*((-y0)+y1) + ady = 0. + else if (x .lt. 1.5d0) then + if (irh .ge. 40) then + adx = adx+2.d0*ady*((-y1)+y15) + ady = 0. + else + if (aw .ge. awc) then + adawc = adawc-ady*((y40-yc)*(0.4d0-aw)/((0.4d0-awc)*(0.4d0- + $awc))) + ady40 = ady40+ady*(1-(0.4d0-aw)/(0.4d0-awc)) + adyc = adyc+ady*((0.4d0-aw)/(0.4d0-awc)) + ady = 0. + adx = adx+2*adyc*y1540 + adyc = 0. + adx = adx+2.d0*ady40*((-y140)+y1540) + ady40 = 0. + endif + adx = adx+0.8d0*adawc + adawc = 0. + endif + else if (x .lt. 2.d0) then + if (irh .ge. 40) then + adx = adx+2.d0*ady*((-y15)+y2) + ady = 0. + endif + endif + if (tso4 .gt. 0.d0) then + adtnh4 = adtnh4+adx/tso4 + adtso4 = adtso4-adx*(tnh4/(tso4*tso4)) + adx = 0. + endif + admno3 = admno3+adtno3*(0.5+sign(0.5d0,mno3-0.d0)) + adtno3 = 0. + admnh4 = admnh4+adtnh4*(0.5+sign(0.5d0,mnh4-0.d0)) + adtnh4 = 0. + admso4 = admso4+adtso4*(0.5+sign(0.5d0,mso4-0.d0)) + adtso4 = 0. + + end SUBROUTINE ADAWATER +!----------------------------------------------------------------------------- + + subroutine adrpmares_11( in, par, adin, adout, + & I, J, L ) + + ! References to f90 modules + USE CHECKPT_MOD + USE RPMARES_MOD, ONLY : CUBIC, AWATER, ACTCOF + +# include "CMN_SIZE" ! Size params + +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + +C============================================== +C define parameters +C============================================== + real*8 floor + parameter ( floor = 1.d-30 ) + real*8 mwhno3 + parameter ( mwhno3 = 63.01287d0 ) + real*8 mwnh3 + parameter ( mwnh3 = 17.03061d0 ) + real*8 mwnh4 + parameter ( mwnh4 = 18.03858d0 ) + real*8 mwno3 + parameter ( mwno3 = 62.0049d0 ) + real*8 mwso4 + parameter ( mwso4 = 96.0576d0 ) + +C============================================== +C define common blocks +C============================================== + +C============================================== +C define arguments +C============================================== + double precision adin(5) + double precision adout(8) + double precision in(5) + double precision par(2) + INTEGER :: I, J, L + +C============================================== +C define local variables +C============================================== + real*8 a0 + real*8 a1 + real*8 a2 + real*8 ada0 + real*8 ada1 + real*8 ada2 + real*8 adah2o + real*8 adahso4 + real*8 adan(3) + real*8 adanh4 + real*8 adano3 + real*8 adano3_in + real*8 adaso4 + real*8 adcat(2) + real*8 adcrutes(3) + real*8 aderor + real aderorh + real*8 adgamahat + real*8 adgamana + real*8 adgamas1 + real*8 adgamas2 + real*8 adgamold + real*8 adgams(2,3) + real*8 adgnh3 + real*8 adgno3 + real*8 adhplus + real*8 admhso4 + real*8 admna + real*8 admnh4 + real*8 admso4 + real*8 adrk2sa + real*8 adrkna + real*8 adrknwet + real*8 adso4 + real*8 adt21 + real*8 adtmasshno3 + real*8 adtnh4 + real*8 adtno3 + real*8 adtso4 + real*8 adwh2o + real*8 adxno3 + real*8 adynh4 + real*8 adzso4 + real*8 ah2o + real*8 an(3) + real*8 anh4 + real*8 ano3 + real*8 cat(2) + real*8 crutes(3) + real*8 eror + real*8 erorh + integer exit + real*8 gamaab + real*8 gamahat + real*8 gamana + real*8 gamas1 + real*8 gamas2 + real*8 gamas2h + real*8 gamold + real*8 gams(2,3) + real*8 gnh3 + real*8 gno3 + real*8 hplus + integer ip1 + integer ip2 + integer irh + real*8 k2sa + real*8 kna + real*8 mhso4 + real*8 mna + real*8 mnh4 + real*8 molnu + real*8 mso4 + integer nnn + integer nnn1 + integer nr + real*8 phibar + real*8 rh + real*8 rk2sa + real*8 rkna + real*8 rknwet + real*8 so4 + real*8 t1 + real*8 t2 + real*8 t21 + real*8 t3 + real*8 t4 + real*8 t6 + real*8 temp + real*8 tmasshno3 + real*8 tnh4 + real*8 tno3 + real*8 toler2 + real*8 tso4 + real*8 wh2o + real*8 xno3 + real*8 ynh4 + real*8 zso4 + +C---------------------------------------------- +C SAVE ARGUMENTS +C---------------------------------------------- + !erorh = eror + erorh = 0. + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + ada0 = 0. + ada1 = 0. + ada2 = 0. + adah2o = 0. + adahso4 = 0. + do ip1 = 1, 3 + adan(ip1) = 0. + end do + adanh4 = 0. + adano3 = 0. + adano3_in = 0. + adaso4 = 0. + do ip1 = 1, 2 + adcat(ip1) = 0. + end do + do ip1 = 1, 3 + adcrutes(ip1) = 0. + end do + aderor = 0. + adgamahat = 0. + adgamana = 0. + adgamas1 = 0. + adgamas2 = 0. + adgamold = 0. + do ip2 = 1, 3 + do ip1 = 1, 2 + adgams(ip1,ip2) = 0. + end do + end do + adgnh3 = 0. + adgno3 = 0. + adhplus = 0. + admhso4 = 0. + admna = 0. + admnh4 = 0. + admso4 = 0. + adrk2sa = 0. + adrkna = 0. + adrknwet = 0. + adso4 = 0. + adt21 = 0. + adtmasshno3 = 0. + adtnh4 = 0. + adtno3 = 0. + adtso4 = 0. + adwh2o = 0. + adxno3 = 0. + adynh4 = 0. + adzso4 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + so4 = in(1) + gno3 = in(2) + gnh3 = in(3) + ano3 = in(4) + anh4 = in(5) + rh = par(1) + temp = par(2) + tso4 = max(floor,so4/mwso4) + tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3) + tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4) + tmasshno3 = max(0.d0,gno3+ano3) + irh = nint(100.*rh) + irh = max(1,irh) + irh = min(99,irh) + t6 = 8.2d-11*temp + t1 = 298.d0/temp + t2 = log(t1) + t3 = t1-1.d0 + t4 = 1.d0+t2-t1 + kna = 2511000.d0*exp(29.17d0*t3+16.83d0*t4)*t6 + k2sa = 0.01015d0*exp(8.85d0*t3+25.14d0*t4) + call awater( irh,tso4,tnh4,tno3,ah2o ) + wh2o = 0.001d0*ah2o + zso4 = tso4/wh2o + gamaab = 1.d0 + mnh4 = tnh4/wh2o + ynh4 = tnh4 + adgnh3 = adgnh3+adout(8) + adout(8) = 0.d0 + adgno3 = adgno3+adout(7) + adout(7) = 0.d0 + adso4 = adso4+adout(6) + adout(6) = 0.d0 + adanh4 = adanh4+adout(5) + adout(5) = 0.d0 + adah2o = adah2o+adout(4) + adout(4) = 0.d0 + adano3 = adano3+adout(3) + adout(3) = 0.d0 + adahso4 = adahso4+adout(2) + adout(2) = 0.d0 + adaso4 = adaso4+adout(1) + adout(1) = 0.d0 + do nnn = nitr_max(I,J,L), 1, -1 + eror = erorh + exit = 0 + call awater( irh,tso4,tnh4,tno3,ah2o ) + wh2o = 0.001d0*ah2o + gamana = 1.d0 + gamas1 = 1.d0 + gamas2 = 1.d0 + gamold = 1.d0 + + !===================================================================== + ! CHECKPOINT + ! The adjoint calculation needs the variables error,exit,gamana,gamas1, + ! gamas2,gamold and wh2o at iteration nnn-1. Rather than recompute, + ! use the values saved durring the forward run, but only if nnn-1 > 0 + !===================================================================== + IF (nnn-1 .gt. 0) THEN + eror = eror_fwd(I,J,L,nnn-1) + exit = exit_fwd(I,J,L,nnn-1) + gamana = gamana_fwd(I,J,L,nnn-1) + gamas1 = gamas1_fwd(I,J,L,nnn-1) + gamas2 = gamas2_fwd(I,J,L,nnn-1) + gamold = gamold_fwd(I,J,L,nnn-1) + wh2o = wh2o_fwd(I,J,L,nnn-1) + ENDIF + +! do nnn1 = 1, nnn-1 +! if (exit .eq. 0) then +! rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1) +! rkna = kna/(gamana*gamana) +! rknwet = rkna*wh2o +! t21 = zso4-mnh4 +! a2 = rk2sa+rknwet-t21 +! a1 = rk2sa*rknwet-t21*(rk2sa+rknwet)-rk2sa*zso4-rkna*tno3 +! a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3) +! call cubic( a2,a1,a0,nr,crutes ) +! hplus = crutes(1) +! mso4 = rk2sa*zso4/(hplus+rk2sa) +! mhso4 = max(1.d-10,zso4-mso4) +! mna = rkna*tno3/(hplus+rknwet) +! mna = max(0.,mna) +! mna = min(mna,tno3/wh2o) +! xno3 = mna*wh2o +! call awater( irh,tso4,ynh4,xno3,ah2o ) +! wh2o = 0.001d0*ah2o +! cat(1) = hplus +! cat(2) = mnh4 +! an(1) = mso4 +! an(2) = mna +! an(3) = mhso4 +! call actcof( cat,an,gams,molnu,phibar ) +! gamana = gams(1,2) +! gamas1 = gams(1,1) +! gamas2 = gams(1,3) +! gamahat = gamas2*gamas2/(gamaab*gamaab) +! eror = abs(gamold-gamahat)/gamold +! gamold = gamahat +! endif +! if (eror .le. toler2) then +! exit = 11 +! endif +! end do + gamas2h = gamas2 + if (exit .eq. 0) then + rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1) + rkna = kna/(gamana*gamana) + rknwet = rkna*wh2o + t21 = zso4-mnh4 + a2 = rk2sa+rknwet-t21 + a1 = rk2sa*rknwet-t21*(rk2sa+rknwet)-rk2sa*zso4-rkna*tno3 + a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3) + call cubic( a2,a1,a0,nr,crutes ) + hplus = crutes(1) + mso4 = rk2sa*zso4/(hplus+rk2sa) + mhso4 = max(1.d-10,zso4-mso4) + mna = rkna*tno3/(hplus+rknwet) + mna = max(0.,mna) + mna = min(mna,tno3/wh2o) + xno3 = mna*wh2o + ano3 = mna*wh2o*mwno3 + cat(1) = hplus + cat(2) = mnh4 + an(1) = mso4 + an(2) = mna + an(3) = mhso4 + call actcof( cat,an,gams,molnu,phibar ) + gamas2 = gams(1,3) + gamahat = gamas2*gamas2/(gamaab*gamaab) + adgamahat = adgamahat+adgamold + adgamold = 0. + aderorh = aderor/gamold + adgamold = adgamold-aderor*(abs(gamold-gamahat)/(gamold* + $gamold)) + adgamahat = adgamahat-aderorh*sign(1.d0,gamold-gamahat) + adgamold = adgamold+aderorh*sign(1.d0,gamold-gamahat) + aderor = 0. + adgamas2 = adgamas2+adgamahat*(2*gamas2/(gamaab*gamaab)) + adgamahat = 0. + adgams(1,3) = adgams(1,3)+adgamas2 + adgamas2 = 0. + adgams(1,1) = adgams(1,1)+adgamas1 + adgamas1 = 0. + adgams(1,2) = adgams(1,2)+adgamana + adgamana = 0. + call adactcof( cat,an,adcat,adan,adgams ) + admhso4 = admhso4+adan(3) + adan(3) = 0. + admna = admna+adan(2) + adan(2) = 0. + admso4 = admso4+adan(1) + adan(1) = 0. + admnh4 = admnh4+adcat(2) + adcat(2) = 0. + adhplus = adhplus+adcat(1) + adcat(1) = 0. + adah2o = adah2o+0.001d0*adwh2o + adwh2o = 0. + call adawater( irh,tso4,ynh4,xno3,adtso4,adynh4,adxno3,adah2o + $) + admhso4 = admhso4+adahso4*wh2o*mwso4 + adwh2o = adwh2o+adahso4*mhso4*mwso4 + adahso4 = 0. + admso4 = admso4+adaso4*wh2o*mwso4 + adwh2o = adwh2o+adaso4*mso4*mwso4 + adaso4 = 0. + adano3 =adano3-adgno3*(0.5-sign(0.5d0,floor-(tmasshno3-ano3))) + adtmasshno3 = adtmasshno3+adgno3*(0.5-sign(0.5d0,floor- + $(tmasshno3-ano3))) + adgno3 = 0. + admna = admna+adano3*wh2o*mwno3 + adwh2o = adwh2o+adano3*mna*mwno3 + adano3 = 0. + admna = admna+adxno3*wh2o + adwh2o = adwh2o+adxno3*mna + adxno3 = 0. + mna = rkna*tno3/(hplus+rknwet) + mna = max(0.,mna) + adtno3 = adtno3+admna*((0.5-sign(0.5d0,tno3/wh2o-mna))/wh2o) + adwh2o = adwh2o-admna*(0.5-sign(0.5d0,tno3/wh2o-mna))*(tno3/ + $(wh2o*wh2o)) + admna = admna*(0.5+sign(0.5d0,tno3/wh2o-mna)) + mna = rkna*tno3/(hplus+rknwet) + admna = admna*(0.5-sign(0.5d0,0.-mna)) + adhplus = adhplus-admna*(rkna*tno3/((hplus+rknwet)*(hplus+ + $rknwet))) + adrkna = adrkna+admna*(tno3/(hplus+rknwet)) + adrknwet = adrknwet-admna*(rkna*tno3/((hplus+rknwet)*(hplus+ + $rknwet))) + adtno3 = adtno3+admna*(rkna/(hplus+rknwet)) + admna = 0. + admso4 = admso4-admhso4*(0.5-sign(0.5d0,1.d-10-(zso4-mso4))) + adzso4 = adzso4+admhso4*(0.5-sign(0.5d0,1.d-10-(zso4-mso4))) + admhso4 = 0. + adhplus = adhplus-admso4*(rk2sa*zso4/((hplus+rk2sa)*(hplus+ + $rk2sa))) + adrk2sa = adrk2sa+admso4*(zso4/(hplus+rk2sa)-rk2sa*zso4/ + $((hplus+rk2sa)*(hplus+rk2sa))) + adzso4 = adzso4+admso4*(rk2sa/(hplus+rk2sa)) + admso4 = 0. + adcrutes(1) = adcrutes(1)+adhplus + adhplus = 0. + call adcubic( a2,a1,a0,ada2,ada1,ada0,adcrutes ) + adrk2sa = adrk2sa-ada0*(rknwet*(t21+zso4)+rkna*tno3) + adrkna = adrkna-ada0*rk2sa*tno3 + adrknwet = adrknwet-ada0*rk2sa*(t21+zso4) + adt21 = adt21-ada0*rk2sa*rknwet + adtno3 = adtno3-ada0*rk2sa*rkna + adzso4 = adzso4-ada0*rk2sa*rknwet + ada0 = 0. + adrk2sa = adrk2sa+ada1*(rknwet-t21-zso4) + adrkna = adrkna-ada1*tno3 + adrknwet = adrknwet+ada1*(rk2sa-t21) + adt21 = adt21-ada1*(rk2sa+rknwet) + adtno3 = adtno3-ada1*rkna + adzso4 = adzso4-ada1*rk2sa + ada1 = 0. + adrk2sa = adrk2sa+ada2 + adrknwet = adrknwet+ada2 + adt21 = adt21-ada2 + ada2 = 0. + admnh4 = admnh4-adt21 + adzso4 = adzso4+adt21 + adt21 = 0. + adrkna = adrkna+adrknwet*wh2o + adwh2o = adwh2o+adrknwet*rkna + adrknwet = 0. + adgamana = adgamana-adrkna*(2*kna*gamana/(gamana*gamana* + $gamana*gamana)) + adrkna = 0. + gamas2 = gamas2h + adgamas1 = adgamas1-adrk2sa*(3*k2sa*gamas2*gamas2*gamas1* + $gamas1/(gamas1*gamas1*gamas1*gamas1*gamas1*gamas1)) + adgamas2 = adgamas2+adrk2sa*(2*k2sa*gamas2/(gamas1*gamas1* + $gamas1)) + adrk2sa = 0. + endif + end do + adtnh4 = adtnh4+adynh4 + adynh4 = 0. + call awater( irh,tso4,tnh4,tno3,ah2o ) + wh2o = 0.001d0*ah2o + adtnh4 = adtnh4+admnh4/wh2o + adwh2o = adwh2o-admnh4*(tnh4/(wh2o*wh2o)) + admnh4 = 0. + adtso4 = adtso4+adzso4/wh2o + adwh2o = adwh2o-adzso4*(tso4/(wh2o*wh2o)) + adzso4 = 0. + adgnh3 = 0. + adano3 = adano3-adgno3 + adtmasshno3 = adtmasshno3+adgno3 + adgno3 = 0. + adano3_in = adano3_in+adano3 + adano3 = 0. + adtnh4 = adtnh4+adanh4*mwnh4 + adanh4 = 0. + adtso4 = adtso4+adahso4*mwso4 + adahso4 = 0. + adaso4 = 0. + adah2o = adah2o+0.001d0*adwh2o + adwh2o = 0. + call adawater( irh,tso4,tnh4,tno3,adtso4,adtnh4,adtno3,adah2o ) + ano3 = in(4) + adano3 = adano3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3))) + adgno3 = adgno3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3))) + adtmasshno3 = 0. + adano3 = adano3+adano3_in + adano3_in = 0. + adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh4) + adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh3) + adtnh4 = 0. + adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwno3) + adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwhno3) + adtno3 = 0. + adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4) + adtso4 = 0. + adin(5) = adin(5)+adanh4 + adanh4 = 0. + adin(4) = adin(4)+adano3 + adano3 = 0. + adin(3) = adin(3)+adgnh3 + adgnh3 = 0. + adin(2) = adin(2)+adgno3 + adgno3 = 0. + adin(1) = adin(1)+adso4 + adso4 = 0. + + end SUBROUTINE ADRPMARES_11 +!----------------------------------------------------------------------------- + + +C DISCLAIMER +C +C This file was generated by TAMC version 5.3.2 +C +C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES +C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, +C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS +C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS. +C +C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION +C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS +C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT +C ALLOWED. +C +C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT +C info@FastOpt.com +C + subroutine adrpmares_12( in, par, adin, adout, + & I, J, L ) + +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + +C============================================== +C define parameters +C============================================== + real*8 floor + parameter ( floor = 1.d-30 ) + real*8 mwhno3 + parameter ( mwhno3 = 63.01287d0 ) + real*8 mwnh3 + parameter ( mwnh3 = 17.03061d0 ) + real*8 mwnh4 + parameter ( mwnh4 = 18.03858d0 ) + real*8 mwno3 + parameter ( mwno3 = 62.0049d0 ) + real*8 mwso4 + parameter ( mwso4 = 96.0576d0 ) + +C============================================== +C define common blocks +C============================================== +C============================================== +C define arguments +C============================================== + double precision adin(5) + double precision adout(8) + double precision in(5) + double precision par(2) + INTEGER :: I, J, L + +C============================================== +C define local variables +C============================================== + real*8 adah2o + real*8 adanh4 + real*8 adano3 + real*8 adano3_in + real*8 adaso4 + real*8 adgnh3 + real*8 adgno3 + real*8 adgno3_in + real*8 adso4 + real*8 adtnh4 + real*8 adtno3 + real*8 adtso4 + real*8 anh4 + real*8 ano3 + real*8 gnh3 + real*8 gno3 + integer irh + real*8 rh + real*8 so4 + real*8 tnh4 + real*8 tno3 + real*8 tso4 + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adah2o = 0. + adanh4 = 0. + adano3 = 0. + adano3_in = 0. + adaso4 = 0. + adgnh3 = 0. + adgno3 = 0. + adgno3_in = 0. + adso4 = 0. + adtnh4 = 0. + adtno3 = 0. + adtso4 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + so4 = in(1) + gno3 = in(2) + gnh3 = in(3) + ano3 = in(4) + anh4 = in(5) + rh = par(1) + tso4 = max(floor,so4/mwso4) + tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3) + tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4) + irh = nint(100.*rh) + irh = max(1,irh) + irh = min(99,irh) + adgnh3 = adgnh3+adout(8) + adout(8) = 0.d0 + adgno3 = adgno3+adout(7) + adout(7) = 0.d0 + adso4 = adso4+adout(6) + adout(6) = 0.d0 + adanh4 = adanh4+adout(5) + adout(5) = 0.d0 + adah2o = adah2o+adout(4) + adout(4) = 0.d0 + adano3 = adano3+adout(3) + adout(3) = 0.d0 + adout(2) = 0.d0 + adaso4 = adaso4+adout(1) + adout(1) = 0.d0 + call adawater( irh,tso4,tnh4,tno3,adtso4,adtnh4,adtno3,adah2o ) + adtso4 = adtso4+adaso4*mwso4 + adaso4 = 0. + adano3_in = adano3_in+adano3 + adano3 = 0. + adgno3_in = adgno3_in+adgno3 + adgno3 = 0. + adgnh3 = 0. + adtnh4 = adtnh4+adanh4*mwnh4 + adanh4 = 0. + adano3 = adano3+adano3_in + adano3_in = 0. + adgno3 = adgno3+adgno3_in + adgno3_in = 0. + adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh4) + adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh3) + adtnh4 = 0. + adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwno3) + adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwhno3) + adtno3 = 0. + adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4) + adtso4 = 0. + adin(5) = adin(5)+adanh4 + adanh4 = 0. + adin(4) = adin(4)+adano3 + adano3 = 0. + adin(3) = adin(3)+adgnh3 + adgnh3 = 0. + adin(2) = adin(2)+adgno3 + adgno3 = 0. + adin(1) = adin(1)+adso4 + adso4 = 0. + + end SUBROUTINE ADRPMARES_12 + + +C DISCLAIMER +C +C This file was generated by TAMC version 5.3.2 +C +C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES +C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, +C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS +C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS. +C +C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION +C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS +C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT +C ALLOWED. +C +C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT +C info@FastOpt.com +C + subroutine adrpmares_2( in, par, adin, adout, + & I, J, L ) + +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + +C============================================== +C define parameters +C============================================== + real*8 floor + parameter ( floor = 1.d-30 ) + real*8 mwno3 + parameter ( mwno3 = 62.0049d0 ) + real*8 minno3 + parameter ( minno3 = 1.d-6/mwno3 ) + real*8 mwso4 + parameter ( mwso4 = 96.0576d0 ) + real*8 minso4 + parameter ( minso4 = 1.d-6/mwso4 ) + real*8 mwhno3 + parameter ( mwhno3 = 63.01287d0 ) + +C============================================== +C define arguments +C============================================== + double precision adin(5) + double precision adout(8) + double precision in(5) + double precision par(2) + INTEGER :: I, J, L + +C============================================== +C define local variables +C============================================== + real*8 adanh4 + real*8 adano3 + real*8 adaso4 + real*8 adgnh3 + real*8 adgno3 + real*8 adso4 + real*8 adtno3 + real*8 adtso4 + real*8 anh4 + real*8 ano3 + real*8 aso4 + integer exit + real*8 gnh3 + real*8 gno3 + real*8 rh + real*8 so4 + real*8 tno3 + real*8 tso4 + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adanh4 = 0. + adano3 = 0. + adaso4 = 0. + adgnh3 = 0. + adgno3 = 0. + adso4 = 0. + adtno3 = 0. + adtso4 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + so4 = in(1) + gno3 = in(2) + gnh3 = in(3) + ano3 = in(4) + anh4 = in(5) + rh = par(1) + aso4 = 0.d0 + exit = 0 + if (rh .lt. 0.01) then + exit = 1 + endif + if (exit .eq. 0) then + tso4 = max(floor,so4/mwso4) + aso4 = so4 + tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3) + endif + adgnh3 = adgnh3+adout(8) + adout(8) = 0.d0 + adgno3 = adgno3+adout(7) + adout(7) = 0.d0 + adso4 = adso4+adout(6) + adout(6) = 0.d0 + adanh4 = adanh4+adout(5) + adout(5) = 0.d0 + adout(4) = 0.d0 + adano3 = adano3+adout(3) + adout(3) = 0.d0 + adout(2) = 0.d0 + adaso4 = adaso4+adout(1) + adout(1) = 0.d0 + if (tso4 .lt. minso4 .and. tno3 .lt. minno3) then + if (exit .eq. 0) then + adgno3 = adgno3*(0.5-sign(0.5d0,floor-gno3)) + adgnh3 = adgnh3*(0.5-sign(0.5d0,floor-gnh3)) + adanh4 = adanh4*(0.5-sign(0.5d0,floor-anh4)) + adano3 = adano3*(0.5-sign(0.5d0,floor-ano3)) + adaso4 = adaso4*(0.5-sign(0.5d0,floor-aso4)) + endif + endif + if (exit .eq. 0) then + adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwno3) + adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwhno3) + adtno3 = 0. + adso4 = adso4+adaso4 + adaso4 = 0. + adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4) + adtso4 = 0. + endif + adin(5) = adin(5)+adanh4 + adanh4 = 0. + adin(4) = adin(4)+adano3 + adano3 = 0. + adin(3) = adin(3)+adgnh3 + adgnh3 = 0. + adin(2) = adin(2)+adgno3 + adgno3 = 0. + adin(1) = adin(1)+adso4 + adso4 = 0. + + end SUBROUTINE ADRPMARES_2 +!----------------------------------------------------------------------------- + +C DISCLAIMER +C +C This file was generated by TAMC version 5.3.2 +C +C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES +C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, +C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS +C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS. +C +C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION +C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS +C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT +C ALLOWED. +C +C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT +C info@FastOpt.com +C + subroutine adrpmares_3( in, par, adin, adout, + & I, J, L ) + +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + +C============================================== +C define parameters +C============================================== + real*8 floor + parameter ( floor = 1.d-30 ) + real*8 mwhno3 + parameter ( mwhno3 = 63.01287d0 ) + real*8 mwnh3 + parameter ( mwnh3 = 17.03061d0 ) + real*8 mwnh4 + parameter ( mwnh4 = 18.03858d0 ) + real*8 mwno3 + parameter ( mwno3 = 62.0049d0 ) + real*8 mwso4 + parameter ( mwso4 = 96.0576d0 ) + +C============================================== +C define common blocks +C============================================== +C============================================== +C define arguments +C============================================== + double precision adin(5) + double precision adout(8) + double precision in(5) + double precision par(2) + INTEGER :: I, J, L + +C============================================== +C define local variables +C============================================== + real*8 adah2o + real*8 adanh4 + real*8 adano3 + real*8 adano3_in + real*8 adaso4 + real*8 adgnh3 + real*8 adgno3 + real*8 adgno3_in + real*8 adso4 + real*8 adtnh4 + real*8 adtno3 + real*8 adtso4 + real*8 adtwoso4 + real*8 adwh2o + real*8 adynh4 + real*8 anh4 + real*8 ano3 + real*8 gnh3 + real*8 gno3 + integer irh + real*8 rh + real*8 so4 + real*8 tnh4 + real*8 tno3 + real*8 tso4 + real*8 twoso4 + real*8 ynh4 + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adah2o = 0. + adanh4 = 0. + adano3 = 0. + adano3_in = 0. + adaso4 = 0. + adgnh3 = 0. + adgno3 = 0. + adgno3_in = 0. + adso4 = 0. + adtnh4 = 0. + adtno3 = 0. + adtso4 = 0. + adtwoso4 = 0. + adwh2o = 0. + adynh4 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + so4 = in(1) + gno3 = in(2) + gnh3 = in(3) + ano3 = in(4) + anh4 = in(5) + rh = par(1) + tso4 = max(floor,so4/mwso4) + tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3) + tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4) + irh = nint(100.*rh) + irh = max(1,irh) + irh = min(99,irh) + twoso4 = 2.*tso4 + ynh4 = twoso4 + adgnh3 = adgnh3+adout(8) + adout(8) = 0.d0 + adgno3 = adgno3+adout(7) + adout(7) = 0.d0 + adso4 = adso4+adout(6) + adout(6) = 0.d0 + adanh4 = adanh4+adout(5) + adout(5) = 0.d0 + adah2o = adah2o+adout(4) + adout(4) = 0.d0 + adano3 = adano3+adout(3) + adout(3) = 0.d0 + adout(2) = 0.d0 + adaso4 = adaso4+adout(1) + adout(1) = 0.d0 + adano3_in = adano3_in+adano3 + adano3 = 0. + adgno3_in = adgno3_in+adgno3 + adgno3 = 0. + adtnh4 = adtnh4+adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4))) + adynh4 = adynh4-adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4))) + adgnh3 = 0. + adynh4 = adynh4+adanh4*mwnh4 + adanh4 = 0. + adtso4 = adtso4+adaso4*mwso4 + adaso4 = 0. + adtwoso4 = adtwoso4+adynh4 + adynh4 = 0. + adwh2o = adwh2o+1000*adah2o + adah2o = 0. + adah2o = adah2o+0.001d0*adwh2o + adwh2o = 0. + ynh4 = twoso4 + call adawater( irh,tso4,ynh4,tno3,adtso4,adynh4,adtno3,adah2o ) + adtwoso4 = adtwoso4+adynh4 + adynh4 = 0. + adtso4 = adtso4+2*adtwoso4 + adtwoso4 = 0. + adano3 = adano3+adano3_in + adano3_in = 0. + adgno3 = adgno3+adgno3_in + adgno3_in = 0. + adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh4) + adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh3) + adtnh4 = 0. + adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwno3) + adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwhno3) + adtno3 = 0. + adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4) + adtso4 = 0. + adin(5) = adin(5)+adanh4 + adanh4 = 0. + adin(4) = adin(4)+adano3 + adano3 = 0. + adin(3) = adin(3)+adgnh3 + adgnh3 = 0. + adin(2) = adin(2)+adgno3 + adgno3 = 0. + adin(1) = adin(1)+adso4 + adso4 = 0. + + end SUBROUTINE ADRPMARES_3 + +!----------------------------------------------------------------------------- + + +C DISCLAIMER +C +C This file was generated by TAMC version 5.3.2 +C +C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES +C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, +C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS +C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS. +C +C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION +C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS +C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT +C ALLOWED. +C +C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT +C info@FastOpt.com +C + subroutine adrpmares_4( in, par, adin, adout, + & I, J, L ) + +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + +C============================================== +C define parameters +C============================================== + real*8 floor + parameter ( floor = 1.d-30 ) + real*8 mwhno3 + parameter ( mwhno3 = 63.01287d0 ) + real*8 mwnh3 + parameter ( mwnh3 = 17.03061d0 ) + real*8 mwnh4 + parameter ( mwnh4 = 18.03858d0 ) + real*8 mwno3 + parameter ( mwno3 = 62.0049d0 ) + real*8 mwso4 + parameter ( mwso4 = 96.0576d0 ) + +C============================================== +C define common blocks +C============================================== +C============================================== +C define arguments +C============================================== + double precision adin(5) + double precision adout(8) + double precision in(5) + double precision par(2) + INTEGER :: I, J, L + +C============================================== +C define local variables +C============================================== + real aa + real*8 adah2o + real*8 adanh4 + real*8 adano3 + real*8 adaso4 + real*8 adbb + real*8 adcc + real*8 addd + real*8 addisc + real*8 adfnh3 + real*8 adgnh3 + real*8 adgno3 + real*8 adso4 + real*8 adtmasshno3 + real*8 adtnh4 + real*8 adtno3 + real*8 adtso4 + real*8 adtwoso4 + real*8 adwh2o + real*8 adxno3 + real*8 adxxq + real*8 adynh4 + real*8 anh4 + real*8 ano3 + real*8 bb + real*8 cc + real*8 convt + real*8 dd + real*8 disc + real*8 fnh3 + real*8 gnh3 + real*8 gno3 + integer irh + real*8 k3 + real*8 rh + real*8 so4 + real*8 temp + real*8 tmasshno3 + real*8 tnh4 + real*8 tno3 + real*8 tso4 + real*8 twoso4 + real*8 xno3 + real*8 xxq + real*8 ynh4 + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adah2o = 0. + adanh4 = 0. + adano3 = 0. + adaso4 = 0. + adbb = 0. + adcc = 0. + addd = 0. + addisc = 0. + adfnh3 = 0. + adgnh3 = 0. + adgno3 = 0. + adso4 = 0. + adtmasshno3 = 0. + adtnh4 = 0. + adtno3 = 0. + adtso4 = 0. + adtwoso4 = 0. + adwh2o = 0. + adxno3 = 0. + adxxq = 0. + adynh4 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + so4 = in(1) + gno3 = in(2) + gnh3 = in(3) + ano3 = in(4) + anh4 = in(5) + rh = par(1) + temp = par(2) + tso4 = max(floor,so4/mwso4) + tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3) + tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4) + tmasshno3 = max(0.d0,gno3+ano3) + irh = nint(100.*rh) + irh = max(1,irh) + irh = min(99,irh) + convt = 1.d0/(0.082d0*temp) + k3 = exp(118.87-24084./temp-6.025*log(temp)) + k3 = k3*convt*convt + twoso4 = 2.*tso4 + fnh3 = tnh4-twoso4 + cc = tno3*fnh3-k3 + if (cc .le. 0.d0) then + xno3 = 0.d0 + else + aa = 1.d0 + bb = -(tno3+fnh3) + disc = bb*bb-4.*cc + dd = sqrt(disc) + xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd)) + xno3 = min(xxq/aa,cc/xxq) + endif + ynh4 = twoso4+xno3 + ano3 = xno3*mwno3 + adgnh3 = adgnh3+adout(8) + adout(8) = 0.d0 + adgno3 = adgno3+adout(7) + adout(7) = 0.d0 + adso4 = adso4+adout(6) + adout(6) = 0.d0 + adanh4 = adanh4+adout(5) + adout(5) = 0.d0 + adah2o = adah2o+adout(4) + adout(4) = 0.d0 + adano3 = adano3+adout(3) + adout(3) = 0.d0 + adout(2) = 0.d0 + adaso4 = adaso4+adout(1) + adout(1) = 0.d0 + adano3 = adano3-adgno3*(0.5-sign(0.5d0,floor-(tmasshno3-ano3))) + adtmasshno3 = adtmasshno3+adgno3*(0.5-sign(0.5d0,floor-(tmasshno3- + $ano3))) + adgno3 = 0. + adtnh4 = adtnh4+adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4))) + adynh4 = adynh4-adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4))) + adgnh3 = 0. + adynh4 = adynh4+adanh4*mwnh4 + adanh4 = 0. + adxno3 = adxno3+adano3*mwno3 + adano3 = 0. + adtso4 = adtso4+adaso4*mwso4 + adaso4 = 0. + adtwoso4 = adtwoso4+adynh4 + adxno3 = adxno3+adynh4 + adynh4 = 0. + adwh2o = adwh2o+1000*adah2o + adah2o = 0. + if (cc .le. 0.d0) then + else + adcc = adcc+adxno3*((0.5-sign(0.5d0,cc/xxq-xxq/aa))/xxq) + adxxq = adxxq+adxno3*((0.5+sign(0.5d0,cc/xxq-xxq/aa))/aa-(0.5- + $sign(0.5d0,cc/xxq-xxq/aa))*(cc/(xxq*xxq))) + adxno3 = 0. + adbb = adbb-0.5d0*adxxq + addd = addd-0.5d0*adxxq*sign(1.d0,bb) + adxxq = 0. + addisc = addisc+addd*(1./(2.*sqrt(disc))) + addd = 0. + adbb = adbb+2*addisc*bb + adcc = adcc-4*addisc + addisc = 0. + adfnh3 = adfnh3-adbb + adtno3 = adtno3-adbb + adbb = 0. + endif + adfnh3 = adfnh3+adcc*tno3 + adtno3 = adtno3+adcc*fnh3 + adcc = 0. + adtnh4 = adtnh4+adfnh3 + adtwoso4 = adtwoso4-adfnh3 + adfnh3 = 0. + adah2o = adah2o+0.001d0*adwh2o + adwh2o = 0. + ynh4 = twoso4 + call adawater( irh,tso4,ynh4,tno3,adtso4,adynh4,adtno3,adah2o ) + adtwoso4 = adtwoso4+adynh4 + adynh4 = 0. + adtso4 = adtso4+2*adtwoso4 + adtwoso4 = 0. + ano3 = in(4) + adano3 = adano3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3))) + adgno3 = adgno3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3))) + adtmasshno3 = 0. + adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh4) + adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh3) + adtnh4 = 0. + adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwno3) + adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwhno3) + adtno3 = 0. + adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4) + adtso4 = 0. + adin(5) = adin(5)+adanh4 + adanh4 = 0. + adin(4) = adin(4)+adano3 + adano3 = 0. + adin(3) = adin(3)+adgnh3 + adgnh3 = 0. + adin(2) = adin(2)+adgno3 + adgno3 = 0. + adin(1) = adin(1)+adso4 + adso4 = 0. + + end SUBROUTINE ADRPMARES_4 + +!----------------------------------------------------------------------------- + + +C DISCLAIMER +C +C This file was generated by TAMC version 5.3.2 +C +C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES +C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, +C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS +C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS. +C +C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION +C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS +C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT +C ALLOWED. +C +C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT +C info@FastOpt.com +C + subroutine adrpmares_6( in, par, adin, adout, + & I, J, L ) + + ! References to f90 modules + USE CHECKPT_MOD + USE RPMARES_MOD, ONLY : AWATER, ACTCOF + +# include "CMN_SIZE" ! Size params + +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + +C============================================== +C define parameters +C============================================== + real*8 floor + parameter ( floor = 1.d-30 ) + real*8 mwhno3 + parameter ( mwhno3 = 63.01287d0 ) + real*8 mwnh3 + parameter ( mwnh3 = 17.03061d0 ) + real*8 mwnh4 + parameter ( mwnh4 = 18.03858d0 ) + real*8 mwno3 + parameter ( mwno3 = 62.0049d0 ) + real*8 mwso4 + parameter ( mwso4 = 96.0576d0 ) + +C============================================== +C define common blocks +C============================================== + +C============================================== +C define arguments +C============================================= = + double precision adin(5) + double precision adout(8) + double precision in(5) + double precision par(2) + INTEGER :: I, J, L + +C============================================== +C define local variables +C============================================== + real aa + real adaa + real*8 adah2o + real*8 adan(3) + real*8 adanh4 + real*8 adano3 + real*8 adaso4 + real*8 adbb + real*8 adcat(2) + real*8 adcc + real*8 addd + real*8 addisc + real*8 aderor + real aderorh + real*8 adgamaan + real*8 adgamold + real*8 adgams(2,3) + real*8 adgasqd + real*8 adgnh3 + real*8 adgno3 + real*8 adkw2 + real*8 adman + real*8 admas + real*8 admnh4 + real*8 adrr1 + real*8 adrr2 + real*8 adso4 + real*8 adtmasshno3 + real*8 adtnh4 + real*8 adtno3 + real*8 adtso4 + real*8 adtwoso4 + real*8 adwh2o + real*8 adwsqd + real*8 adxno3 + real*8 adxxq + real*8 adynh4 + real*8 ah2o + real*8 an(3) + real*8 anh4 + real*8 ano3 + real*8 bb + real*8 cat(2) + real*8 cc + real*8 dd + real*8 disc + real*8 eror + integer exit + real*8 gamaan + real*8 gamaanh + real*8 gamold + real*8 gams(2,3) + real*8 gasqd + real*8 gnh3 + real*8 gno3 + integer ip1 + integer ip2 + integer irh + real*8 k1a + real*8 kan + real*8 khat + real*8 kna + real*8 kph + real*8 kw + real*8 kw2 + real*8 man + real*8 mas + real*8 mnh4 + real*8 molnu + integer nnn + integer nnn1 + real*8 phibar + real*8 rh + real*8 rr1 + real*8 rr2 + real*8 so4 + real*8 t1 + real*8 t2 + real*8 t3 + real*8 t4 + real*8 t6 + real*8 temp + real*8 tmasshno3 + real*8 tnh4 + real*8 tno3 + real*8 toler1 + real*8 tso4 + real*8 twoso4 + real*8 wh2o + real*8 wh2oh + real*8 wsqd + real*8 xno3 + real*8 xxq + real*8 ynh4 + real*8 ynh4h + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adaa = 0. + adah2o = 0. + do ip1 = 1, 3 + adan(ip1) = 0. + end do + adanh4 = 0. + adano3 = 0. + adaso4 = 0. + adbb = 0. + do ip1 = 1, 2 + adcat(ip1) = 0. + end do + adcc = 0. + addd = 0. + addisc = 0. + aderor = 0. + adgamaan = 0. + adgamold = 0. + do ip2 = 1, 3 + do ip1 = 1, 2 + adgams(ip1,ip2) = 0. + end do + end do + adgasqd = 0. + adgnh3 = 0. + adgno3 = 0. + adkw2 = 0. + adman = 0. + admas = 0. + admnh4 = 0. + adrr1 = 0. + adrr2 = 0. + adso4 = 0. + adtmasshno3 = 0. + adtnh4 = 0. + adtno3 = 0. + adtso4 = 0. + adtwoso4 = 0. + adwh2o = 0. + adwsqd = 0. + adxno3 = 0. + adxxq = 0. + adynh4 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + so4 = in(1) + gno3 = in(2) + gnh3 = in(3) + ano3 = in(4) + anh4 = in(5) + rh = par(1) + temp = par(2) + tso4 = max(floor,so4/mwso4) + tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3) + tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4) + tmasshno3 = max(0.d0,gno3+ano3) + irh = nint(100.*rh) + irh = max(1,irh) + irh = min(99,irh) + t6 = 8.2d-11*temp + t1 = 298.d0/temp + t2 = log(t1) + t3 = t1-1.d0 + t4 = 1.d0+t2-t1 + kna = 2511000.d0*exp(29.17d0*t3+16.83d0*t4)*t6 + k1a = 0.00001805d0*exp((-(1.5d0*t3))+26.92d0*t4) + kw = 1.01d-14*exp((-(22.52d0*t3))+26.92d0*t4) + kph = 57.639d0*exp(13.79d0*t3-5.39d0*t4)*t6 + khat = kph*k1a/kw + kan = kna*khat + toler1 = 0.00001d0 + twoso4 = 2.*tso4 + adgnh3 = adgnh3+adout(8) + adout(8) = 0.d0 + adgno3 = adgno3+adout(7) + adout(7) = 0.d0 + adso4 = adso4+adout(6) + adout(6) = 0.d0 + adanh4 = adanh4+adout(5) + adout(5) = 0.d0 + adah2o = adah2o+adout(4) + adout(4) = 0.d0 + adano3 = adano3+adout(3) + adout(3) = 0.d0 + adout(2) = 0.d0 + adaso4 = adaso4+adout(1) + adout(1) = 0.d0 + !do nnn = 50, 1, -1 + do nnn = nitr_max(I,J,L), 1, -1 + exit = 0 + gamold = 1.d0 + gamaan = 0.1 + ynh4 = twoso4 + call awater( irh,tso4,ynh4,tno3,ah2o ) + wh2o = 0.001d0*ah2o + ynh4 = twoso4 + + !===================================================================== + ! CHECKPOINT + ! The do loop below was soley for the recomputation of ynh4h, wh2oh, + ! gamaanhm, exit and gamold. + ! Instead of recomputing these quantities, get them from the forward + ! calculation, except if nnn is 1, in which case they are just their + ! normal values + !===================================================================== + IF (nnn-1 .gt. 0) THEN + ynh4h = ynh4_fwd(I,J,L,nnn-1) + wh2oh = wh2o_fwd(I,J,L,nnn-1) + gamaanh = gamaan_fwd(I,J,L,nnn-1) + gamold = gamold_fwd(I,J,L,nnn-1) + exit = exit_fwd(I,J,L,nnn-1) + ENDIF + +! do nnn1 = 1, nnn-1 +! gasqd = gamaan*gamaan +! wsqd = wh2o*wh2o +! kw2 = kan*wsqd/gasqd +! aa = 1.-kw2 +! bb = twoso4+kw2*(tno3+tnh4-twoso4) +! cc = -(kw2*tno3*(tnh4-twoso4)) +! disc = bb*bb-4.*aa*cc +! if (aa .ne. 0.d0) then +! dd = sqrt(disc) +! xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd)) +! rr1 = xxq/aa +! rr2 = cc/xxq +! if (rr1*rr2 .lt. 0.d0) then +! xno3 = max(rr1,rr2) +! else +! xno3 = min(rr1,rr2) +! endif +! else +! xno3 = -(cc/bb) +! endif +! xno3 = min(xno3,tno3) +! call awater( irh,tso4,ynh4,xno3,ah2o ) +! wh2o = 0.001*ah2o +! man = xno3/wh2o +! mas = tso4/wh2o +! mnh4 = 2.*mas+man +! ynh4 = mnh4*wh2o +! cat(1) = 0. +! cat(2) = mnh4 +! an(1) = mas +! an(2) = man +! an(3) = 0. +! call actcof( cat,an,gams,molnu,phibar ) +! gamaan = gams(2,2) +! eror = abs(gamold-gamaan)/gamold +! gamold = gamaan +! if (eror .le. toler1) then +! if (exit .eq. 0) then +! exit = 6 +! endif +! endif +! end do + ynh4h = ynh4 + wh2oh = wh2o + gamaanh = gamaan + gasqd = gamaan*gamaan + wsqd = wh2o*wh2o + kw2 = kan*wsqd/gasqd + aa = 1.-kw2 + bb = twoso4+kw2*(tno3+tnh4-twoso4) + cc = -(kw2*tno3*(tnh4-twoso4)) + disc = bb*bb-4.*aa*cc + if (aa .ne. 0.d0) then + dd = sqrt(disc) + xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd)) + rr1 = xxq/aa + rr2 = cc/xxq + if (rr1*rr2 .lt. 0.d0) then + xno3 = max(rr1,rr2) + else + xno3 = min(rr1,rr2) + endif + else + xno3 = -(cc/bb) + endif + xno3 = min(xno3,tno3) + call awater( irh,tso4,ynh4,xno3,ah2o ) + wh2o = 0.001*ah2o + man = xno3/wh2o + mas = tso4/wh2o + mnh4 = 2.*mas+man + ynh4 = mnh4*wh2o + cat(1) = 0. + cat(2) = mnh4 + an(1) = mas + an(2) = man + an(3) = 0. + call actcof( cat,an,gams,molnu,phibar ) + gamaan = gams(2,2) + eror = abs(gamold-gamaan)/gamold + if (eror .le. toler1) then + if (exit .eq. 0) then + ano3 = xno3*mwno3 + adwh2o = adwh2o+1000*adah2o + adah2o = 0. + adtnh4 = adtnh4+adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4) + $)) + adynh4 = adynh4-adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4) + $)) + adgnh3 = 0. + adano3 = adano3-adgno3*(0.5-sign(0.5d0,floor-(tmasshno3-ano3)) + $) + adtmasshno3 = adtmasshno3+adgno3*(0.5d0-sign(0.5d0,floor- + $(tmasshno3-ano3))) + adgno3 = 0. + adynh4 = adynh4+adanh4*mwnh4 + adanh4 = 0. + adxno3 = adxno3+adano3*mwno3 + adano3 = 0. + adtso4 = adtso4+adaso4*mwso4 + adaso4 = 0. + endif + endif + adgamaan = adgamaan+adgamold + adgamold = 0. + aderorh = aderor/gamold + adgamold = adgamold-aderor*(abs(gamold-gamaan)/(gamold*gamold)) + adgamaan = adgamaan-aderorh*sign(1.d0,gamold-gamaan) + adgamold = adgamold+aderorh*sign(1.d0,gamold-gamaan) + aderor = 0. + adgams(2,2) = adgams(2,2)+adgamaan + adgamaan = 0. + call adactcof( cat,an,adcat,adan,adgams ) + adan(3) = 0. + adman = adman+adan(2) + adan(2) = 0. + admas = admas+adan(1) + adan(1) = 0. + admnh4 = admnh4+adcat(2) + adcat(2) = 0. + adcat(1) = 0. + admnh4 = admnh4+adynh4*wh2o + adwh2o = adwh2o+adynh4*mnh4 + adynh4 = 0. + adman = adman+admnh4 + admas = admas+2*admnh4 + admnh4 = 0. + adtso4 = adtso4+admas/wh2o + adwh2o = adwh2o-admas*(tso4/(wh2o*wh2o)) + admas = 0. + adwh2o = adwh2o-adman*(xno3/(wh2o*wh2o)) + adxno3 = adxno3+adman/wh2o + adman = 0. + adah2o = adah2o+0.001*adwh2o + adwh2o = 0. + ynh4 = ynh4h + call adawater( irh,tso4,ynh4,xno3,adtso4,adynh4,adxno3,adah2o ) + if (aa .ne. 0.d0) then + dd = sqrt(disc) + xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd)) + rr1 = xxq/aa + rr2 = cc/xxq + if (rr1*rr2 .lt. 0.d0) then + xno3 = max(rr1,rr2) + else + xno3 = min(rr1,rr2) + endif + else + xno3 = -(cc/bb) + endif + adtno3 = adtno3+adxno3*(0.5-sign(0.5d0,tno3-xno3)) + adxno3 = adxno3*(0.5+sign(0.5d0,tno3-xno3)) + if (aa .ne. 0.d0) then + if (rr1*rr2 .lt. 0.d0) then + adrr1 = adrr1+adxno3*(0.5+sign(0.5d0,rr1-rr2)) + adrr2 = adrr2+adxno3*(0.5-sign(0.5d0,rr1-rr2)) + adxno3 = 0. + else + adrr1 = adrr1+adxno3*(0.5+sign(0.5d0,rr2-rr1)) + adrr2 = adrr2+adxno3*(0.5-sign(0.5d0,rr2-rr1)) + adxno3 = 0. + endif + adcc = adcc+adrr2/xxq + adxxq = adxxq-adrr2*(cc/(xxq*xxq)) + adrr2 = 0. + adaa = adaa-adrr1*(xxq/(aa*aa)) + adxxq = adxxq+adrr1/aa + adrr1 = 0. + adbb = adbb-0.5d0*adxxq + addd = addd-0.5d0*adxxq*sign(1.d0,bb) + adxxq = 0. + addisc = addisc+addd*(1./(2.*sqrt(disc))) + addd = 0. + else + adbb = adbb+adxno3*(cc/(bb*bb)) + adcc = adcc-adxno3/bb + adxno3 = 0. + endif + adaa = adaa-4*addisc*cc + adbb = adbb+2*addisc*bb + adcc = adcc-4*addisc*aa + addisc = 0. + adkw2 = adkw2-adcc*tno3*(tnh4-twoso4) + adtnh4 = adtnh4-adcc*kw2*tno3 + adtno3 = adtno3-adcc*kw2*(tnh4-twoso4) + adtwoso4 = adtwoso4+adcc*kw2*tno3 + adcc = 0. + adkw2 = adkw2+adbb*(tno3+tnh4-twoso4) + adtnh4 = adtnh4+adbb*kw2 + adtno3 = adtno3+adbb*kw2 + adtwoso4 = adtwoso4+adbb*(1-kw2) + adbb = 0. + adkw2 = adkw2-adaa + adaa = 0. + adgasqd = adgasqd-adkw2*(kan*wsqd/(gasqd*gasqd)) + adwsqd = adwsqd+adkw2*(kan/gasqd) + adkw2 = 0. + wh2o = wh2oh + adwh2o = adwh2o+2*adwsqd*wh2o + adwsqd = 0. + gamaan = gamaanh + adgamaan = adgamaan+2*adgasqd*gamaan + adgasqd = 0. + end do + adtwoso4 = adtwoso4+adynh4 + adynh4 = 0. + adynh4 = adynh4+adanh4*mwnh4 + adanh4 = 0. + adano3 = 0. + adtso4 = adtso4+adaso4*mwso4 + adaso4 = 0. + adah2o = adah2o+0.001d0*adwh2o + adwh2o = 0. + ynh4 = twoso4 + call adawater( irh,tso4,ynh4,tno3,adtso4,adynh4,adtno3,adah2o ) + adtwoso4 = adtwoso4+adynh4 + adynh4 = 0. + adtso4 = adtso4+2*adtwoso4 + adtwoso4 = 0. + ano3 = in(4) + adano3 = adano3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3))) + adgno3 = adgno3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3))) + adtmasshno3 = 0. + adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh4) + adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh3) + adtnh4 = 0. + adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwno3) + adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwhno3) + adtno3 = 0. + adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4) + adtso4 = 0. + adin(5) = adin(5)+adanh4 + adanh4 = 0. + adin(4) = adin(4)+adano3 + adano3 = 0. + adin(3) = adin(3)+adgnh3 + adgnh3 = 0. + adin(2) = adin(2)+adgno3 + adgno3 = 0. + adin(1) = adin(1)+adso4 + adso4 = 0. + + end SUBROUTINE ADRPMARES_6 + +!----------------------------------------------------------------------------- + + +C DISCLAIMER +C +C This file was generated by TAMC version 5.3.2 +C +C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES +C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, +C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS +C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS. +C +C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION +C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS +C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT +C ALLOWED. +C +C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT +C info@FastOpt.com +C + subroutine adrpmares_7( in, par, adin, adout, + & I, J, L ) + +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + +C============================================== +C define parameters +C============================================== + real*8 floor + parameter ( floor = 1.d-30 ) + real*8 mwhno3 + parameter ( mwhno3 = 63.01287d0 ) + real*8 mwnh3 + parameter ( mwnh3 = 17.03061d0 ) + real*8 mwnh4 + parameter ( mwnh4 = 18.03858d0 ) + real*8 mwno3 + parameter ( mwno3 = 62.0049d0 ) + real*8 mwso4 + parameter ( mwso4 = 96.0576d0 ) + +C============================================== +C define common blocks +C============================================== +C============================================== +C define arguments +C============================================== + double precision adin(5) + double precision adout(8) + double precision in(5) + double precision par(2) + INTEGER :: I, J, L + +C============================================== +C define local variables +C============================================== + real*8 adah2o + real*8 adanh4 + real*8 adano3 + real*8 adano3_in + real*8 adaso4 + real*8 adgnh3 + real*8 adgno3 + real*8 adgno3_in + real*8 adso4 + real*8 adtnh4 + real*8 adtno3 + real*8 adtso4 + real*8 adtwoso4 + real*8 adxno3 + real*8 adynh4 + real*8 anh4 + real*8 ano3 + real*8 gnh3 + real*8 gno3 + integer irh + real*8 rh + real*8 so4 + real*8 tnh4 + real*8 tno3 + real*8 tso4 + real*8 twoso4 + real*8 xno3 + real*8 ynh4 + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adah2o = 0. + adanh4 = 0. + adano3 = 0. + adano3_in = 0. + adaso4 = 0. + adgnh3 = 0. + adgno3 = 0. + adgno3_in = 0. + adso4 = 0. + adtnh4 = 0. + adtno3 = 0. + adtso4 = 0. + adtwoso4 = 0. + adxno3 = 0. + adynh4 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + so4 = in(1) + gno3 = in(2) + gnh3 = in(3) + ano3 = in(4) + anh4 = in(5) + rh = par(1) + tso4 = max(floor,so4/mwso4) + tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3) + tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4) + irh = nint(100.*rh) + irh = max(1,irh) + irh = min(99,irh) + twoso4 = 2.*tso4 + xno3 = tno3/mwno3 + ynh4 = twoso4 + adgnh3 = adgnh3+adout(8) + adout(8) = 0.d0 + adgno3 = adgno3+adout(7) + adout(7) = 0.d0 + adso4 = adso4+adout(6) + adout(6) = 0.d0 + adanh4 = adanh4+adout(5) + adout(5) = 0.d0 + adah2o = adah2o+adout(4) + adout(4) = 0.d0 + adano3 = adano3+adout(3) + adout(3) = 0.d0 + adout(2) = 0.d0 + adaso4 = adaso4+adout(1) + adout(1) = 0.d0 + adtnh4 = adtnh4+adgnh3*(0.5-sign(0.5d0,floor-mwnh3*(tnh4-ynh4)))* + $mwnh3 + adynh4 = adynh4-adgnh3*(0.5-sign(0.5d0,floor-mwnh3*(tnh4-ynh4)))* + $mwnh3 + adgnh3 = 0. + adano3_in = adano3_in+adano3 + adano3 = 0. + adgno3_in = adgno3_in+adgno3 + adgno3 = 0. + call adawater( irh,tso4,ynh4,xno3,adtso4,adynh4,adxno3,adah2o ) + adynh4 = adynh4+adanh4*mwnh4 + adanh4 = 0. + adtwoso4 = adtwoso4+adynh4 + adynh4 = 0. + adtno3 = adtno3+adxno3/mwno3 + adxno3 = 0. + adtso4 = adtso4+adaso4*mwso4 + adaso4 = 0. + ynh4 = twoso4 + call adawater( irh,tso4,ynh4,tno3,adtso4,adynh4,adtno3,adah2o ) + adtwoso4 = adtwoso4+adynh4 + adynh4 = 0. + adtso4 = adtso4+2*adtwoso4 + adtwoso4 = 0. + adano3 = adano3+adano3_in + adano3_in = 0. + adgno3 = adgno3+adgno3_in + adgno3_in = 0. + adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh4) + adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh3) + adtnh4 = 0. + adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwno3) + adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwhno3) + adtno3 = 0. + adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4) + adtso4 = 0. + adin(5) = adin(5)+adanh4 + adanh4 = 0. + adin(4) = adin(4)+adano3 + adano3 = 0. + adin(3) = adin(3)+adgnh3 + adgnh3 = 0. + adin(2) = adin(2)+adgno3 + adgno3 = 0. + adin(1) = adin(1)+adso4 + adso4 = 0. + + end SUBROUTINE ADRPMARES_7 + +!----------------------------------------------------------------------------- + + +C DISCLAIMER +C +C This file was generated by TAMC version 5.3.2 +C +C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES +C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, +C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS +C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS. +C +C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION +C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS +C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT +C ALLOWED. +C +C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT +C info@FastOpt.com +C + subroutine adrpmares_8( in, par, adin, adout, + & I, J, L ) + +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + +C============================================== +C define parameters +C============================================== + real*8 floor + parameter ( floor = 1.d-30 ) + real*8 mwhno3 + parameter ( mwhno3 = 63.01287d0 ) + real*8 mwnh3 + parameter ( mwnh3 = 17.03061d0 ) + real*8 mwnh4 + parameter ( mwnh4 = 18.03858d0 ) + real*8 mwno3 + parameter ( mwno3 = 62.0049d0 ) + real*8 mwso4 + parameter ( mwso4 = 96.0576d0 ) + +C============================================== +C define common blocks +C============================================== +C============================================== +C define arguments +C============================================== + double precision adin(5) + double precision adout(8) + double precision in(5) + double precision par(2) + INTEGER :: I, J, L + +C============================================== +C define local variables +C============================================== + real*8 adah2o + real*8 adahso4 + real*8 adanh4 + real*8 adano3 + real*8 adano3_in + real*8 adaso4 + real*8 adgnh3 + real*8 adgno3 + real*8 adso4 + real*8 adtmasshno3 + real*8 adtnh4 + real*8 adtno3 + real*8 adtso4 + real*8 anh4 + real*8 ano3 + real*8 gnh3 + real*8 gno3 + integer irh + real*8 rh + real*8 so4 + real*8 tnh4 + real*8 tno3 + real*8 tso4 + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adah2o = 0. + adahso4 = 0. + adanh4 = 0. + adano3 = 0. + adano3_in = 0. + adaso4 = 0. + adgnh3 = 0. + adgno3 = 0. + adso4 = 0. + adtmasshno3 = 0. + adtnh4 = 0. + adtno3 = 0. + adtso4 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + so4 = in(1) + gno3 = in(2) + gnh3 = in(3) + ano3 = in(4) + anh4 = in(5) + rh = par(1) + tso4 = max(floor,so4/mwso4) + tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3) + tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4) + irh = nint(100.*rh) + irh = max(1,irh) + irh = min(99,irh) + adgnh3 = adgnh3+adout(8) + adout(8) = 0.d0 + adgno3 = adgno3+adout(7) + adout(7) = 0.d0 + adso4 = adso4+adout(6) + adout(6) = 0.d0 + adanh4 = adanh4+adout(5) + adout(5) = 0.d0 + adah2o = adah2o+adout(4) + adout(4) = 0.d0 + adano3 = adano3+adout(3) + adout(3) = 0.d0 + adahso4 = adahso4+adout(2) + adout(2) = 0.d0 + adaso4 = adaso4+adout(1) + adout(1) = 0.d0 + adgnh3 = 0. + adano3 = adano3-adgno3 + adtmasshno3 = adtmasshno3+adgno3 + adgno3 = 0. + adano3_in = adano3_in+adano3 + adano3 = 0. + adtnh4 = adtnh4+adanh4*mwnh4 + adanh4 = 0. + adtso4 = adtso4+adahso4*mwso4 + adahso4 = 0. + adaso4 = 0. + call adawater( irh,tso4,tnh4,tno3,adtso4,adtnh4,adtno3,adah2o ) + adano3 = adano3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3))) + adgno3 = adgno3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3))) + adtmasshno3 = 0. + adano3 = adano3+adano3_in + adano3_in = 0. + adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh4) + adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh3) + adtnh4 = 0. + adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwno3) + adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwhno3) + adtno3 = 0. + adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4) + adtso4 = 0. + adin(5) = adin(5)+adanh4 + adanh4 = 0. + adin(4) = adin(4)+adano3 + adano3 = 0. + adin(3) = adin(3)+adgnh3 + adgnh3 = 0. + adin(2) = adin(2)+adgno3 + adgno3 = 0. + adin(1) = adin(1)+adso4 + adso4 = 0. + + end SUBROUTINE ADRPMARES_8 +!------------------------------------------------------------------------------ + + subroutine adcubic( a2, a1, a0, ada2, ada1, ada0, adcrutes ) +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + implicit none + +C============================================== +C define parameters +C============================================== + real*8 one + parameter ( one = 1.d0 ) + real*8 one3rd + parameter ( one3rd = 0.333333333d0 ) + real*8 sqrt3 + parameter ( sqrt3 = 1.732050808d0 ) + +C============================================== +C define common blocks +C============================================== +C============================================== +C define arguments +C============================================== + real*8 a0 + real*8 a1 + real*8 a2 + real*8 ada0 + real*8 ada1 + real*8 ada2 + real*8 adcrutes(3) + +C============================================== +C define local variables +C============================================== + real*8 a2sq + real*8 ada2sq + real*8 adcosth + real*8 addum1 + real*8 addum2 + real*8 adpart1 + real*8 adpart2 + real*8 adpart3 + real*8 adphi + real*8 adqq + real*8 adrr + real*8 adrrsq + real*8 adsinth + real*8 adtheta + real*8 adyy1 + real*8 adyy2 + real*8 adyy3 + real*8 costh + real*8 crutes(3) + real*8 dum1 + real*8 dum2 + real*8 part1 + real*8 part2 + real*8 part3 + real*8 phi + real*8 qq + real*8 rr + real*8 rrsq + real*8 sinth + real*8 theta + real*8 yy1 + real*8 yy2 + real*8 yy3 + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + ada2sq = 0. + adcosth = 0. + addum1 = 0. + addum2 = 0. + adpart1 = 0. + adpart2 = 0. + adpart3 = 0. + adphi = 0. + adqq = 0. + adrr = 0. + adrrsq = 0. + adsinth = 0. + adtheta = 0. + adyy1 = 0. + adyy2 = 0. + adyy3 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + a2sq = a2*a2 + qq = (a2sq-3.d0*a1)/9.d0 + rr = (a2*(2.d0*a2sq-9.d0*a1)+27.d0*a0)/54.d0 + dum1 = qq*qq*qq + rrsq = rr*rr + dum2 = dum1-rrsq + if (dum2 .ge. 0.d0) then + phi = sqrt(dum1) + if (abs(phi) .lt. 1.d-20) then + crutes(1) = 0.d0 + crutes(2) = 0.d0 + crutes(3) = 0.d0 + endif + theta = acos(rr/phi)/3.d0 + costh = cos(theta) + sinth = sin(theta) + part1 = sqrt(qq) + yy1 = part1*costh + yy2 = yy1-a2/3.d0 + yy3 = sqrt3*part1*sinth + crutes(3) = (-(2.d0*yy1))-a2/3.d0 + crutes(2) = yy2+yy3 + crutes(1) = yy2-yy3 + if (crutes(1) .lt. 0.d0) then + crutes(1) = 1.d+9 + endif + if (crutes(2) .lt. 0.d0) then + crutes(2) = 1.d+9 + endif + if (crutes(3) .lt. 0.d0) then + crutes(3) = 1.d+9 + endif + adcrutes(2) = adcrutes(2)+adcrutes(1)*(0.5-sign(0.5d0,crutes(2)- + $crutes(1))) + adcrutes(1) = adcrutes(1)*(0.5+sign(0.5d0,crutes(2)-crutes(1))) + crutes(1) = yy2-yy3 + if (crutes(1) .lt. 0.d0) then + crutes(1) = 1.d+9 + endif + if (crutes(2) .lt. 0.d0) then + crutes(2) = 1.d+9 + endif + if (crutes(3) .lt. 0.d0) then + adcrutes(3) = 0. + endif + crutes(1) = yy2-yy3 + if (crutes(1) .lt. 0.d0) then + crutes(1) = 1.d+9 + endif + if (crutes(2) .lt. 0.d0) then + adcrutes(2) = 0. + endif + crutes(1) = yy2-yy3 + if (crutes(1) .lt. 0.d0) then + adcrutes(1) = 0. + endif + adyy2 = adyy2+adcrutes(1) + adyy3 = adyy3-adcrutes(1) + adcrutes(1) = 0. + adyy2 = adyy2+adcrutes(2) + adyy3 = adyy3+adcrutes(2) + adcrutes(2) = 0. + ada2 = ada2-0.333333333333d0*adcrutes(3) + adyy1 = adyy1-2*adcrutes(3) + adcrutes(3) = 0. + adpart1 = adpart1+adyy3*sqrt3*sinth + adsinth = adsinth+adyy3*sqrt3*part1 + adyy3 = 0. + ada2 = ada2-0.333333333333d0*adyy2 + adyy1 = adyy1+adyy2 + adyy2 = 0. + adcosth = adcosth+adyy1*part1 + adpart1 = adpart1+adyy1*costh + adyy1 = 0. + adqq = adqq+adpart1*(1./(2.*sqrt(qq))) + adpart1 = 0. + adtheta = adtheta+adsinth*cos(theta) + adsinth = 0. + adtheta = adtheta-adcosth*sin(theta) + adcosth = 0. + adphi = adphi+adtheta*(1./sqrt(1.-(rr/phi)**2)*(rr/(phi*phi))/ + $3.d0) + adrr = adrr-adtheta*(1./sqrt(1.-(rr/phi)**2)/phi/3.d0) + adtheta = 0. + if (abs(phi) .lt. 1.d-20) then + adcrutes(3) = 0. + adcrutes(2) = 0. + adcrutes(1) = 0. + endif + addum1 = addum1+adphi*(1./(2.*sqrt(dum1))) + adphi = 0. + else + part1 = sqrt(rrsq-dum1) + part2 = abs(rr) + part3 = (part1+part2)**one3rd + adcrutes(3) = 0. + adcrutes(2) = 0. + ada2 = ada2-0.333333333333d0*adcrutes(1) + adpart3 = adpart3-adcrutes(1)*(1-qq/(part3*part3))*sign(one,rr) + adqq = adqq-adcrutes(1)/part3*sign(one,rr) + adcrutes(1) = 0. + adpart1 = adpart1+adpart3*one3rd*(part1+part2)**(one3rd-1) + adpart2 = adpart2+adpart3*one3rd*(part1+part2)**(one3rd-1) + adpart3 = 0. + adrr = adrr+adpart2*sign(1.d0,rr) + adpart2 = 0. + addum1 = addum1-adpart1*(1./(2.*sqrt(rrsq-dum1))) + adrrsq = adrrsq+adpart1*(1./(2.*sqrt(rrsq-dum1))) + adpart1 = 0. + endif + addum1 = addum1+addum2 + adrrsq = adrrsq-addum2 + addum2 = 0. + adrr = adrr+2*adrrsq*rr + adrrsq = 0. + adqq = adqq+3*addum1*qq*qq + addum1 = 0. + ada0 = ada0+0.5d0*adrr + ada1 = ada1+adrr*((-9)*a2/54.d0) + ada2 = ada2+adrr*((2.d0*a2sq-9.d0*a1)/54.d0) + ada2sq = ada2sq+adrr*(2*a2/54.d0) + adrr = 0. + ada1 = ada1-0.333333333333d0*adqq + ada2sq = ada2sq+0.111111111111d0*adqq + adqq = 0. + ada2 = ada2+2*ada2sq*a2 + ada2sq = 0. + + end SUBROUTINE ADCUBIC +!------------------------------------------------------------------------------ + + subroutine adrpmares_6_D5( in, par, adin, adout, + & I, J, L ) + +! +!****************************************************************************** +! Subroutine adrpmares_6_D5 was created using a modified version of +! rpmares_short6.f which replaced the RETURN structure with a DOWHILE loop. +! (dkh, 06/01/05) +! +! Notes +! (1 ) The following changes are made to the code returned by TAMC: +! - Change the routine name +! - Expand argument list to include I, J, L +! - Eliminate the OUT variable as we are not returning results of fwd +! calculation from this subroutine. +! - Replace reference to TAMC storage routines with reference to our +! checkpointing variables xxx_fwd which are initialized in +! RECOMP_RPMARES. Comment out the portions of the code that were used +! to recompute these variables (idow, gamaan, wh2o, ynh4). +! +! (2 ) Unlike previous version, don't bother to use checkpointed values of +! gamanold Can just use gamaan_fwd(I,J,L,idow-1) to restore gamanold. +! +!****************************************************************************** +! + + ! Reference to f90 modules + USE CHECKPT_MOD + USE RPMARES_MOD, ONLY : CUBIC, AWATER, ACTCOF + +# include "CMN_SIZE" ! Size params + +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== +! implicit none + +C============================================== +C define parameters +C============================================== + real*8 floor + parameter ( floor = 1.d-30 ) + real*8 mwhno3 + parameter ( mwhno3 = 63.01287d0 ) + real*8 mwnh3 + parameter ( mwnh3 = 17.03061d0 ) + real*8 mwnh4 + parameter ( mwnh4 = 18.03858d0 ) + real*8 mwno3 + parameter ( mwno3 = 62.0049d0 ) + real*8 mwso4 + parameter ( mwso4 = 96.0576d0 ) + +C============================================== +C define common blocks +C============================================== +C============================================== +C define arguments +C============================================== + double precision adin(5) + double precision adout(8) + double precision in(5) +! double precision out(8) + double precision par(2) + +C============================================== +C define local variables +C============================================== + real aa + real adaa + real*8 adah2o + real*8 adan(3) + real*8 adanh4 + real*8 adano3 + real*8 adaso4 + real*8 adbb + real*8 adcat(2) + real*8 adcc + real*8 addd + real*8 addisc + real*8 aderor + real aderori + real*8 adgamaan + real*8 adgamold + real*8 adgams(2,3) + real*8 adgasqd + real*8 adgnh3 + real*8 adgno3 + real*8 adkw2 + real*8 adman + real*8 admas + real*8 admnh4 + real*8 adrr1 + real*8 adrr2 + real*8 adso4 + real*8 adtmasshno3 + real*8 adtnh4 + real*8 adtno3 + real*8 adtso4 + real*8 adtwoso4 + real*8 adwh2o + real*8 adwsqd + real*8 adxno3 + real*8 adxxq + real*8 adynh4 + real*8 ah2o + real*8 ahso4 + real*8 an(3) + real*8 anh4 + real*8 ano3 + real*8 aso4 + real*8 bb + real*8 cat(2) + real*8 cc + logical converged + real*8 dd + real*8 disc + real*8 eror + real*8 gamaan + real*8 gamaani + real*8 gamold + real*8 gams(2,3) + real*8 gasqd + real*8 gnh3 + real*8 gno3 + integer idow + integer idow2 + integer ip1 + integer ip2 + integer irh + real*8 k1a + real*8 kan + real*8 khat + real*8 kna + real*8 kph + real*8 kw + real*8 kw2 + real*8 man + real*8 mas + real*8 mnh4 + real*8 molnu + integer ndow + integer nnn + real*8 phibar + real*8 rh + real*8 rr1 + real*8 rr2 + real*8 so4 + real*8 t1 + real*8 t2 + real*8 t3 + real*8 t4 + real*8 t6 + real*8 temp + real*8 tmasshno3 + real*8 tnh4 + real*8 tno3 + real*8 toler1 + real*8 tso4 + real*8 twoso4 + real*8 wh2o + real*8 wh2oi + real*8 wsqd + real*8 xno3 + real*8 xxq + real*8 ynh4 + real*8 ynh4i + INTEGER I, J, L + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adaa = 0. + adah2o = 0. + do ip1 = 1, 3 + adan(ip1) = 0. + end do + adanh4 = 0. + adano3 = 0. + adaso4 = 0. + adbb = 0. + do ip1 = 1, 2 + adcat(ip1) = 0. + end do + adcc = 0. + addd = 0. + addisc = 0. + aderor = 0. + adgamaan = 0. + adgamold = 0. + do ip2 = 1, 3 + do ip1 = 1, 2 + adgams(ip1,ip2) = 0. + end do + end do + adgasqd = 0. + adgnh3 = 0. + adgno3 = 0. + adkw2 = 0. + adman = 0. + admas = 0. + admnh4 = 0. + adrr1 = 0. + adrr2 = 0. + adso4 = 0. + adtmasshno3 = 0. + adtnh4 = 0. + adtno3 = 0. + adtso4 = 0. + adtwoso4 = 0. + adwh2o = 0. + adwsqd = 0. + adxno3 = 0. + adxxq = 0. + adynh4 = 0. + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- +C---------------------------------------------- +C FUNCTION AND TAPE COMPUTATIONS +C---------------------------------------------- + so4 = in(1) + gno3 = in(2) + gnh3 = in(3) + ano3 = in(4) + anh4 = in(5) + rh = par(1) + temp = par(2) + tso4 = max(floor,so4/mwso4) + tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3) + tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4) + tmasshno3 = max(0.d0,gno3+ano3) + irh = nint(100.*rh) + irh = max(1,irh) + irh = min(99,irh) + t6 = 8.2d-11*temp + t1 = 298.d0/temp + t2 = log(t1) + t3 = t1-1.d0 + t4 = 1.d0+t2-t1 + kna = 2511000.d0*exp(29.17d0*t3+16.83d0*t4)*t6 + k1a = 0.00001805d0*exp((-(1.5d0*t3))+26.92d0*t4) + kw = 1.01d-14*exp((-(22.52d0*t3))+26.92d0*t4) + kph = 57.639d0*exp(13.79d0*t3-5.39d0*t4)*t6 + khat = kph*k1a/kw + kan = kna*khat + toler1 = 0.00001d0 + gamold = 1.d0 + gamaan = 0.1 + twoso4 = 2.*tso4 + ynh4 = twoso4 + call awater( irh,tso4,ynh4,tno3,ah2o ) + wh2o = 0.001d0*ah2o + aso4 = tso4*mwso4 + ahso4 = 0.d0 + ano3 = 0.d0 + anh4 = ynh4*mwnh4 + ynh4 = twoso4 + nnn = 0 + converged = .false. + idow = 0 + !The following section is used by TAMC to recompute idow. + !We comment this out and use the values from nitr_max +! do while (converged .eq. .false. .or. nnn .gt. 50 ) +! idow = idow+1 +! nnn = nnn+1 +! gasqd = gamaan*gamaan +! wsqd = wh2o*wh2o +! kw2 = kan*wsqd/gasqd +! aa = 1.-kw2 +! bb = twoso4+kw2*(tno3+tnh4-twoso4) +! cc = -(kw2*tno3*(tnh4-twoso4)) +! disc = bb*bb-4.*aa*cc +! if (aa .ne. 0.d0) then +! dd = sqrt(disc) +! xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd)) +! rr1 = xxq/aa +! rr2 = cc/xxq +! if (rr1*rr2 .lt. 0.d0) then +! xno3 = max(rr1,rr2) +! else +! xno3 = min(rr1,rr2) +! endif +! else +! xno3 = -(cc/bb) +! endif +! xno3 = min(xno3,tno3) +! call awater( irh,tso4,ynh4,xno3,ah2o ) +! wh2o = 0.001*ah2o +! man = xno3/wh2o +! mas = tso4/wh2o +! mnh4 = 2.*mas+man +! ynh4 = mnh4*wh2o +! cat(1) = 0. +! cat(2) = mnh4 +! an(1) = mas +! an(2) = man +! an(3) = 0. +! call actcof( cat,an,gams,molnu,phibar ) +! gamaan = gams(2,2) +! eror = abs(gamold-gamaan)/gamold +! gamold = gamaan +! if (eror .le. toler1) then +! aso4 = tso4*mwso4 +! ahso4 = 0. +! ano3 = xno3*mwno3 +! anh4 = ynh4*mwnh4 +! gno3 = max(floor,tmasshno3-ano3) +! gnh3 = mwnh3*max(floor,tnh4-ynh4) +! converged = .true. +! endif +! end do +! call adstore( 'memory_1_rpmares_idow',21,idow,4,1,1 ) +! out(1) = aso4 +! out(2) = ahso4 +! out(3) = ano3 +! out(4) = ah2o +! out(5) = anh4 +! out(6) = so4 +! out(7) = gno3 +! out(8) = gnh3 + + idow = nitr_max(I,J,L) + +C---------------------------------------------- +C ADJOINT COMPUTATIONS +C---------------------------------------------- + ano3 = in(4) + adgnh3 = adgnh3+adout(8) + adout(8) = 0.d0 + adgno3 = adgno3+adout(7) + adout(7) = 0.d0 + adso4 = adso4+adout(6) + adout(6) = 0.d0 + adanh4 = adanh4+adout(5) + adout(5) = 0.d0 + adah2o = adah2o+adout(4) + adout(4) = 0.d0 + adano3 = adano3+adout(3) + adout(3) = 0.d0 + adout(2) = 0.d0 + adaso4 = adaso4+adout(1) + adout(1) = 0.d0 + !call adresto( 'memory_1_rpmares_idow',21,idow,4,1,1 ) + ndow = idow + do idow = ndow, 1, -1 + gamaan = 0.1 + ynh4 = twoso4 + call awater( irh,tso4,ynh4,tno3,ah2o ) + wh2o = 0.001d0*ah2o + ynh4 = twoso4 + ! The following section is used to recompute gamaan, ynh4 and + ! wh20 at each iteration. Instead, comment this out and use + ! the checkpointed variables xxx_fwd. +! do idow2 = 1, idow-1 +! gasqd = gamaan*gamaan +! wsqd = wh2o*wh2o +! kw2 = kan*wsqd/gasqd +! aa = 1.-kw2 +! bb = twoso4+kw2*(tno3+tnh4-twoso4) +! cc = -(kw2*tno3*(tnh4-twoso4)) +! disc = bb*bb-4.*aa*cc +! if (aa .ne. 0.d0) then +! dd = sqrt(disc) +! xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd)) +! rr1 = xxq/aa +! rr2 = cc/xxq +! if (rr1*rr2 .lt. 0.d0) then +! xno3 = max(rr1,rr2) +! else +! xno3 = min(rr1,rr2) +! endif +! else +! xno3 = -(cc/bb) +! endif +! xno3 = min(xno3,tno3) +! call awater( irh,tso4,ynh4,xno3,ah2o ) +! wh2o = 0.001*ah2o +! man = xno3/wh2o +! mas = tso4/wh2o +! mnh4 = 2.*mas+man +! ynh4 = mnh4*wh2o +! cat(1) = 0. +! cat(2) = mnh4 +! an(1) = mas +! an(2) = man +! an(3) = 0. +! call actcof( cat,an,gams,molnu,phibar ) +! gamaan = gams(2,2) +! gamold = gamaan +! end do + IF ( idow .gt. 1 ) THEN + gamaan = gamaan_fwd(I,J,L,idow-1) + wh2o = wh2o_fwd(I,J,L,idow-1) + ynh4 = ynh4_fwd(I,J,L,idow-1) + ENDIF + gamold = gamaan + ynh4i = ynh4 + wh2oi = wh2o + gamaani = gamaan + gasqd = gamaan*gamaan + wsqd = wh2o*wh2o + kw2 = kan*wsqd/gasqd + aa = 1.-kw2 + bb = twoso4+kw2*(tno3+tnh4-twoso4) + cc = -(kw2*tno3*(tnh4-twoso4)) + disc = bb*bb-4.*aa*cc + if (aa .ne. 0.d0) then + dd = sqrt(disc) + xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd)) + rr1 = xxq/aa + rr2 = cc/xxq + if (rr1*rr2 .lt. 0.d0) then + xno3 = max(rr1,rr2) + else + xno3 = min(rr1,rr2) + endif + else + xno3 = -(cc/bb) + endif + xno3 = min(xno3,tno3) + call awater( irh,tso4,ynh4,xno3,ah2o ) + wh2o = 0.001*ah2o + man = xno3/wh2o + mas = tso4/wh2o + mnh4 = 2.*mas+man + ynh4 = mnh4*wh2o + cat(1) = 0. + cat(2) = mnh4 + an(1) = mas + an(2) = man + an(3) = 0. + call actcof( cat,an,gams,molnu,phibar ) + gamaan = gams(2,2) + eror = abs(gamold-gamaan)/gamold + if (eror .le. toler1) then + ano3 = xno3*mwno3 + adwh2o = adwh2o+1000*adah2o + adah2o = 0. + adtnh4 = adtnh4+adgnh3*mwnh3*(0.5-sign(0.5,floor-(tnh4-ynh4))) + adynh4 = adynh4-adgnh3*mwnh3*(0.5-sign(0.5,floor-(tnh4-ynh4))) + adgnh3 = 0. + adano3 = adano3-adgno3*(0.5-sign(0.5,floor-(tmasshno3-ano3))) + adtmasshno3 = adtmasshno3+adgno3*(0.5-sign(0.5,floor- + $(tmasshno3-ano3))) + adgno3 = 0. + adynh4 = adynh4+adanh4*mwnh4 + adanh4 = 0. + adxno3 = adxno3+adano3*mwno3 + adano3 = 0. + adtso4 = adtso4+adaso4*mwso4 + adaso4 = 0. + endif + adgamaan = adgamaan+adgamold + adgamold = 0. + aderori = aderor/gamold + adgamold = adgamold-aderor*(abs(gamold-gamaan)/(gamold*gamold)) + adgamaan = adgamaan-aderori*sign(1.,gamold-gamaan) + adgamold = adgamold+aderori*sign(1.,gamold-gamaan) + aderor = 0. + adgams(2,2) = adgams(2,2)+adgamaan + adgamaan = 0. + call adactcof( cat,an,adcat,adan,adgams ) + adan(3) = 0. + adman = adman+adan(2) + adan(2) = 0. + admas = admas+adan(1) + adan(1) = 0. + admnh4 = admnh4+adcat(2) + adcat(2) = 0. + adcat(1) = 0. + admnh4 = admnh4+adynh4*wh2o + adwh2o = adwh2o+adynh4*mnh4 + adynh4 = 0. + adman = adman+admnh4 + admas = admas+2*admnh4 + admnh4 = 0. + adtso4 = adtso4+admas/wh2o + adwh2o = adwh2o-admas*(tso4/(wh2o*wh2o)) + admas = 0. + adwh2o = adwh2o-adman*(xno3/(wh2o*wh2o)) + adxno3 = adxno3+adman/wh2o + adman = 0. + adah2o = adah2o+0.001*adwh2o + adwh2o = 0. + ynh4 = ynh4i + call adawater( irh,tso4,ynh4,xno3,adtso4,adynh4,adxno3,adah2o ) + if (aa .ne. 0.d0) then + dd = sqrt(disc) + xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd)) + rr1 = xxq/aa + rr2 = cc/xxq + if (rr1*rr2 .lt. 0.d0) then + xno3 = max(rr1,rr2) + else + xno3 = min(rr1,rr2) + endif + else + xno3 = -(cc/bb) + endif + adtno3 = adtno3+adxno3*(0.5-sign(0.5,tno3-xno3)) + adxno3 = adxno3*(0.5+sign(0.5,tno3-xno3)) + if (aa .ne. 0.d0) then + if (rr1*rr2 .lt. 0.d0) then + adrr1 = adrr1+adxno3*(0.5+sign(0.5,rr1-rr2)) + adrr2 = adrr2+adxno3*(0.5-sign(0.5,rr1-rr2)) + adxno3 = 0. + else + adrr1 = adrr1+adxno3*(0.5+sign(0.5,rr2-rr1)) + adrr2 = adrr2+adxno3*(0.5-sign(0.5,rr2-rr1)) + adxno3 = 0. + endif + adcc = adcc+adrr2/xxq + adxxq = adxxq-adrr2*(cc/(xxq*xxq)) + adrr2 = 0. + adaa = adaa-adrr1*(xxq/(aa*aa)) + adxxq = adxxq+adrr1/aa + adrr1 = 0. + adbb = adbb-0.5d0*adxxq + addd = addd-0.5d0*adxxq*sign(1.d0,bb) + adxxq = 0. + addisc = addisc+addd*(1./(2.*sqrt(disc))) + addd = 0. + else + adbb = adbb+adxno3*(cc/(bb*bb)) + adcc = adcc-adxno3/bb + adxno3 = 0. + endif + adaa = adaa-4*addisc*cc + adbb = adbb+2*addisc*bb + adcc = adcc-4*addisc*aa + addisc = 0. + adkw2 = adkw2-adcc*tno3*(tnh4-twoso4) + adtnh4 = adtnh4-adcc*kw2*tno3 + adtno3 = adtno3-adcc*kw2*(tnh4-twoso4) + adtwoso4 = adtwoso4+adcc*kw2*tno3 + adcc = 0. + adkw2 = adkw2+adbb*(tno3+tnh4-twoso4) + adtnh4 = adtnh4+adbb*kw2 + adtno3 = adtno3+adbb*kw2 + adtwoso4 = adtwoso4+adbb*(1-kw2) + adbb = 0. + adkw2 = adkw2-adaa + adaa = 0. + adgasqd = adgasqd-adkw2*(kan*wsqd/(gasqd*gasqd)) + adwsqd = adwsqd+adkw2*(kan/gasqd) + adkw2 = 0. + wh2o = wh2oi + adwh2o = adwh2o+2*adwsqd*wh2o + adwsqd = 0. + gamaan = gamaani + adgamaan = adgamaan+2*adgasqd*gamaan + adgasqd = 0. + end do + adtwoso4 = adtwoso4+adynh4 + adynh4 = 0. + adah2o = adah2o+0.001d0*adwh2o + adwh2o = 0. + ynh4 = twoso4 + call adawater( irh,tso4,ynh4,tno3,adtso4,adynh4,adtno3,adah2o ) + adtwoso4 = adtwoso4+adynh4 + adynh4 = 0. + adtso4 = adtso4+2*adtwoso4 + adtwoso4 = 0. + ano3 = in(4) + adano3 = adano3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3))) + adgno3 = adgno3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3))) + adtmasshno3 = 0. + anh4 = in(5) + adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh4) + adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/ + $mwnh4)))/mwnh3) + adtnh4 = 0. + adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwno3) + adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/ + $mwhno3)))/mwhno3) + adtno3 = 0. + adso4 = adso4+adtso4*((0.5-sign(0.5,floor-so4/mwso4))/mwso4) + adtso4 = 0. + adin(5) = adin(5)+adanh4 + adanh4 = 0. + adin(4) = adin(4)+adano3 + adano3 = 0. + adin(3) = adin(3)+adgnh3 + adgnh3 = 0. + adin(2) = adin(2)+adgno3 + adgno3 = 0. + adin(1) = adin(1)+adso4 + adso4 = 0. + + + end SUBROUTINE ADRPMARES_6_D5 + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE RPMARES_ADJ_MOD diff --git a/code/adjoint/schem_adj.f b/code/adjoint/schem_adj.f new file mode 100644 index 0000000..e87cdfa --- /dev/null +++ b/code/adjoint/schem_adj.f @@ -0,0 +1,365 @@ +! $Id: schem_adj.f,v 1.1 2010/05/07 20:39:47 daven Exp $ + SUBROUTINE SCHEM_ADJ +! +!****************************************************************************** +! Subroutine SCHEM_ADJ performs adjoint of strat chem. (dkh, 05/02/10) +! +! Based on forward model routine SCHEM (qli, bmy, 11/20/1999, 10/25/05). +! +! NOTES: +! (1 ) Use ITS_A_NEW_MONTH instead of older method (dkh, 05/02/10) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DAO_MOD, ONLY : AD, T + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : GET_MONTH, GET_TAU + USE TIME_MOD, ONLY : GET_TS_CHEM, TIMESTAMP_STRING + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : TRACER_MW_KG, XNUMOLAIR + USE TRACERID_MOD, ONLY : IDTACET, IDTALD2, IDTALK4, IDTC2H6 + USE TRACERID_MOD, ONLY : IDTC3H8, IDTCH2O, IDTH2O2, IDTHNO4 + USE TRACERID_MOD, ONLY : IDTISOP, IDTMACR, IDTMEK, IDTMP + USE TRACERID_MOD, ONLY : IDTMVK, IDTPMN, IDTPRPE, IDTR4N2 + USE TRACERID_MOD, ONLY : IDTRCHO + USE TRANSFER_MOD, ONLY : TRANSFER_ZONAL + USE TROPOPAUSE_MOD, ONLY : GET_MIN_TPAUSE_LEVEL, ITS_IN_THE_STRAT + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + + INTEGER :: I, IOS, J, L, N, NN, LMIN + INTEGER, SAVE :: MONTHSAVE = 0 + + ! Number of photolysis species (currently is 13) + INTEGER, PARAMETER :: NSPHOTO = 13 + + ! Tracers that undergo photolysis loss in the stratosphere + INTEGER :: SPHOTOID(NSPHOTO) = (/ + & 3, 8, 9, 10, 11, 12, 13, + & 14, 17, 20, 22, 23, 24 /) + + ! Character variables + CHARACTER(LEN=16 ) :: STAMP + CHARACTER(LEN=255) :: FILENAME + + ! REAL*4 arrays -- for reading from binary data files + REAL*4 :: ARRAY(1,JGLOB,LGLOB) + REAL*4, ALLOCATABLE, SAVE :: STRATOH(:,:) + REAL*4, ALLOCATABLE, SAVE :: SJVALUE(:,:,:) + REAL*4, ALLOCATABLE, SAVE :: COPROD(:,:) + REAL*4, ALLOCATABLE, SAVE :: COLOSS(:,:) + + ! REAL*8 variables + REAL*8 :: k0, k1, k2, k3, XTAU + REAL*8 :: DTCHEM, RDLOSS, T1L, M, TK, RC + + ! External functions + REAL*8, EXTERNAL :: BOXVL + + !================================================================= + ! SCHEM_ADJ begins here! + !================================================================= + + ! Chemistry timestep [s] + DTCHEM = GET_TS_CHEM() * 60d0 + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 100 ) STAMP + 100 FORMAT( ' - SCHEM_ADJ: Strat chemistry adjoint at ', a ) + + !================================================================= + ! If it is the first call to SCHEM, allocate arrays for reading + ! data. These arrays are declared SAVE so they will be preserved + ! between calls. + !================================================================= + IF ( FIRST ) THEN + ALLOCATE( STRATOH( JJPAR, LLPAR ), STAT=IOS ) + IF ( IOS /= 0 ) CALL ALLOC_ERR( 'STRATOH' ) + STRATOH = 0e0 + + ALLOCATE( SJVALUE( JJPAR, LLPAR, NSPHOTO ), STAT=IOS ) + IF ( IOS /= 0 ) CALL ALLOC_ERR( 'SJVALUE' ) + SJVALUE = 0e0 + + ALLOCATE( COPROD( JJPAR, LLPAR ), STAT=IOS ) + IF ( IOS /= 0 ) CALL ALLOC_ERR( 'COPROD' ) + COPROD = 0e0 + + ALLOCATE( COLOSS( JJPAR, LLPAR ), STAT=IOS ) + IF ( IOS /= 0 ) CALL ALLOC_ERR( 'COLOSS' ) + COLOSS = 0e0 + ENDIF + + !================================================================= + ! If it is a new month (or the first call to SCHEM), + ! do the following: + ! + ! (1) Read archived J-values and store in SJVALUE + ! (2) Read archived CO production rates and store in COPROD + ! (3) Read archived CO loss rates and store in COLOSS + ! + ! NOTES + ! (a) All of the above-mentioned data are stored in binary punch + ! files, for ease of use. + ! + ! (b) STRATOH, SJVALUE, CO_PROD, and CO_LOSS are now declared + ! as both ALLOCATABLE and SAVE. If SCHEM is called, then + ! data will be declared for these arrays, and the values in + ! these arrays will be preserved between calls. + ! + ! (c) If SCHEM is never called (i.e. if you are running another + ! type of chemistry simulation), then memory never gets + ! allocated to STRATOH, SJVALUE, CO_PROD, and CO_LOSS. + ! This saves on computational resources. + !================================================================= + ! adj_group: now use ITS_A_NEW_MONTH + !IF ( GET_MONTH() /= MONTHSAVE .or. FIRST ) THEN + ! MONTHSAVE = GET_MONTH() + IF ( ITS_A_NEW_MONTH() ) THEN + + ! TAU value at the beginning of this month + XTAU = GET_TAU0( GET_MONTH(), 1, 1985 ) + + !============================================================== + ! Read this month's OH + !============================================================== + FILENAME = TRIM( DATA_DIR ) // 'stratOH_200203/stratOH.' // + & GET_NAME_EXT() // '.' // + & GET_RES_EXT() + + ! Read data + CALL READ_BPCH2( FILENAME, 'CHEM-L=$', 1, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR) + CALL TRANSFER_ZONAL( ARRAY(1,:,:), STRATOH ) + + !============================================================== + ! Read in monthly mean archived J-values + !============================================================== + FILENAME = TRIM( DATA_DIR ) // 'stratjv_200203/stratjv.' // + & GET_NAME_EXT() // '.' // + & GET_RES_EXT() + + DO NN = 1, NSPHOTO + N = SPHOTOID(NN) + + ! Read data + CALL READ_BPCH2( FILENAME, 'JV-MAP-$', N, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR) + CALL TRANSFER_ZONAL( ARRAY(1,:,:), SJVALUE(:,:,NN) ) + ENDDO + + !============================================================== + ! Read in CO production rates + !============================================================== + FILENAME = TRIM( DATA_DIR ) // 'pco_lco_200203/COprod.' // + & GET_NAME_EXT() // '.' // + & GET_RES_EXT() + + ! Read data + CALL READ_BPCH2( FILENAME, 'PORL-L=$', 9, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR) + CALL TRANSFER_ZONAL( ARRAY(1,:,:), COPROD ) + + !============================================================== + ! Read in CO loss rates + !============================================================== + FILENAME = TRIM( DATA_DIR ) // 'pco_lco_200203/COloss.' // + & GET_NAME_EXT() // '.' // + & GET_RES_EXT() + + ! Read data + CALL READ_BPCH2( FILENAME, 'PORL-L=$', 10, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR) + CALL TRANSFER_ZONAL( ARRAY(1,:,:), COLOSS ) + + ENDIF + + !================================================================= + ! Do photolysis for selected tracers with this + ! month's archived J-values + !================================================================= + + ! Get the minimum level extent of the ann mean tropopause + LMIN = GET_MIN_TPAUSE_LEVEL() + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, NN ) +!$OMP+SCHEDULE( DYNAMIC ) + DO NN = 1, NSPHOTO + N = SPHOTOID(NN) + + DO L = LMIN, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Only proceed for stratospheric boxes + IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN + + ! fwd code: + !STT(I,J,L,N) = STT(I,J,L,N) * + ! EXP( -SJVALUE(J,L,NN) * DTCHEM ) + ! adj code: + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) * + & EXP( -SJVALUE(J,L,NN) * DTCHEM ) + ENDIF + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !print*, 'In schem, done with photolysis' + + !================================================================= + ! CO is special -- + ! use archived P, L rates for CO chemistry in stratosphere + !================================================================= + CALL CO_STRAT_PL_ADJ( COPROD, COLOSS ) + + !================================================================= + ! Reaction with OH -- compute rate constants for each tracer + !================================================================= + !print*, 'In schem, before reaction with OH' + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, M, TK, RC, k0, k1, RDLOSS, T1L ) +!$OMP+SCHEDULE( DYNAMIC ) + DO N = 1, N_TRACERS + DO L = LMIN, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Only proceed for stratospheric boxes + IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN + + ! Density of air at grid box (I,J,L) in molec/cm3 + M = AD(I,J,L) / BOXVL(I,J,L) * XNUMOLAIR + + ! Temperature at grid box (I,J,L) in K + TK = T(I,J,L) + + ! Select proper reaction rate w/ OH for the given tracer + ! Some rates are temperature or density dependent + IF ( N == IDTALK4 ) THEN + RC = 8.20D-12 * EXP( -300.D0 / TK ) + + ELSE IF ( N == IDTISOP ) THEN + RC = 2.55D-11 * EXP( 410.D0 / TK ) + + ELSE IF ( N == IDTH2O2 ) THEN + RC = 2.90D-12 * EXP( -160.D0 / TK ) + + ELSE IF ( N == IDTACET ) THEN + RC = 1.70D-12 * EXP( -600.D0 / TK ) + + ELSE IF ( N == IDTMEK ) THEN + RC = 2.92D-13 * EXP( 414.D0 / TK ) + + ELSE IF ( N == IDTALD2 ) THEN + RC = 1.40D-12 * EXP( -1860.D0 / TK ) + + ELSE IF ( N == IDTRCHO ) THEN + RC = 2.00D-11 + + ELSE IF ( N == IDTMVK ) THEN + RC = 4.13D-12 * EXP( 452.D0 / TK ) + + ELSE IF ( N == IDTMACR ) THEN + RC = 1.86D-11 * EXP( -175.D0 / TK ) + + ELSE IF ( N == IDTPMN ) THEN + RC = 3.60D-12 + + ELSE IF ( N == IDTR4N2 ) THEN + RC = 1.30D-12 + + ELSE IF ( N == IDTPRPE ) THEN + k0 = 8.0D-27 * ( 300.D0 / TK )**3.5 + k1 = 3.0D-11 + + RC = k1 * k0 * M / ( k1 + k0*M ) + RC = RC * 0.5 ** (1 / ( 1 + LOG10( k0*M/k1 )**2 ) ) + + ELSE IF ( N == IDTC3H8 ) THEN + RC = 8.00D-12 * EXP( -590.D0 / TK ) + + ELSE IF ( N == IDTCH2O ) THEN + RC = 1.00D-12 + + ELSE IF ( N == IDTC2H6 ) THEN + RC = 7.9D-12 * EXP( -1030.D0 / TK ) + + ELSE IF ( N == IDTHNO4 ) THEN + RC = 1.30D-12 * EXP( 380.D0 / TK ) + + ELSE IF ( N == IDTMP ) THEN + RC = 1.14D-12 * EXP( 200.D0 / TK ) + + ELSE + RC = 0d0 + + ENDIF + + ! Compute loss with OH based on the rate constants from above + ! Cap RDLOSS so that it does not exceed 1.0 (bmy, 5/4/00) + RDLOSS = RC * STRATOH(J,L) * DTCHEM + RDLOSS = MIN( RDLOSS, 1d0 ) + + ! T1L is the absolute amount of STT lost to rxn with OH + ! Subtract T1L from STT + ! fwd code: + !T1L = STT(I,J,L,N) * RDLOSS + !STT(I,J,L,N) = STT(I,J,L,N) - T1L + ! adj code: + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) * ( 1D0 - RDLOSS ) + + + ! Oxidation of PRPE as source of ACET with 80% yield + IF ( N == IDTPRPE ) THEN + ! fwd code: + !STT(I,J,L,IDTACET) = STT(I,J,L,IDTACET) + + ! 0.8d0 * T1L * + ! TRACER_MW_KG(IDTACET) / TRACER_MW_KG(IDTPRPE) + ! adj code: + STT_ADJ(I,J,L,IDTACET) = STT_ADJ(I,J,L,IDTACET) * + & 0.8d0 * RDLOSS * + & TRACER_MW_KG(IDTACET) / TRACER_MW_KG(IDTPRPE) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Set FIRST = .FALSE. -- we have been thru SCHEM at least once now + FIRST = .FALSE. + + ! Return to calling program + END SUBROUTINE SCHEM_ADJ diff --git a/code/adjoint/setemis_adj.f b/code/adjoint/setemis_adj.f new file mode 100644 index 0000000..d4b7c62 --- /dev/null +++ b/code/adjoint/setemis_adj.f @@ -0,0 +1,884 @@ +! $Id: setemis_adj.f,v 1.1 2010/04/01 07:09:43 daven Exp $ + SUBROUTINE SETEMIS_ADJ( ) +! +!****************************************************************************** +! Subroutine SETEMIS_ADJ passes adjoints from SMVGEAR array adjoint REMIS_ADJ +! back to GEOS-Chem emission adjoint arrays, e.g., BIOFUEL_ADJ +! +! Based on forward code SETEMIS (lwh, jyl, gmg, djj, bdf, bmy, 6/8/98, 6/11/08) +! +! Variables taken from F90 Modules: +! ============================================================================ +! (1 ) BIOFUEL (REAL*8 ) : Biofuel burning emissions [molec (C)/cm3/s ] +! (2 ) BFTRACE (INTEGER) : Index array for biofuels [CTM tracer # ] +! (3 ) NBFTRACE (INTEGER) : Number of biofuel species [unitless ] +! (4 ) BURNEMIS (REAL*8 ) : Biomass burning emissions [molec (C)/cm3/s ] +! (5 ) BIOTRCE (INTEGER) : Index array for bioburn [CTM tracer # ] +! (6 ) NBIOTRCE (INTEGER) : Number of bioburn species [unitless ] +! (7 ) JLOP (INTEGER) : SMVGEAR grid box index [unitless ] +! (8 ) REMIS (REAL*8 ) : SMVGEAR emissions array [molec species/cm3/s] +! (9 ) VOLUME (REAL*8 ) : SMVGEAR volume array [cm3 ] +! +! NOTES: +! (1 ) Original code from Harvard Tropospheric Chemistry Module for 3-D +! applications by Larry Horowitz, Jinyou Liang, Gerry Gardner, +! Prof. Daniel Jacob of Harvard University (Release V2.0) +! (2 ) New version 3.0 by Bob Yantosca to place NOx emissions into boxes +! above the surface. (bmy, 6/8/98) +! (3 ) Also now do chemistry up to the location of the annual mean +! tropopause (bmy, 12/9/99) +! (4 ) BURNEMIS is now dynamically allocatable and is contained in F90 +! module "biomass_mod.f". BIOTRCE and NBIOTRCE are also contained +! in "biomass_mod.f". (bmy, 9/12/00) +! (5 ) BIOFUEL is now dynamically allocatable and is contained in F90 +! module "biofuel_mod.f". BFTRACE and NBFTRACE are also contained +! in "biofuel_mod.f" (bmy, 9/12/00, 4/17/01) +! (6 ) BURNEMIS and BIOFUEL are now treated as true global arrays, +! and need to be referenced by the global offset variables +! IREF = I + I0 and JREF = J + J0 (bmy, 9/12/00) +! (7 ) Now reference JLOP, REMIS, VOLUME from F90 module "comode_mod.f", +! in order to save memory (bmy, 10/19/00) +! (8 ) Now add in up to NBFTRACE biofuel species (bmy, 4/17/01) +! (9 ) Add new subroutine header, updated comments, cosmetic changes. +! (bmy, 4/17/01) +! (10) Updated comments -- GEMISNOX is [molec/cm3/s]. (bdf, bmy, 6/7/01) +! (11) For GEOS-3, we now distributes surface emissions throughout the +! boundary layer. This is necessary since the first couple of GEOS-3 +! surface layers are very thin. Piling up of emissions into a small +! layer will cause SMVGEAR to choke. (bdf, bmy, 6/15/01) +! (12) Also now reference BFTRACE and NBFTRACE from "biofuel_mod.f", +! and reference AD12 from "diag_mod.f". (bdf, bmy, 6/15/01) +! (13) For GEOS-1, GEOS-STRAT, emit into the surface layer, as we did +! in prior versions. (bmy, 6/26/01) +! (14) Bug fix: corrected a typo for the biofuel emissions (bmy, 7/10/01) +! (15) Bug fix: make sure BIOMASS and BIOFUEL, and SOIL NOx emissions have +! units of [molec/box/s] before distributing thru the boundary layer. +! This involves multiplication by VOLUME(JLOOP1) and division by +! VOLUME(JLOOP). (bmy, 7/16/01) +! (16) XTRA2(IREF,JREF,5) is now XTRA2(I,J). BIOFUEL(:,IREF,JREF) is now +! BIOFUEL(:,I,J). BURNEMIS(:,IREF,JREF) is now BURNEMIS(:,I,J). +! Replace PW(I,J) with P(I,J). (bmy, 9/28/01) +! (17) Removed obsolete code from 9/01 (bmy, 10/24/01) +! (18) Now references GET_PEDGE from "pressure_mod.f", to compute P at +! the bottom edge of grid box (I,J,L). (dsa, bdf, bmy, 8/21/02) +! (19) Now reference IDTNOX, IDENOX, etc from "tracerid_mod.f" (bmy, 11/6/02) +! (20) Remove references to IREF, JREF (bmy, 2/11/03) +! (21) NEMIS is now NEMIS(NCS) for SMVGEAR II (gcc, bdf, bmy, 4/1/03) +! (22) Added parallel loop over N. Also directly substituted JLOP(I,J,1) +! for all instances of JLOOP1. Updated comments. (hamid, bmy, 3/19/04) +! (23) Bug fix for COMPAQ compiler...do not use EXIT from w/in parallel loop. +! (auvray, bmy, 11/29/04) +! (24) Now replace XTRA2 with GET_PBL_TOP_L in "pbl_mix_mod.f". Now remove +! reference to CMN, it's obsolete. Now references GET_TPAUSE_LEVEL +! from "tropopause_mod.f" (bmy, 8/22/05) +! (25) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (26) Now updated for new "biomass_mod.f" (bmy, 4/5/06) +! (27) Now account for the different definition of tropopause in case +! of variable tropopause. The BIOMASS array from "biomass_mod.f" is +! now in units of [molec CO/cm2/s]. Adjust unit conversion accordingly. +! Also replace NBIOMAX with NBIOMAX_GAS, since aerosol biomass is +! handled elsewhere. (bdf, phs, bmy, 9/27/06) +! (28) Now replace GEMISNOX array (from CMN_NOX) with module arrays +! EMIS_LI_NOx and EMIS_AC_NOx (ltm, bmy, 10/3/07) +! (29) Bug fix: resize EMISRR to be consistent w/ CMN_O3 (bmy, jaf, 6/11/08) +!****************************************************************************** +! + ! References to F90 modules + USE AIRCRAFT_NOX_MOD, ONLY : EMIS_AC_NOx + USE BIOFUEL_MOD, ONLY : BIOFUEL, BFTRACE, NBFTRACE + USE BIOMASS_MOD, ONLY : BIOMASS, BIOTRCE, NBIOMAX_GAS + USE COMODE_MOD, ONLY : JLOP, REMIS, VOLUME + USE COMODE_MOD, ONLY : IYSAVE + USE DIAG_MOD, ONLY : AD12 + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LVARTROP + USE LIGHTNING_NOX_MOD, ONLY : EMIS_LI_NOx + USE PBL_MIX_MOD, ONLY : GET_PBL_TOP_L + USE PRESSURE_MOD, ONLY : GET_PEDGE + USE TRACERID_MOD, ONLY : CTRMB, IDEMIS, IDENOX + USE TROPOPAUSE_MOD, ONLY : GET_TPAUSE_LEVEL + + ! Ship plume emissions moved from calcrate.F + USE EDGAR_MOD, ONLY : GET_EDGAR_NOx + USE ICOADS_SHIP_MOD, ONLY : GET_ICOADS_SHIP + USE EMEP_MOD, ONLY : GET_EMEP_ANTHRO, GET_EUROPE_MASK + USE EMISSIONS_MOD, ONLY : NOx_SCALING + USE COMODE_MOD, ONLY : CSPEC, AIRDENS, CSPEC_ADJ + USE COMODE_MOD, ONLY : CSPEC_ORIG, CSPEC_FOR_KPP + USE LOGICAL_MOD, ONLY : LDRYD, LPRT + USE LOGICAL_MOD, ONLY : LICOADSSHIP, LEDGARSHIP, LEMEPSHIP + USE DRYDEP_MOD, ONLY : SHIPO3DEP + USE ADJ_ARRAYS_MOD, ONLY : SHIPO3DEP_ADJ + USE TRACERID_MOD, ONLY : IDTNO, IDTNOX, IDTHNO3 + USE TRACERID_MOD, ONLY : IDO3, IDHNO3, IDNO2, IDNO + USE TRACERID_MOD, ONLY : IDEHNO3, IDEOX + USE DAO_MOD, ONLY : BXHEIGHT, SUNCOS, SUNCOS_5hr + USE PARANOX_MOD, ONLY : INTERPOLATE_LUT2 + USE PARANOX_ADJ_MOD, ONLY : INTERPOLATE_LUT2_ADJ + USE COMODE_MOD, ONLY : CHK_CSPEC + + USE ADJ_ARRAYS_MOD, ONLY : NADJ_EANTHRO + USE ADJ_ARRAYS_MOD, ONLY : NADJ_EBIOMASS + USE ADJ_ARRAYS_MOD, ONLY : NADJ_EBIOFUEL + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENOX_so + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENOX_li + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENOX_ac + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : REMIS_ADJ + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_NOX" ! GEMISNOX2 +# include "CMN_O3" ! EMISRR, EMISRRN +# include "comode.h" ! IDEMS, NEMIS + + ! Local variables + LOGICAL :: IS_LI_NOx, IS_AC_NOx + INTEGER :: I, J, JLOOP, JLOOP1, LTROP + INTEGER :: L, LL, N, NN, NBB, NBF, TOP + REAL*8 :: COEF1, TOTPRES, DELTPRES + REAL*8 :: EMIS_BL, NOXTOT, TOTAL, A_CM2 + + + REAL*8 :: SHIP, TOTO3, JNO2, JO1D + REAL*8 :: DTSRCE, AREA_CM2 + REAL*4 :: FRACTION_NOX, INT_OPE + INTEGER :: NK + CHARACTER*8 :: SPECNAME + REAL*8, EXTERNAL :: FJFUNC + + REAL*8 :: EMIS_BL_ADJ + REAL*4 :: FRACTION_NOX_ADJ + REAL*4 :: INT_OPE_ADJ + REAL*8 :: SHIP_ADJ + REAL*8 :: TOTO3_ADJ + REAL*8 :: O3_ADJ + REAL*8 :: NO_ADJ + REAL*8 :: NO2_ADJ + + INTEGER :: M + + !================================================================= + ! SETEMIS_ADJ begins here! + !================================================================= + + ! Test if the EMIS_LI_NOx and EMIS_AC_NOx arrays are allocated + IS_LI_NOx = ALLOCATED( EMIS_LI_NOx ) + IS_AC_NOX = ALLOCATED( EMIS_AC_NOX ) + + M = 1 + + NCS = NCSURBAN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( N, NN, NBB, NBF, I ) +!$OMP+PRIVATE( J, L, JLOOP, COEF1, TOP ) +!$OMP+PRIVATE( TOTPRES, NOXTOT, DELTPRES, EMIS_BL, A_CM2 ) +!$OMP+PRIVATE( TOTO3, SHIP, AREA_CM2, FRACTION_NOX, INT_OPE ) +!$OMP+PRIVATE( NK, JNO2, JO1D, SPECNAME ) +!$OMP+PRIVATE( EMIS_BL_ADJ, TOTO3_ADJ,INT_OPE_ADJ ) +!$OMP+PRIVATE( FRACTION_NOX_ADJ,SHIP_ADJ ) +!$OMP+PRIVATE( O3_ADJ, NO_ADJ, NO2_ADJ ) +!$OMP+SCHEDULE( DYNAMIC ) + + ! Loop over emission species + DO N = 1, NEMIS(NCS) + + ! Get CTM tracer number NN corresponding to emission species N + NN = IDEMS(N) + IF ( NN == 0 ) CYCLE + + ! We have to search for the biomass burning species in + ! BIOTRCE with the same CTM tracer number NN as in IDEMS + NBB = 0 + IF ( ALLOCATED( BIOMASS ) ) THEN + DO I = 1, NBIOMAX_GAS + IF ( BIOTRCE(I) == NN ) THEN + NBB = I +#if defined( COMPAQ ) + ! COMPAQ has an issue with EXIT from w/in parallel loop + ! (auvray, bmy, 11/29/04) +#else + EXIT +#endif + ENDIF + ENDDO + ENDIF + + ! We have to search for the biofuel burning species in + ! BFTRACE with the same CTM tracer number NN as in IDEMS + NBF = 0 + IF ( ALLOCATED( BIOFUEL ) ) THEN + DO I = 1, NBFTRACE + IF ( BFTRACE(I) == NN ) THEN + NBF = I +#if defined( COMPAQ ) + ! COMPAQ has an issue with EXIT from w/in parallel loop + ! (auvray, bmy, 11/29/04) +#else + EXIT +#endif + ENDIF + ENDDO + ENDIF + + ! COEF1 = molecules of emission species / molecules of tracer + COEF1 = 1.0 + CTRMB(NN, IDEMIS(NN)) + + ! Loop over Lat and Long boxes + DO J = 1, NLAT + DO I = 1, NLONG + + !=========================================================== + ! For GEOS-3: distribute surface emissions throughout the + ! entire boundary layer. Define some variables here. + ! (bdf, 6/15/01) + !=========================================================== + + ! Top level of the boundary layer + ! guard for b.l. being in first level. + TOP = FLOOR( GET_PBL_TOP_L( I, J ) ) + IF ( TOP == 0 ) TOP = 1 + + ! Pressure thickness of entire boundary layer [hPa] + TOTPRES = GET_PEDGE(I,J,1) - GET_PEDGE(I,J,TOP+1) + + !=========================================================== + ! Adjoint of biofuel burning source [molec/cm3/s] + !=========================================================== + IF ( NBF /= 0 ) THEN + DO L = 1, TOP + JLOOP = JLOP(I,J,L) + + IF ( JLOOP /= 0 ) THEN + + ! fwd code: + !REMIS(JLOOP,N) = REMIS(JLOOP,N) + + ! ( EMIS_BL / VOLUME(JLOOP) ) + ! adj code: + EMIS_BL_ADJ = REMIS_ADJ(JLOOP,N) / VOLUME(JLOOP) + + ! recalc DELTPRES + ! Thickness of level L [mb] + DELTPRES = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + ! fwd code: + ! Store in EMIS_BL. + !EMIS_BL = ( BIOFUEL(NBF,I,J) * + ! VOLUME( JLOP(I,J,1) ) / COEF1 ) * + ! ( DELTPRES / TOTPRES ) + ! * BIOFUEL_ICS(I,J,NBF) + IF ( NADJ_EBIOFUEL(NN) > 0 ) THEN + EMS_SF_ADJ(I,J,M,NADJ_EBIOFUEL(NN)) + & = EMS_SF_ADJ(I,J,M,NADJ_EBIOFUEL(NN)) + & + ( BIOFUEL(NBF,I,J) + & * VOLUME( JLOP(I,J,1) ) / COEF1 ) + & * ( DELTPRES / TOTPRES ) + & * EMIS_BL_ADJ + ENDIF + + ENDIF + EMIS_BL_ADJ = 0d0 + ENDDO + ENDIF + + !=========================================================== + ! Adjoint of biomass burning source [molec/cm3/s] + !=========================================================== + IF ( NBB /= 0 ) THEN + DO L = 1, TOP + JLOOP = JLOP(I,J,L) + + IF ( JLOOP /= 0 ) THEN + + ! fwd code: + !REMIS(JLOOP,N) = REMIS(JLOOP,N) + + & ! ( EMIS_BL / VOLUME(JLOOP) ) + ! adj code: + EMIS_BL_ADJ = REMIS_ADJ(JLOOP,N) / VOLUME(JLOOP) + + ! Thickness of level L [mb] + DELTPRES = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + ! Grid box area [cm2] + A_CM2 = GET_AREA_CM2( IYSAVE(JLOOP) ) + + ! fwd code: + !EMIS_BL = ( BIOMASS(I,J,NBB) * A_CM2 / COEF1 ) * + ! ( DELTPRES / TOTPRES ) + ! adj code: + IF ( NADJ_EBIOMASS(NN) > 0 ) THEN + EMS_SF_ADJ(I,J,M,NADJ_EBIOMASS(NN)) + & = EMS_SF_ADJ(I,J,M,NADJ_EBIOMASS(NN)) + & + BIOMASS(I,J,NBB) * A_CM2 / COEF1 + & * ( DELTPRES / TOTPRES ) + & * EMIS_BL_ADJ + ENDIF + + + ENDIF + EMIS_BL_ADJ = 0d0 + ENDDO + ENDIF + + !=========================================================== + ! Adjoints of non-NOx sources + !=========================================================== + IF ( N /= IDENOX ) THEN + + !======================================================== + ! Anthropogenic tracers other than NOx [molec/box/s] + ! Distribute emissions thru the entire boundary layer + !======================================================== + DO L = 1, TOP + JLOOP = JLOP(I,J,L) + + IF ( JLOOP /= 0 ) THEN + + ! Thickness of level L [mb] + DELTPRES = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + ! fwd code: + !REMIS(JLOOP,N) = EMIS_BL / VOLUME(JLOOP) + ! adj code: + EMIS_BL_ADJ = REMIS_ADJ(JLOOP,N) / VOLUME(JLOOP) + + ! fwd code: + !EMIS_BL = ( EMISRR(I,J,N) / COEF1 ) * + ! ( DELTPRES / TOTPRES ) + ! adj code: + IF ( NADJ_EANTHRO(NN) > 0 ) THEN + EMS_SF_ADJ(I,J,M,NADJ_EANTHRO(NN)) + & = EMS_SF_ADJ(I,J,M,NADJ_EANTHRO(NN)) + & + ( EMISRR(I,J,N) / COEF1 ) + & * ( DELTPRES / TOTPRES ) + & * EMIS_BL_ADJ + ENDIF + ENDIF + ENDDO + + ! fwd code: + !EMIS_BL = 0d0 + ! adj code: + EMIS_BL_ADJ = 0d0 + + ! For NOx only.... + ELSEIF( N == IDENOX ) THEN + + !======================================================== + ! Ship NOx (emitted as NO, O3, HNO3 after plume evolution) + ! [molec/cm3/s] + ! Distribute emissions thru the entire boundary layer + !======================================================== + + ! Update only if ship emissions are turned on + IF ( LICOADSSHIP .or. LEDGARSHIP .or. LEMEPSHIP ) THEN + + ! Recompute EMIS_BL, SHIP, FRACTION_NOX, INT_OPE + + ! Surface area of grid box + AREA_CM2 = GET_AREA_CM2( J ) + + ! Reset + SHIP = 0D0 + + ! handle global inventory first + IF ( LEDGARSHIP ) THEN + + ! Get SHIP EDGAR emissions for NOx [molec/cm2/s] + SHIP = GET_EDGAR_NOx( I, J, + & MOLEC_CM2_S=.TRUE., SHIP=.TRUE.) + + ! ICOADS ship emissions (cklee,7/09/09) + ELSE IF ( LICOADSSHIP ) THEN + + ! Get ICOADS emissions for NOx [molec/cm2/s] + SHIP = GET_ICOADS_SHIP( I, J, IDTNOX, + & MOLEC_CM2_S=.TRUE. ) + + ENDIF + + ! Overwrite Europe + IF ( LEMEPSHIP ) THEN + + ! Prevent overwriting ICOADS data with a 0 value from EMEP + IF (GET_EUROPE_MASK( I, J ) > 0d0) THEN + + ! Get SHIP EMEP emissions for NOx [molec/cm2/s] + SHIP = GET_EMEP_ANTHRO( I, J, IDTNOX, + & SHIP=.TRUE. ) + ENDIF + + ENDIF + + ! Add possible scaling of NOx emissions + SHIP = SHIP * NOx_SCALING + + !---------------------------------- + ! Get J-Values for J(NO2) and J(O3) + !---------------------------------- + + ! Check if sun is up + !Need to replace with SUNCOS. Careful -- SUNCOS has JLOOP 1D index. + !Need to convert from I,J + JLOOP = JLOP(I,J,1) + IF (SUNCOS(JLOOP) > 0d0 ) THEN + + ! Loop over photolysis reactions to find NO2, O3 + DO L = 1, JPHOTRAT(NCS) + + ! Reaction number + NK = NRATES(NCS) + L + + ! Name of species being photolyzed + SPECNAME = NAMEGAS(IRM(1,NK,NCS)) + + ! Check if this is NO2 or O3, store values, 1/s + SELECT CASE ( TRIM( SPECNAME ) ) + CASE ( 'NO2' ) + JNO2 = FJFUNC(I,J,1,L,1,SPECNAME) + CASE ( 'O3' ) + JO1D = FJFUNC(I,J,1,L,1,SPECNAME) + CASE DEFAULT + END SELECT + + ENDDO + + ELSE + + ! J-values are zero when sun is down + JNO2 = 0d0 + JO1D = 0d0 + + ENDIF + + ! Determine fraction of NOx remaining and integrated Ozone + ! Production Efficiency for ship emiss (gvinken,mpayer,2/7/12) + ! Uses surface-layer concentrations of O3, NO, NO2 (molec/cm3) + ! from CSPEC and air density (molec/cm3) + ! These values of CSPEC need to be forward model values from + ! before KPP but after PARTITION + CALL INTERPOLATE_LUT2( I, J, + & CSPEC_ORIG(JLOOP,IDO3), CSPEC_ORIG(JLOOP,IDNO), + & CSPEC_ORIG(JLOOP,IDNO2), AIRDENS(JLOOP), + & JO1D, JNO2, + & FRACTION_NOx, INT_OPE) + + !----------------- + ! Ship O3 + !----------------- + + EMIS_BL = SHIP * (1D0 - FRACTION_NOX) * INT_OPE + + !---------------------------- + ! adjoint code begins here + !---------------------------- + EMIS_BL_ADJ = 0d0 + TOTO3_ADJ = 0d0 + INT_OPE_ADJ = 0d0 + FRACTION_NOX_ADJ = 0d0 + SHIP_ADJ = 0d0 + + ! Ship plume chemistry can create or destroy net O3 + ! Treat positive O3 production as emissions + ! Treat O3 *destruction* in plume as dry deposition + ! (cdh, 3/21/2013) + IF (EMIS_BL >= 0d0) THEN + + ! Loop over the boundary layer + DO L = 1, TOP + JLOOP = JLOP(I,J,L) + + IF ( JLOOP == 0 ) CYCLE + + ! Thickness of level L [mb] + DELTPRES = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + + ! fwd code: + !REMIS(JLOOP,IDEOX) = REMIS(JLOOP,IDEOX) + ! + EMIS_BL + ! * ( DELTPRES / TOTPRES ) + ! * AREA_CM2 / VOLUME(JLOOP) + ! adj code: + EMIS_BL_ADJ = EMIS_BL_ADJ + & + REMIS_ADJ(JLOOP,IDEOX) + & * ( DELTPRES / TOTPRES ) + & * AREA_CM2 / VOLUME(JLOOP) + ENDDO + + ! fwd code: + !IF (LDRYD) SHIPO3DEP(I,J) = 0d0 + ! adj code: + SHIPO3DEP_ADJ(I,J) = 0d0 + + + ELSE + + ! No change in REMIS + + ! Recalculate TOTO3 + + ! Initialize + TOTO3 = 0d0 + + ! Loop over the boundary layer + ! If LNLPBL, then TOP=1 + DO L = 1, TOP + JLOOP = JLOP(I,J,L) + + IF ( JLOOP == 0 ) CYCLE + + ! Cumulative O3 in the PBL, molec(O3)/cm2 + TOTO3 = TOTO3 + ( BXHEIGHT(I,J,L) * + & 1d2 ) * CSPEC_ORIG(JLOOP,IDO3) + + ENDDO + + + ! fwd code: + !IF (LDRYD) SHIPO3DEP(I,J) = ABS( EMIS_BL / TOTO3 ) + ! adj code: +!$OMP CRITICAL + IF ( LDRYD .and. ( TOTO3 .ge. 1d0 ) ) THEN + + IF ( EMIS_BL / TOTO3 > 0 ) THEN + EMIS_BL_ADJ = SHIPO3DEP_ADJ(I,J) / TOTO3 + TOTO3_ADJ = - EMIS_BL * SHIPO3DEP_ADJ(I,J) + & / ( TOTO3**2 ) + ELSE + EMIS_BL_ADJ = - SHIPO3DEP_ADJ(I,J) / TOTO3 + TOTO3_ADJ = EMIS_BL * SHIPO3DEP_ADJ(I,J) + & / ( TOTO3**2 ) + ENDIF + + ! ensure that TOTO3_ADJ isn't inf or NaN + !IF ( TOTO3 < 1d-150 ) TOTO3_ADJ = 0d0 + + SHIPO3DEP_ADJ(I,J) = 0d0 + + ELSEIF (LDRYD) THEN + + EMIS_BL_ADJ = 0d0 + TOTO3_ADJ = 0d0 + SHIPO3DEP_ADJ(I,J) = 0d0 + + ENDIF +!$OMP END CRITICAL + + DO L = 1, TOP + JLOOP = JLOP(I,J,L) + + IF ( JLOOP == 0 ) CYCLE + + ! fwd: + !TOTO3 = TOTO3 + ( BXHEIGHT(I,J,L) * + ! 1d2 ) * CSPEC(JLOOP,IDO3) + ! adj: + CSPEC_ADJ(JLOOP,IDO3) = CSPEC_ADJ(JLOOP,IDO3) + & + TOTO3_ADJ + & * BXHEIGHT(I,J,L) * 1d2 + + ENDDO + + ! fwd: + !TOTO3 = 0d0 + ! adj: + TOTO3_ADJ = 0d0 + + ENDIF + + ! fwd code: + !EMIS_BL = SHIP * (1D0 - FRACTION_NOX) * INT_OPE + ! adj code: (SHIP_ADJ not used yet, but go ahead and include it) + SHIP_ADJ = EMIS_BL_ADJ + & * (1D0 - FRACTION_NOX) * INT_OPE + INT_OPE_ADJ = EMIS_BL_ADJ + & * SHIP * (1D0 - FRACTION_NOX) + FRACTION_NOX_ADJ = - EMIS_BL_ADJ + & * SHIP * INT_OPE + EMIS_BL_ADJ = 0d0 + + !----------------- + ! Ship HNO3 + !----------------- + + ! Loop over the boundary layer + DO L = 1, TOP + JLOOP = JLOP(I,J,L) + + IF ( JLOOP == 0 ) CYCLE + + ! Thickness of level L [mb] + DELTPRES = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + + ! fwd: + !REMIS(JLOOP,IDEHNO3) = REMIS(JLOOP,IDEHNO3) + ! + ( EMIS_BL * AREA_CM2 ) + ! / VOLUME(JLOOP) + ! adj: + EMIS_BL_ADJ = REMIS_ADJ(JLOOP,IDEHNO3) + & * AREA_CM2 / VOLUME(JLOOP) + + ! fwd: + !EMIS_BL = SHIP * ( 1D0 - FRACTION_NOX ) * + ! ( DELTPRES / TOTPRES ) + ! adj: + SHIP_ADJ = SHIP_ADJ + EMIS_BL_ADJ + & * ( 1D0 - FRACTION_NOX ) + & * ( DELTPRES / TOTPRES ) + FRACTION_NOX_ADJ = FRACTION_NOX_ADJ + & - SHIP * EMIS_BL_ADJ + & * ( DELTPRES / TOTPRES ) + + ENDDO + + + !----------------- + ! Ship NO + !----------------- + ! Loop over the boundary layer + DO L = 1, TOP + JLOOP = JLOP(I,J,L) + EMIS_BL = 0d0 + + IF ( JLOOP == 0 ) CYCLE + + ! Thickness of level L [mb] + DELTPRES = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + + ! fwd: + !REMIS(JLOOP,IDENOX) = REMIS(JLOOP,IDENOX) + ! + ( EMIS_BL * AREA_CM2 ) + ! / VOLUME(JLOOP) + ! adj: + EMIS_BL_ADJ = REMIS_ADJ(JLOOP,IDENOX) + & * AREA_CM2 / VOLUME(JLOOP) + ! fwd: + !EMIS_BL = ( SHIP * FRACTION_NOX ) + ! * ( DELTPRES / TOTPRES ) + ! adj: + SHIP_ADJ = SHIP_ADJ + EMIS_BL_ADJ + & * ( DELTPRES / TOTPRES ) * FRACTION_NOX + FRACTION_NOX_ADJ = FRACTION_NOX_ADJ + EMIS_BL_ADJ + & * ( DELTPRES / TOTPRES ) * SHIP + + ENDDO + + JLOOP = JLOP(I,J,1) + + ! fwd code: + !CALL INTERPOLATE_LUT2( I, J, + ! CSPEC(JLOOP,IDO3), CSPEC(JLOOP,IDNO), + ! CSPEC(JLOOP,IDNO2), AIRDENS(JLOOP), + ! JO1D, JNO2, + ! FRACTION_NOx, INT_OPE) + ! adj code: + CALL INTERPOLATE_LUT2_ADJ( I, J, + & CSPEC_ORIG(JLOOP,IDO3), O3_ADJ, + & CSPEC_ORIG(JLOOP,IDNO), NO_ADJ, + & CSPEC_ORIG(JLOOP,IDNO2), NO2_ADJ, AIRDENS(JLOOP), + & JO1D, JNO2, FRACTION_NOX, + & FRACTION_NOX_ADJ, INT_OPE, INT_OPE_ADJ ) + + + CSPEC_ADJ(JLOOP,IDO3) = CSPEC_ADJ(JLOOP,IDO3) + O3_ADJ + CSPEC_ADJ(JLOOP,IDNO) = CSPEC_ADJ(JLOOP,IDNO) + NO_ADJ + CSPEC_ADJ(JLOOP,IDNO2)= CSPEC_ADJ(JLOOP,IDNO2)+NO2_ADJ + + ENDIF + + !======================================================== + ! Adjoint of Aircraft and Lightning NOx [molec/cm3/s] + !======================================================== + + ! bdf - variable tropopause is a tropospheric box + IF ( LVARTROP ) THEN + LTROP = GET_TPAUSE_LEVEL( I, J ) + ELSE + LTROP = GET_TPAUSE_LEVEL( I, J ) - 1 + ENDIF + + + DO L = 1, LTROP + JLOOP = JLOP(I,J,L) + + IF ( JLOOP /= 0 ) THEN + + + !----------------- + ! Aircraft NOx + !----------------- + IF ( IS_AC_NOx ) THEN + + ! fwd: + !REMIS(JLOOP,N) = REMIS(JLOOP,N) + EMIS_BL + ! adj: + EMIS_BL_ADJ = REMIS_ADJ(JLOOP,N) + + ! fwd: + !EMIS_BL = EMIS_AC_NOx(I,J,L) / COEF1 + ! adj: + IF ( IDADJ_ENOX_ac > 0 ) THEN + EMS_SF_ADJ(I,J,M,IDADJ_ENOX_ac) + & = EMS_SF_ADJ(I,J,M,IDADJ_ENOX_ac) + & + EMIS_AC_NOx(I,J,L) / COEF1 + & * EMIS_BL_ADJ + ENDIF + + ENDIF + + !----------------- + ! Lightning NOx + !----------------- + IF ( IS_LI_NOx ) THEN + + ! fwd code: + !REMIS(JLOOP,N) = REMIS(JLOOP,N) + EMIS_BL + ! adj code: + EMIS_BL_ADJ = REMIS_ADJ(JLOOP,N) + + ! fwd code: + !EMIS_BL = EMIS_LI_NOx(I,J,L) / COEF1 + ! adj code: + IF ( IDADJ_ENOX_li > 0 ) THEN + EMS_SF_ADJ(I,J,M,IDADJ_ENOX_li) + & = EMS_SF_ADJ(I,J,M,IDADJ_ENOX_li) + & + EMIS_LI_NOx(I,J,L) / COEF1 + & * EMIS_BL_ADJ + ENDIF + + ENDIF + + ENDIF + + ! fwd code: + !EMIS_BL = 0d0 + ! adj code: + EMIS_BL_ADJ = 0d0 + + ENDDO + + + !======================================================== + ! Soil Nox emissions [molec/cm3/s] + ! Distribute emissions thru the entire boundary layer + !======================================================== + DO L = 1, TOP + JLOOP = JLOP(I,J,L) + + IF ( JLOOP /= 0 ) THEN + + ! Thickness of level L [mb] + DELTPRES = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + ! fwd code: + !REMIS(JLOOP,N) = REMIS(JLOOP,N) + + ! ( EMIS_BL / VOLUME(JLOOP) ) + ! adj code: + EMIS_BL_ADJ = REMIS_ADJ(JLOOP,N) / VOLUME(JLOOP) + + + ! fwd code: + !EMIS_BL = ( GEMISNOX2(I,J) * + ! VOLUME( JLOP(I,J,1) ) / COEF1 ) * + ! ( DELTPRES / TOTPRES ) + ! adj code: + IF ( IDADJ_ENOX_so > 0 ) THEN + EMS_SF_ADJ(I,J,M,IDADJ_ENOX_so) + & = EMS_SF_ADJ(I,J,M,IDADJ_ENOX_so) + & + GEMISNOX2(I,J) + & * VOLUME( JLOP(I,J,1) ) / COEF1 + & * DELTPRES / TOTPRES + & * EMIS_BL_ADJ + ENDIF + + ENDIF + + ! fwd code: + !EMIS_BL = 0d0 + ! adj code: + EMIS_BL_ADJ = 0d0 + + ENDDO + + !======================================================== + ! Adjoint of Anthropogenic NOx emissions [molec/box/s] + !======================================================== + + NOXTOT = 0d0 + DO L = 1, NOXEXTENT + NOXTOT = NOXTOT + EMISRRN(I,J,L) + ENDDO + + ! Loop over the boundary layer + DO L = 1, TOP + JLOOP = JLOP(I,J,L) + + IF ( JLOOP /= 0 ) THEN + + ! Thickness of level L [mb] + DELTPRES = GET_PEDGE(I,J,L) - GET_PEDGE(I,J,L+1) + + ! fwd code: + !REMIS(JLOOP,N) = EMIS_BL / VOLUME(JLOOP) + ! adj code: + EMIS_BL_ADJ = REMIS_ADJ(JLOOP,N) / VOLUME(JLOOP) + + ! fwd code: + !EMIS_BL = ( NOXTOT / COEF1 ) * + ! ( DELTPRES / TOTPRES ) + ! adj code: + IF ( NADJ_EANTHRO(NN) > 0 ) THEN + EMS_SF_ADJ(I,J,M,NADJ_EANTHRO(NN)) + & = EMS_SF_ADJ(I,J,M,NADJ_EANTHRO(NN)) + & + ( NOXTOT / COEF1 ) * + & ( DELTPRES / TOTPRES ) * + & EMIS_BL_ADJ + ENDIF + ENDIF + + ! fwd code: + !EMIS_BL = 0d0 + ! adj code: + EMIS_BL_ADJ = 0d0 + + ENDDO + + ! fwd code: + !NOXTOT = 0d0 + !DO L = 1, NOXEXTENT + ! NOXTOT = NOXTOT + EMISRRN(I,J,L) + !ENDDO + ! adj code: could use this to distinguish between surface and stack emissions + !DO L = NOXEXTENT, 1, -1 + ! EMISRRN_ADJ(I,J,L) = NOXTOT_ADJ + !ENDDO + !! Reset adjoint + !NOXTOT_ADJ = 0d0 + + ENDIF + + ENDDO ! I + ENDDO ! J + +! ! fwd code: +! !DO JLOOP = 1, NTTLOOP +! ! REMIS(JLOOP,N) = 0d0 +! !ENDDO +! ! adj code: take out of N loop +! DO JLOOP = 1, NTTLOOP +! REMIS_ADJ(JLOOP,N) = 0d0 +! ENDDO + + ENDDO ! N +!$OMP END PARALLEL DO + + REMIS_ADJ(:,:) = 0d0 + + ! Return to calling program + END SUBROUTINE SETEMIS_ADJ diff --git a/code/adjoint/strat_chem_adj_mod.f b/code/adjoint/strat_chem_adj_mod.f new file mode 100644 index 0000000..23a2dcc --- /dev/null +++ b/code/adjoint/strat_chem_adj_mod.f @@ -0,0 +1,332 @@ +!$ID$ +! +! Subroutine STRAT_CHEM_ADJ_MOD performs adjoint of strat chem. +! Based on forward model routine STRAT_CHEM_MOD. +! +! !INTERFACE: +! + MODULE STRAT_CHEM_ADJ_MOD +! +! !USES: +! + IMPLICIT NONE + PRIVATE +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: DO_STRAT_CHEM_ADJ +! +!------------------------------------------------------------------------------ +!BOC +! +! !PRIVATE TYPES: +! + ! Scalars + !REAL*8 :: DTCHEM + + ! Parameters + !INTEGER, PARAMETER :: NTR_GMI = 120 ! Number of species + ! 118 as output from GMI + NOx + Ox families + + !INTEGER, PARAMETER :: MAX_FM = 1 ! Max number of species in a fam + ! Vestigial, as NOx and Ox families pre-processed, but may be useful + ! for future uses, e.g., ClOx. + + ! Arrays + !REAL*8, ALLOCATABLE :: PROD(:,:,:,:) + !REAL*8, ALLOCATABLE :: LOSS(:,:,:,:) + !INTEGER, ALLOCATABLE :: GMI_TO_GC(:,:) + !INTEGER, SAVE :: ncID_strat_rates + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS +!EOC +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: DO_STRAT_CHEM_ADJ +! +! !DESCRIPTION: Function DO\_STRAT\_CHEM is the driver routine for computing +! the simple linearized stratospheric chemistry scheme for a host of species +! whose prod/loss rates were determined from the GMI combo model. Ozone is +! treated using either Linoz or Synoz. +! +! !INTERFACE: +! + SUBROUTINE DO_STRAT_CHEM_ADJ +! +! !USES: +! + USE DAO_MOD, ONLY : AD, CONVERT_UNITS + USE ERROR_MOD, ONLY : DEBUG_MSG + USE LOGICAL_MOD, ONLY : LLINOZ, LPRT + USE TIME_MOD, ONLY : GET_MONTH, TIMESTAMP_STRING + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_A_TAGOX_SIM + USE TRACER_MOD, ONLY : N_TRACERS, STT, TCVV, TRACER_MW_KG + USE TRACERID_MOD, ONLY : IDTOX + USE TROPOPAUSE_MOD, ONLY : GET_MIN_TPAUSE_LEVEL, ITS_IN_THE_TROP + ! adj_group (hml, 07/20/11) + USE STRAT_CHEM_MOD, ONLY : PROD_0, LOSS_0 + USE STRAT_CHEM_MOD, ONLY : PROD, LOSS + USE STRAT_CHEM_MOD, ONLY : DTCHEM + USE STRAT_CHEM_MOD, ONLY : NSCHEM + USE STRAT_CHEM_MOD, ONLY : Strat_TrID_GC + USE STRAT_CHEM_MOD, ONLY : GET_RATES + USE STRAT_CHEM_MOD, ONLY : GET_RATES_INTERP + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF_ADJ, LOSS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : ID_LOSS + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE LINOZ_ADJ_MOD, ONLY : DO_LINOZ_ADJ + USE CHECKPOINT_MOD, ONLY : READ_BEFSTRAT_CHKFILE + USE TIME_MOD, ONLY : GET_NHMS + USE TIME_MOD, ONLY : GET_NYMD + USE TRACER_MOD, ONLY : STT_STRAT_TMP + USE LOGICAL_ADJ_MOD,ONLY : LADJ_STRAT + +# include "define.h" +# include "CMN_SIZE" +! +!EOP +!------------------------------------------------------------------------------ +! +! !LOCAL VARIABLES: +! + INTEGER, SAVE :: LASTSEASON = -1 + INTEGER :: I, J, L, N, LMIN + INTEGER :: IORD, JORD, KORD + INTEGER :: NN, NS, NSL + REAL*8 :: dt, P, k, M0 + REAL*8 :: P_ADJ, k_ADJ, M0_ADJ + REAL*8 :: LOSS_ADJ, PROD_ADJ + CHARACTER(LEN=16) :: STAMP + INTEGER :: NHMS + INTEGER :: NYMD + + + !=============================== + ! DO_STRAT_CHEM_ADJ begins here! + !=============================== + + STAMP = TIMESTAMP_STRING() + WRITE( 6, 100 ) STAMP + 100 FORMAT( ' - DO_STRAT_CHEM_ADJ: Strat chemistry at ', a ) + + !================================================ + ! Determine the rates from disk; merge families + !================================================ + + ! Get the minimum level extent of the tropopause + LMIN = GET_MIN_TPAUSE_LEVEL() + + ! Use ITS_A_NEW_MONTH instead, which works for forward and adjoint + !IF ( GET_MONTH() /= LASTMONTH ) THEN + IF ( ITS_A_NEW_MONTH() ) THEN + + WRITE(6,*) 'Getting new strat rates for month: ',GET_MONTH() + + IF ( LPRT ) CALL DEBUG_MSG( '### STRAT_CHEM_ADJ: at GET_RATES') + + ! Read rates for this month + IF ( ITS_A_FULLCHEM_SIM() ) THEN +#if defined( GRID4x5 ) || defined( GRID2x25 ) + CALL GET_RATES( GET_MONTH() ) +#else + ! For resolutions finer than 2x2.5, nested, + ! or otherwise exotic domains and resolutions + CALL GET_RATES_INTERP( GET_MONTH() ) +#endif + + ENDIF + ENDIF + + IF ( LPRT ) + & CALL DEBUG_MSG( '### STRAT_CHEM_ADJ: at DO_STRAT_CHEM_ADJ' ) + + ! READING STT FROM CHECKPOINT FILE (hml, 07/31/11) + NHMS = GET_NHMS() + NYMD = GET_NYMD() + CALL READ_BEFSTRAT_CHKFILE( NYMD, NHMS ) + + WRITE(6,*) '-----------------------------------------------------' + write(6,*) ' Doing strat chem ajdiont (STRAT_CHEM_ADJ_MOD) ' + WRITE(6,*) '-----------------------------------------------------' + + !================================================================ + ! Full chemistry simulations + !================================================================ + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + !============================================================= + ! Do chemical production and loss for non-ozone species for + ! which we have explicit prod/loss rates from GMI + !============================================================= + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, k, P, dt, M0, NN, NS ) +!$OMP+PRIVATE( k_ADJ, P_ADJ, M0_ADJ ) +!$OMP+PRIVATE( LOSS_ADJ, PROD_ADJ ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1,JJPAR + DO I = 1,IIPAR + + DO L = LMIN,LLPAR + + IF ( ITS_IN_THE_TROP( I, J, L ) ) CYCLE + + DO N=1,NSCHEM ! Tracer index of active strat chem species + NN = Strat_TrID_GC(N) ! Tracer index in STT + + ! Include something to expediate skipping past species + ! that we do not have strat chem for. Prob put tracer on + ! outermost loop. + + ! Skip Ox; we'll always use either Linoz or Synoz + ! Now we will use GMI rate for Ox if LINOZ is off (hml, 10/31/11) + IF ( ITS_A_FULLCHEM_SIM() .and. (NN .eq. IDTOx) .and. + & LLINOZ) CYCLE + + ! adj_group: make a version that applies scaling factors + ! and use this if the stratosphere adjoint ID #'s are active + IF ( LADJ_STRAT ) THEN + DO NS = 1, NSTPL + + NSL = ID_LOSS(NS) ! same for ID_PROD(NS) + + IF ( NN .EQ. NSL ) THEN + + PROD(I,J,L,N) = PROD_0(I,J,L,N) + & * PROD_SF(I,J,1,NS) + LOSS(I,J,L,N) = LOSS_0(I,J,L,N) + & * LOSS_SF(I,J,1,NS) + ENDIF + ENDDO + ENDIF + + ! recalculate forward values to use for adjoint code (hml) + dt = DTCHEM ! timestep [s] + k = LOSS(I,J,L,N) ! loss freq [s-1] + P = PROD(I,J,L,N) * AD(I,J,L) / TCVV(NN)! production term [kg s-1] + ! Use checkpointed value + M0 = STT_STRAT_TMP(I,J,L,NN) ! initial mass [kg] + + ! debug test + !IF ( I == IFD .and. J == JFD .and. L == LFD ) THEN + ! print*, ' IFD, JFD, LFD = ', IFD, JFD, LFD + ! print*, NN,' STRAT TEST adj: k = ', k + ! print*, NN,' STRAT TEST adj: P = ', P + ! print*, NN,' STRAT TEST adj: M0= ', M0 + !ENDIF + + ! No prod or loss at all + IF ( k .eq. 0d0 .and. P .eq. 0d0 ) CYCLE + + ! Simple analytic solution to dM/dt = P - kM over [0,t] + IF ( k .gt. 0d0 ) THEN + ! fwd code: + !STT(I,J,L,N) = M0 * exp(-k*t) + (P/k)*(1d0-exp(-k*t)) + ! adj code: + M0_ADJ = STT_ADJ(I,J,L,NN) * exp(-k*dt) + P_ADJ = STT_ADJ(I,J,L,NN) * (1d0 - exp(-k*dt))/k + k_ADJ = STT_ADJ(I,J,L,NN) + & * ( -p/(k**2) + p/(k**2)*exp(-k*dt) + & + (p*dt/k)*exp(-k*dt) - dt*exp(-k*dt)*M0 ) + ELSE + ! fwd code: + !STT(I,J,L,N) = M0 + P*t + ! adj code: + M0_ADJ = STT_ADJ(I,J,L,NN) + P_ADJ = STT_ADJ(I,J,L,NN) * dt + ENDIF + + ! fwd code: + !k = LOSS(I,J,L,N) ! loss freq [s-1] + !P = PROD(I,J,L,N) * AD(I,J,L) / TCVV(N) ! production term [kg s-1] + !M0 = STT(I,J,L,N) ! initial mass [kg] + ! adj code: + LOSS_ADJ = K_ADJ + PROD_ADJ = P_ADJ * AD(I,J,L) / TCVV(NN) + STT_ADJ (I,J,L,NN) = M0_ADJ + + IF ( LADJ_STRAT ) THEN + DO NS = 1, NSTPL + + NSL = ID_LOSS(NS) ! same for ID_PROD(NS) + + IF ( NN .EQ. NSL ) THEN + + ! fwd code: + !PROD(I,J,L,N) = PROD_0(I,J,L,N) * PROD_SF(I,J,1,N) + !LOSS(I,J,L,N) = LOSS_0(I,J,L,N) * LOSS_SF(I,J,1,N) + ! adj code: + PROD_SF_ADJ(I,J,1,NS) = PROD_SF_ADJ(I,J,1,NS) + & + PROD_0(I,J,L,N) + & * PROD_ADJ + LOSS_SF_ADJ(I,J,1,NS) = LOSS_SF_ADJ(I,J,1,NS) + & + LOSS_0(I,J,L,N) + & * LOSS_ADJ + ENDIF + ENDDO + ENDIF + + ENDDO ! N + ENDDO ! L + ENDDO ! I + ENDDO ! J +!$OMP END PARALLEL DO + + + !=================================== + ! Ozone + !=================================== + + ! fwd code: Put ozone in v/v + !STT(:,:,:,IDTOX ) = STT(:,:,:,IDTOX) * TCVV( IDTOX ) / AD + ! adj code: Put ozone back to kg + STT_ADJ(:,:,:,IDTOX ) = + & STT_ADJ(:,:,:,IDTOX) * AD / TCVV( IDTOX ) + + IF ( LLINOZ ) THEN + CALL DO_LINOZ_ADJ ! Linoz + ELSE + ! must use Linoz or strat chem Ox fluxes for the adjoint + ENDIF + + ! fwd code: Put ozone back to kg + !STT(:,:,:,IDTOX) = STT(:,:,:,IDTOX) * AD / TCVV( IDTOX ) + ! adj code: Put ozone in v/v + STT_ADJ(:,:,:,IDTOX) = + & STT_ADJ(:,:,:,IDTOX)* TCVV( IDTOX ) / AD + + ELSE IF ( ITS_A_TAGOX_SIM() ) THEN + + ! fwd code: + !CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT ) ! kg -> v/v + ! adj code: + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) ! v/v -> kg + + ! adjoint LINOZ does not support tagged Ox simulation for now (hml, 10/05/11) + IF ( LLINOZ ) THEN + CALL DO_LINOZ_ADJ ! Linoz + ELSE + ! must use Linoz or strat chem Ox fluxes for the adjoint + ENDIF + + ! fwd code: + !CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT ) ! v/v -> kg + ! adj code: + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) ! kg -> v/v + + ENDIF + + END SUBROUTINE DO_STRAT_CHEM_ADJ +!EOC +!------------------------------------------------------------------------------ + END MODULE STRAT_CHEM_ADJ_MOD diff --git a/code/adjoint/sulfate_adj_mod.f b/code/adjoint/sulfate_adj_mod.f new file mode 100644 index 0000000..09d32c9 --- /dev/null +++ b/code/adjoint/sulfate_adj_mod.f @@ -0,0 +1,7273 @@ +! $Id: sulfate_adj_mod.f,v 1.8 2012/09/05 22:35:07 yanko Exp $ + MODULE SULFATE_ADJ_MOD +! +!****************************************************************************** +! Module SULFATE_MOD contains arrays and routines for performing either a +! coupled chemistry/aerosol run or an offline sulfate aerosol simulation. +! Original code taken from Mian Chin's GOCART model and modified accordingly. +! (rjp, bdf, bmy, 6/22/00, 10/31/08) +! +! Module Variables: +! ============================================================================ +! (1 ) XNUMOL_OH (REAL*8 ) : Molecules OH per kg OH [molec/kg] +! (2 ) XNUMOL_O3 (REAL*8 ) : Molecules O3 per kg O3 [molec/kg] +! (3 ) XNUMOL_NO3 (REAL*8 ) : Molecules NO3 per kg NO3 [molec/kg] +! (4 ) TCVV_S (REAL*8 ) : Ratio: Molwt air / Molwt S [unitless] +! (5 ) DMSo (REAL*8 ) : DMS oceanic emissions [v/v/timestep] +! (6 ) DRYH2O2 (INTEGER) : Pointer to H2O2 in DEPVEL array [unitless] +! (7 ) DRYSO2 (INTEGER) : Pointer to SO2 in DEPVEL array [unitless] +! (8 ) DRYSO4 (INTEGER) : Pointer to SO4 in DEPVEL array [unitless] +! (9 ) DRYSO4s (INTEGER) : Pointer to SO4s in DEPVEL array [unitless] +! (10) DRYMSA (INTEGER) : Pointer to MSA in DEPVEL array [unitless] +! (11) DRYNH3 (INTEGER) : Pointer to NH3 in DEPVEL array [unitless] +! (12) DRYNH4 (INTEGER) : Pointer to NH4 in DEPVEL array [unitless] +! (13) DRYNIT (INTEGER) : Pointer to NIT in DEPVEL array [unitless] +! (14) DRYNITs (INTEGER) : Pointer to NITs in DEPVEL array [unitless] +! (15) DRYSO4aq (INTEGER) : Pointer to SO4aq in DEPVEL array [unitless] +! (16) DRYAS (INTEGER) : Pointer to AS in DEPVEL array [unitless] +! (17) DRYAHS (INTEGER) : Pointer to AHS in DEPVEL array [unitless] +! (18) DRYLET (INTEGER) : Pointer to LET in DEPVEL array [unitless] +! (19) DRYNH4aq (INTEGER) : Pointer to NH4aq in DEPVEL array [unitless] +! (20) ENH3_an (REAL*8 ) : NH3 anthropogenic emissions [kg NH3/box/s] +! (21) ENH3_bb (REAL*8 ) : NH3 biomass emissions [kg NH3/box/s] +! (22) ENH3_bf (REAL*8 ) : NH3 biofuel emissions [kg NH3/box/s] +! (23) ENH3_na (REAL*8 ) : NH73 natural source emissions [kg NH3/box/s] +! (24) ESO2_ac (REAL*8 ) : SO2 aircraft emissions [kg SO2/box/s] +! (25) ESO2_an (REAL*8 ) : SO2 anthropogenic emissions [kg SO2/box/s] +! (26) ESO2_ev (REAL*8 ) : SO2 eruptive volcanic em. [kg SO2/box/s] +! (27) ESO2_nv (REAL*8 ) : SO2 non-eruptive volcanic em. [kg SO2/box/s] +! (28) ESO2_bb (REAL*8 ) : SO2 biomass burning emissions [kg SO2/box/s] +! (29) ESO2_bf (REAL*8 ) : SO2 biofuel burning emissions [kg SO2/box/s] +! (30) ESO2_sh (REAL*8 ) : SO2 ship emissions [kg SO2/box/s] +! (31) ESO4_an (REAL*8 ) : SO4 anthropogenic emissions [kg SO4/box/s] +! (32) JH2O2 (REAL*8 ) : Monthly mean J(H2O2) values [s-1] +! (33) O3m (REAL*8 ) : Monthly mean O3 concentration [v/v] +! (34) PH2O2m (REAL*8 ) : Monthly mean P(H2O2) [molec/cm3/s] +! (35) PMSA_DMS (REAL*8 ) : P(MSA) from DMS [v/v/timestep] +! (36) PSO2_DMS (REAL*8 ) : P(SO2) from DMS [v/v/timestep] +! (37) PSO4_SO2 (REAL*8 ) : P(SO4) from SO2 [v/v/timestep] +! (38) SSTEMP (REAL*8 ) : Sea surface temperatures [K] +! (39) VCLDF (REAL*8 ) : Volume cloud frac. for SO2 aq. [unitless] +! (40) NEV (INTEGER) : Max # of eruptive volcanoes [unitless] +! (41) IEV (INTEGER) : Longitudes of eruptive volcanoes [degrees] +! (42) JEV (INTEGER) : Latitudes of eruptive volcanoes [degrees ] +! (43) IHGHT (INTEGER) : Height of eruptive volcano plume [m] +! (44) IELVe (INTEGER) : Elevation of eruptive volcanoes [m] +! (45) Eev (REAL*8 ) : SO2 em. from eruptive volcanoes [kg SO2/box/s] +! (46) NNV (INTEGER) : Max # of non-eruptive volcanoes [unitless] +! (47) NNVOL (INTEGER) : Number of non-eruptive volcanoes [unitless] +! (48) INV (INTEGER) : Longitude of non-erup volcanoes [degrees] +! (49) JNV (INTEGER) : Latitude of non-erup volcanoes [degrees] +! (50) IELVn (INTEGER) : Elevation of non-erup volcanoes [m] +! (51) Env (INTEGER) : SO2 em. from non-erup volcanoes [kg SO2/box/s] +! (52) TCOSZ (REAL*8 ) : Sum of cos(SZA) for offline run [unitless] +! (53) TTDAY (REAL*8 ) : Total daylight length at (I,J) [minutes] +! (54) SMALLNUM (REAL*8 ) : Small number - prevent underflow [unitless] +! (55) COSZM (REAL*8 ) : Array for MAX(cos(SZA)) at (I,J) [unitless] +! +! Module Routines: +! =========================================================================== +! (1 ) GET_VCLDF : Computes volume cloud fraction for SO2 chemistry +! (2 ) GET_LWC : Computes liquid water content as a function of T +! (3 ) CHEMSULFATE : Driver routine for sulfate/aerosol chemistry +! (4 ) GRAV_SETTLING : Routine to compute settling of SO4s and NITs +! (5 ) CHEM_DMS : Chemistry routine for DMS tracer +! (6 ) CHEM_H2O2 : Chemistry routine for H2O2 tracer +! (7 ) CHEM_SO2 : Chemistry routine for SO2 tracer +! (8 ) SEASALT_CHEM : Computes SO2->SO4 and HNO3->nitrate w/in seasalt +! (9 ) AQCHEM_SO2 : Computes reaction rates for aqueous SO2 chemistry +! (10) CHEM_SO4 : Chemistry routine for SO4 tracer +! (11) PHASE_SO4 : Computes phase transition for crystalline tracers +! (12) PHASE_RADIATIVE : Computes radiative forcing for crystalline tracers +! (13) CHEM_MSA : Chemistry routine for MSA tracer +! (14) CHEM_NH3 : Chemistry routine for ammonia tracer +! (15) CHEM_NH4 : Chemistry routine for ammonium tracer +! (16) CHEM_NIT : Chemistry routine for nitrates tracer +! (17) EMISSSULFATE : Driver routine for sulfate/aerosol emissions +! (18) SRCDMS : Emission routine for DMS tracer +! (19) SRCSO2 : Emission routine for SO2 tracer +! (20) SRCSO4 : Emission routine for SO4 tracer +! (21) SRCNH3 : Emission routine for NH3 tracer +! (22) GET_OH : Returns OH for coupled or offline simulations +! (23) SET_OH : Resets modified OH in SMVGEAR's CSPEC array +! (24) GET_NO3 : Returns NO3 for coupled or offline simulations +! (25) SET_NO3 : Resets modified OH in SMVGEAR's CSPEC array +! (26) GET_O3 : Returns O3 for coupled or offline simulations +! (27) READ_NONERUP_VOLC : Reads SO2 emissions from non-eruptive volcanoes +! (28) READ_ERUP_VOLC : Reads SO2 emissions from eruptive volcanoes +! (29) READ_ANTHRO_SOx : Reads anthropogenic SO2 and SO4 emissions +! (30) READ_OCEAN_DMS : Reads biogenic DMS emissions from oceans +! (31) READ_SST : Reads monthly mean sea-surface temperatures +! (32) READ_BIOFUEL_SO2 : Reads SO2 emissions from biomass burning +! (33) READ_AIRCRAFT_SO2 : Reads SO2 emissions from aircraft exhaust +! (34) READ_SHIP_SO2 : Reads SO2 emissions from ship exhaust +! (35) READ_ANTHRO_NH3 : Reads NH3 emissions from anthropogenic sources +! (36) READ_NATURAL_NH3 : Reads NH3 emissions from natural sources +! (37) READ_BIOMASS_NH3 : Reads NH3 biomass burning emissions +! (38) READ_OXIDANT : Reads monthly mean O3 and H2O2 for offline run +! (39) OHNO3TIME : Computes time arrays for scaling offline OH, NO3 +! (40) INIT_SULFATE : Allocates & zeroes module arrays +! (41) CLEANUP_SULFATE : Deallocates module arrays +! +! GEOS-CHEM modules referenced by sulfate_mod.f +! ============================================================================ +! (1 ) biomass_mod.f : Module w/ routines for biomass burning +! (2 ) bpch2_mod.f : Module w/ routines for binary pch file I/O +! (3 ) bravo_mod.f : Module w/ routines to read BRAVO emissions +! (4 ) comode_mod.f : Module w/ SMVGEAR allocatable arrays +! (5 ) dao_mod.f : Module w/ DAO met field arrays +! (6 ) diag_mod.f : Module w/ GEOS-Chem diagnostic arrays +! (7 ) directory_mod.f : Module w/ GEOS-Chem data & met field dirs +! (8 ) drydep_mod.f : Module w/ GEOS-Chem dry deposition routines +! (9 ) epa_nei_mod.f : Module w/ routines to read EPA/NEI99 data +! (10) error_mod.f : Module w/ NaN, other error check routines +! (11) file_mod.f : Module w/ file unit numbers & error checks +! (12) future_emissions_mod.f : Module w/ routines for IPCC future emissions +! (13) grid_mod.f : Module w/ horizontal grid information +! (14) global_no3_mod.f : Module w/ routines to read 3-D NO3 field +! (15) global_oh_mod.f : Module w/ routines to read 3-D OH field +! (16) isoropiaii_adj_mod.f : Module w/ ISORROPIA routines for aer thermo eq +! (17) logical_mod.f : Module w/ GEOS-Chem logical switches +! (18) pbl_mix_mod.f : Module w/ routines for PBL height & mixing +! (19) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (20) seasalt_mod.f : Module w/ routines for seasalt chemistry +! (21) streets_anthro_mod.f : Module w/ routines for David Streets' emiss +! (22) time_mod.f : Module w/ routines to compute time & date +! (23) tracer_mod.f : Module w/ GEOS-Chem tracer array STT etc. +! (24) tracerid_mod.f : Module w/ pointers to tracers & emissions +! (25) transfer_mod.f : Module w/ routines to cast & resize arrays +! (26) tropopause_mod.f : Module w/ routines to read ann mean tropopause +! (27) uvalbedo_mod.f : Module w/ UV albedo array and reader +! (28) wetscav_mod.f : Module w/ routines for wetdep & scavenging +! +! References: +! ============================================================================ +! (1 ) Andreae, M.O. & P. Merlet, "Emission of trace gases and aerosols from +! biomass burning", Global Biogeochem. Cycles, 15, 955-966, 2001. +! (2 ) Nightingale et al [2000a], J. Geophys. Res, 14, 373-387 +! (3 ) Nightingale et al [2000b], Geophys. Res. Lett, 27, 2117-2120 +! (4 ) Wanninkhof, R., "Relation between wind speed and gas exchange over +! the ocean", J. Geophys. Res, 97, 7373-7382, 1992. +! +! NOTES: +! (1 ) All module variables are declared PRIVATE (i.e., they can only +! be seen from within this module (bmy, 6/2/00) +! (2 ) The routines in "sulfate_mod.f" assume that we are doing chemistry +! over the global region (e.g. IIPAR=IGLOB, JJPAR=JGLOB). (bmy, 6/8/00) +! (3 ) Removed obsolete code from DRYDEP_SULFATE (bmy, 12/21/00) +! (4 ) Removed obsolete commented-out code from module routines (bmy, 4/23/01) +! (5 ) Now read data files from DATA_DIR/sulfate_sim_200106/ (bmy, 6/19/01) +! (6 ) Updated comments (bmy, 9/4/01) +! (7 ) XTRA2(IREF,JREF,5) is now XTRA2(I,J). Now reference COSSZA from +! "dao_mod.f". (bmy, 9/27/01) +! (8 ) Removed obsolete commented out code from 9/01 (bmy, 10/24/01) +! (9 ) Minor fixes to facilitate compilation on ALPHA (bmy, 11/15/01) +! (11) Now divide module header into MODULE PRIVATE, MODULE VARIABLES, and +! MODULE ROUTINES sections. Updated comments (bmy, 5/28/02) +! (12) Replaced all instances of IM with IIPAR and JM with JJPAR, in order +! to prevent namespace confusion for the new TPCORE (bmy, 6/25/02) +! (13) Now reference "file_mod.f" (bmy, 6/27/02) +! (14) Now references GET_PEDGE from "pressure_mod.f", which computes P at +! the bottom edge of grid box (I,J,L). Also deleted obsolete, +! commented-out code. (dsa, bdf, bmy, 8/21/02) +! (15) Added updated code from Rokjin Park and Brendan Field, in order to +! perform coupled chemistry-aerosol simulations. Also added parallel +! DO-loops in several subroutines. Updated comments, cosmetic +! changes. Now reference "error_mod.f" and "wetscav_mod.f". +! Now only do chemistry below the tropopause. (rjp, bdf, bmy, 12/6/02) +! (16) Added ENH3_na array to hold natural source NH3 emissions. Also now +! facilitate passing DMS, SO2, SO4, NH3 to SMVGEAR for fullchem +! simulations. Added subroutine READ_NATURAL_NH3. (rjp, bmy, 3/23/03) +! (17) Now references "grid_mod.f" and "time_mod.f". Also made other minor +! cosmetic changes. (bmy, 3/27/03) +! (18) Updated chemistry routines to apply drydep losses throughout the +! entire PBL. (rjp, bmy, 8/1/03) +! (19) Now accounts for GEOS-4 PBL being in meters (bmy, 1/15/04) +! (20) Fix ND44 diag so that we get same results for sp or mp (bmy, 3/24/04) +! (21) Added COSZM array. Now use diurnal varying JH2O2 in CHEM_H2O2. +! (rjp, bmy, 3/39/04) +! (22) Added more parallel DO-loops (bmy, 4/14/04) +! (23) Now add SO2 from ships (bec, bmy, 5/20/04) +! (24) Now references "directory_mod.f", "logical_mod.f" and "tracer_mod.f". +! Now removed IJSURF. (bmy, 7/20/04) +! (25) Can overwrite USA with EPA/NEI99 emissions (rjp, rch, bmy, 11/16/04) +! (26) Modified for AS, AHS, LET, SO4aq, NH4aq (cas, bmy, 1/11/05) +! (27) Now also references "pbl_mix_mod.f". NOTE: Comment out phase +! transition code for now since it is still under development and +! will take a while to be rewritten. (bmy, 3/15/05) +! (28) Modified for SO4s, NITs chemistry (bec, 4/13/05) +! (29) Now reads updated files for SST and offline chemistry. Now read data +! for both GCAP and GEOS grids. Now references "tropopause_mod.f". +! (bmy, 8/22/05) +! (30) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (31) Now references XNUMOL & XNUMOLAIR from "tracer_mod.f" (bmy, 10/25/05) +! (32) Now read int'annual SST data on GEOS 1x1 grid (bmy, 11/17/05) +! (33) Bug fix for offline aerosol sim in SEASALT_CHEM (bec, bmy, 3/29/06) +! (34) Bug fix in INIT_DRYDEP (bmy, 5/23/06) +! (35) Now references "bravo_mod.f" (rjp, kfb, bmy, 6/26/06) +! (36) Now references "streets_anthro_mod.f" (yxw, bmy, 8/17/06) +! (37) Now references "biomass_mod.f" (bmy, 9/27/06) +! (38) Now prevent seg fault error in READ_BIOFUEL_SO2 (bmy, 11/3/06) +! (39) Bug fix in SEASALT_CHEM (havala, bec, bmy, 12/8/06) +! (40) Extra error check for low RH in GRAV_SETTLING (phs, 6/11/08) +! (41) Now references "cac_anthro_mod.f". And apply SO2 yearly scale factor +! to SO2 from GEIA (amv, phs, 3/11/08) +! (41) Bug fixes in reading EDGAR data w/ the right tracer number, +! when we are doing offline or nonstd simulations (dkh, 10/31/08) +! (42) Bug fix for AD13_SO2_sh in SRCSO2 (phs, 2/27/09) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "sulfate_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: CHEMSULFATE_ADJ + PUBLIC :: CLEANUP_SULFATE_ADJ + PUBLIC :: EMISSSULFATE_ADJ + + !================================================================= + ! MODULE VARIABLES (see descriptions listed above) + !================================================================= + + ! Time variable + INTEGER :: ELAPSED_SEC + + ! Logical Flags + LOGICAL, PARAMETER :: LENV = .TRUE. + LOGICAL, PARAMETER :: LEEV = .TRUE. + + ! Parameters + REAL*8, PARAMETER :: XNUMOL_OH = 6.022d23 / 17d-3 + REAL*8, PARAMETER :: XNUMOL_O3 = 6.022d23 / 48d-3 + REAL*8, PARAMETER :: XNUMOL_NO3 = 6.022d23 / 62d-3 + REAL*8, PARAMETER :: TCVV_S = 28.97d0 / 32d0 + REAL*8, PARAMETER :: SMALLNUM = 1d-20 + + ! Allocatable arrays + REAL*8, ALLOCATABLE :: VCLDF(:,:,:) + REAL*8, ALLOCATABLE :: ADPSO4_SO2(:,:,:) + + ! Eruptive volcanoes + INTEGER, PARAMETER :: NEV=50 + INTEGER :: NEVOL + INTEGER, ALLOCATABLE :: IEV(:), JEV(:) + INTEGER, ALLOCATABLE :: IDAYs(:), IDAYe(:) + INTEGER, ALLOCATABLE :: IHGHT(:), IELVe(:) + REAL*8, ALLOCATABLE :: EEV(:) + + ! Non-eruptive volcanoes + INTEGER, PARAMETER :: NNV=50 + INTEGER :: NNVOL + INTEGER, ALLOCATABLE :: INV(:), JNV(:), IELVn(:) + REAL*8, ALLOCATABLE :: ENV(:) + + ! Pointers to drydep species w/in DEPSAV + INTEGER :: DRYSO2, DRYSO4, DRYMSA, DRYNH3 + INTEGER :: DRYNH4, DRYNIT, DRYSO4s, DRYNITs + INTEGER :: DRYH2O2, DRYSO4aq, DRYAS, DRYAHS + INTEGER :: DRYLET, DRYNH4aq + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE GET_VCLDF +! +!****************************************************************************** +! Subroutine GET_VCLDF computes the volume cloud fraction for SO2 chemistry. +! (rjp, bdf, bmy, 9/23/02) +! +! References: +! ============================================================================ +! (1) Sundqvist et al. [1989] +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : RH + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L + REAL*8 :: PRES, PSFC, RH2, R0, B0 + + ! Parameters + REAL*8, PARAMETER :: ZRT = 0.60d0, ZRS = 0.99d0 + + !================================================================= + ! GET_VCLDF begins here! + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, PSFC, PRES, RH2, R0, B0 ) + DO L = 1, LLTROP + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Surface pressure + PSFC = GET_PEDGE(I,J,1) + + ! Pressure at the center of the grid box + PRES = GET_PCENTER(I,J,L) + + ! RH (from "dao_mod.f") is relative humidity [%] + ! Convert to fraction and store in RH2 + RH2 = RH(I,J,L) * 1.0d-2 + + ! Terms from Sundqvist ??? + R0 = ZRT + ( ZRS - ZRT ) * EXP( 1d0 - ( PSFC / PRES )**2.5 ) + B0 = ( RH2 - R0 ) / ( 1d0 - R0 ) + + ! Force B0 into the range 0-1 + IF ( RH2 < R0 ) B0 = 0d0 + IF ( B0 > 1d0 ) B0 = 1d0 + + ! Volume cloud fraction + VCLDF(I,J,L) = 1d0 - SQRT( 1d0 - B0 ) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE GET_VCLDF + +!------------------------------------------------------------------------------ + + FUNCTION GET_LWC( T ) RESULT( LWC ) +! +!****************************************************************************** +! Function GET_LWC returns the cloud liquid water content at a GEOS-CHEM +! grid box as a function of temperature. (rjp, bmy, 10/31/02, 1/14/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) T (REAL*8) : Temperature value at a GEOS-CHEM grid box [K] +! +! NOTES: +!****************************************************************************** +! + ! Arguments + REAL*8, INTENT(IN) :: T + + ! Function value + REAL*8 :: LWC + + !================================================================= + ! GET_LWC begins here! + !================================================================= + + ! Compute Liquid water content in [g/m3] + IF ( T > 293d0 ) THEN + LWC = 0.2d0 + + ELSE IF ( T >= 280.d0 .AND. T <= 293.d0 ) THEN + LWC = 0.32d0 - 0.0060d0 * ( T - 273.D0 ) + + ELSE IF ( T >= 248.d0 .AND. T < 280.d0 ) THEN + LWC = 0.23d0 + 0.0065d0 * ( T - 273.D0 ) + + ELSE IF ( T < 248.d0 ) THEN + LWC = 0.07d0 + + ENDIF + + ! Convert from [g/m3] to [m3/m3] + LWC = LWC * 1.D-6 + + ! Return to calling program + END FUNCTION GET_LWC + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEMSULFATE_ADJ + +!****************************************************************************** +! Subroutine CHEMSULFATE_ADJ is the interface between the GEOS-CHEM main program +! and the adjoint sulfate chemistry routines. This version only supports +! full chemistry. (dkh, 10/12/05) +! +! It is attempted to be as similar as possible to the forward +! routine CHEMSULFATE (rjp, bdf, bmy, 5/31/00, 3/16/06) +! +! NOTES: +! (1 ) Now we call ADJ_CHEM_xxx rather than computing the adjoint chemistry +! routines directly. (dkh, 10/12/05) +! (2 ) Recalculate VCLDF. (dkh, 08/27/06) +! (3 ) Updated to GCv8 adjoint (dkh, 09/27/09) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE DAO_MOD, ONLY : AD, AIRDEN, CLDF + USE DAO_MOD, ONLY : SUNCOS, CONVERT_UNITS + USE DRYDEP_MOD, ONLY : DEPSAV + USE ERROR_MOD, ONLY : DEBUG_MSG + USE ERROR_MOD, ONLY : ERROR_STOP + USE GLOBAL_OH_MOD, ONLY : GET_GLOBAL_OH + USE GLOBAL_NO3_MOD, ONLY : GET_GLOBAL_NO3 + USE LOGICAL_MOD, ONLY : LCRYST, LPRT + USE TIME_MOD, ONLY : GET_MONTH, GET_TS_CHEM + USE TIME_MOD, ONLY : GET_ELAPSED_SEC, ITS_A_NEW_MONTH + USE TRACER_MOD, ONLY : STT, TCVV + USE TRACER_MOD, ONLY : N_TRACERS, ITS_AN_AEROSOL_SIM + USE TRACERID_MOD, ONLY : IDTNITs, IDTSO4s + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRSTCHEM = .TRUE. + INTEGER, SAVE :: LASTMONTH = -99 + INTEGER :: I, J, L, N, MONTH + REAL*8 :: DTCHEM + + ! External functions + REAL*8, EXTERNAL :: BOXVL + + !================================================================= + ! CHEMSULFATE_ADJ begins here! + !================================================================= + + ! Get current month + MONTH = GET_MONTH() + + ! Establish indices w/in DEPSAV array + IF ( FIRSTCHEM ) THEN + + ! Initialize arrays (if not already done before) + CALL INIT_SULFATE_ADJ + + ! Reset first-time flag + FIRSTCHEM = .FALSE. + ENDIF + + ! If it's an offline simulation ... + IF ( ITS_AN_AEROSOL_SIM() ) THEN + + CALL ERROR_STOP('offline aerosol not supported in adjoint', + & 'sulfate_adj_mod.f') +! +! ! Then read monthly data files ... +! IF ( ITS_A_NEW_MONTH() ) THEN +! CALL GET_GLOBAL_OH( MONTH ) +! CALL GET_GLOBAL_NO3( MONTH ) +! ENDIF +! +! ! And compute time scaling arrays for offline OH, NO3 +! CALL OHNO3TIME + + ENDIF + + ! Store NTIME in a shadow variable + ELAPSED_SEC = GET_ELAPSED_SEC() + + ! DTCHEM is the chemistry timestep in seconds + DTCHEM = GET_TS_CHEM() * 60d0 + + ! Initialize adjoint module arrays + !PSO2_DMS = 0d0 + !PMSA_DMS = 0d0 + !PSO4_SO2 = 0d0 + !PSO4_SS = 0d0 + !PNITs = 0d0 + ADPSO4_SO2 = 0d0 + + !================================================================= + ! Call individual chemistry routines for sulfate/aerosol tracers + !================================================================= + + ! Redo forward model unit conversion + + ! Convert all tracers in STT from [kg] -> [v/v] + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSULFATE_ADJ: a CONV UNIT 1 ') + + ! fwd code: + !! Convert STT from [v/v] -> [kg] + !CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT ) + ! adj code: + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT_ADJ ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSULFATE_ADJ: a CONV UNIT 2 ') + + ! fwd code: + !CALL CHEM_NIT + ! adj code: + CALL CHEM_NIT_ADJ + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMSULFATE_ADJ: a CHEM_NIT_ADJ ' ) + + ! fwd code: + !CALL CHEM_NH4 + ! adj code: + CALL CHEM_NH4_ADJ + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMSULFATE_ADJ: a CHEM_NH4_ADJ ' ) + + ! fwd code: + !CALL CHEM_NH3 + ! adj code: + CALL CHEM_NH3_ADJ + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMSULFATE_ADJ: a CHEM_NH3_ADJ ' ) + + ! fwd code: + !CALL CHEM_MSA + ! adj code: + CALL CHEM_MSA_ADJ + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMSULFATE_ADJ: a CHEM_MSA_ADJ ' ) + + ! fwd code: + !CALL CHEM_SO4 + ! adj code: + CALL CHEM_SO4_ADJ + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMSULFATE_ADJ: a CHEM_SO4_ADJ ' ) + + ! SO2 + ! added in v16 of GCv6 adj (dkh, 08/27/06) + CALL GET_VCLDF + IF ( LPRT ) + & CALL DEBUG_MSG( '### CHEMSULFATE_ADJ: a GET_VCLDF ' ) + + ! fwd code: + !CALL CHEM_SO2 + ! adj code: + CALL CHEM_SO2_ADJ + + ! Redo forward model unit conversion + ! Convert STT from [v/v] -> [kg] + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSULFATE_ADJ: a CONV UNIT 3 ') + + + ! We have already gone thru one chemistry iteration + FIRSTCHEM = .FALSE. + + ! For offline runs only ... + IF ( ITS_AN_AEROSOL_SIM() ) THEN + + CALL ERROR_STOP('offline aerosol not supported in adjoint', + & 'sulfate_adj_mod.f') + + ! fwd code: + !! H2O2 (offline only) + !CALL CHEM_H2O2 + !IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSULFATE: a CHEM_H2O2' ) + ! adj code: + + ! fwd code: + !! DMS (offline only) + !CALL CHEM_DMS + !IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSULFATE: a CHEM_DMS' ) + ! adj code: + + ENDIF + + + ! fwd code: + !! Convert all tracers in STT from [kg] -> [v/v] + !CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT ) + ! adj code: + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT_ADJ ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSULFATE_ADJ: a CONV UNIT 4 ') + + ! fwd code: + !! NITs [kg] gravitational settling + !CALL GRAV_SETTLING( STT(:,:,:,IDTNITs), 2 ) + !IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSULFATE: GRAV_SET, NITS' ) + ! adj code: + print*, ' WARNING: no adjoint of NITs gravitational settling' + + ! fwd code: + !! SO4s [kg] gravitational settling + !CALL GRAV_SETTLING( STT(:,:,:,IDTSO4s), 1 ) + !IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSULFATE: GRAV_SET, SO4S' ) + ! adj code: + print*, ' WARNING: no adjoint of SO4s gravitational settling' + + ! Return to calling program + END SUBROUTINE CHEMSULFATE_ADJ + +!!------------------------------------------------------------------------------ +!! +! +! SUBROUTINE GRAV_SETTLING( TC, N ) +!! +!!****************************************************************************** +!! Subroutine GRAV_SETTLING performs gravitational settling of sulfate +!! and nitrate in coarse sea salt (SO4S and NITS). +!! (bec, rjp, bmy, 4/20/04, 7/20/04, 10/25/05) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) TC (REAL*8 ) : Tracer [kg] +!! (2 ) N (INTEGER) : N=1 is SO4S; N=2 is NITS +!! +!! Arguments as Output: +!! ============================================================================ +!! (1 ) TC (REAL*8 ) : Contains modified tracer +!! +!! NOTES: +!! (1 ) Now references SALA_REDGE_um and SALC_REDGE_um from "tracer_mod.f" +!! (bmy, 7/20/04) +!! (2 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +!! (3 ) Now limit relative humidity to [tiny(real*8),0.99] range for DLOG +!! argument (phs, 5/1/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE DAO_MOD, ONLY : T, BXHEIGHT, RH +! USE DIAG_MOD, ONLY : AD44 +! USE DRYDEP_MOD, ONLY : DEPSAV +! USE PRESSURE_MOD, ONLY : GET_PCENTER +! USE TRACER_MOD, ONLY : SALA_REDGE_um, SALC_REDGE_um, XNUMOL +! USE TRACERID_MOD, ONLY : IDTSO4s, IDTNITs +! USE TIME_MOD, ONLY : GET_ELAPSED_SEC, GET_TS_CHEM +! USE GRID_MOD, ONLY : GET_AREA_CM2 +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_GCTM" ! g0 +!# include "CMN_DIAG" ! ND44 +! +! ! Arguments +! INTEGER, INTENT(IN) :: N +! REAL*8, INTENT(INOUT) :: TC(IIPAR,JJPAR,LLPAR) +! +! ! Local variables +! INTEGER :: I, J, L, DTCHEM +! REAL*8 :: DELZ, DELZ1, REFF +! REAL*8 :: P, DP, PDP, TEMP +! REAL*8 :: CONST, SLIP, VISC, FAC1 +! REAL*8 :: FAC2, FLUX, AREA_CM2, RHB +! REAL*8 :: RCM, RWET, RATIO_R, RHO +! REAL*8 :: TOT1, TOT2 +! REAL*8 :: VTS(LLPAR) +! REAL*8 :: TC0(LLPAR) +! +! ! Parameters +! REAL*8, PARAMETER :: C1 = 0.7674d0 +! REAL*8, PARAMETER :: C2 = 3.079d0 +! REAL*8, PARAMETER :: C3 = 2.573d-11 +! REAL*8, PARAMETER :: C4 = -1.424d0 +! REAL*8, PARAMETER :: DEN = 2200.0d0 ! [kg/m3] sea-salt density +! +! ! Arrays +! INTEGER :: IDDEP(2) +! INTEGER :: IDTRC(2) +! +! !================================================================= +! ! GRAV_SETTLING begins here! +! !================================================================= +! +! ! Return if tracers are undefined +! IF ( IDTSO4s == 0 .and. IDTNITs == 0 ) RETURN +! +! ! Return if it's the start of the run +! IF ( GET_ELAPSED_SEC() == 0 ) RETURN +! +! ! Chemistry timestep [s] +! DTCHEM = GET_TS_CHEM() * 60d0 +! +! ! Store in IDDEP array +! IDDEP(1) = DRYSO4s +! IDDEP(2) = DRYNITs +! +! ! Tracer array +! IDTRC(1) = IDTSO4s +! IDTRC(2) = IDTNITs +! +! ! Coarse mode +! REFF = 0.5d-6 * ( SALC_REDGE_um(1) + SALC_REDGE_um(2) ) +! +! ! Sea salt radius [cm] +! RCM = REFF * 100d0 +! +! ! Exponential factors +! FAC1 = C1 * ( RCM**C2 ) +! FAC2 = C3 * ( RCM**C4 ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L, VTS, P, TEMP, RHB, RWET ) +!!$OMP+PRIVATE( RATIO_R, RHO, DP, PDP, CONST, SLIP, VISC, TC0 ) +!!$OMP+PRIVATE( DELZ, DELZ1, TOT1, TOT2, AREA_CM2, FLUX ) +!!$OMP+SCHEDULE( DYNAMIC ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Initialize +! DO L = 1, LLPAR +! VTS(L) = 0d0 +! ENDDO +! +! ! Loop over levels +! DO L = 1, LLPAR +! +! ! Pressure at center of the level [kPa] +! P = GET_PCENTER(I,J,L) * 0.1d0 +! +! ! Temperature [K] +! TEMP = T(I,J,L) +! +! ! Cap RH at 0.99 +! RHB = MIN( 0.99d0, RH(I,J,L) * 1d-2 ) +! +! ! Safety check (phs, 5/1/08) +! RHB = MAX( TINY(RHB), RHB ) +! +! ! Aerosol growth with relative humidity in radius [m] +! ! (Gerber, 1985) +! RWET = 0.01d0*(FAC1/(FAC2-DLOG(RHB))+RCM**3.d0)**0.33d0 +! +! ! Ratio dry over wet radii at the cubic power +! RATIO_R = ( REFF / RWET )**3.d0 +! +! ! Density of the wet aerosol (kg/m3) +! RHO = RATIO_R * DEN + ( 1.d0 - RATIO_R ) * 1000.d0 +! +! ! Dp = particle diameter [um] +! DP = 2.d0 * RWET * 1.d6 +! +! ! PdP = P * dP [hPa * um] +! PDp = P * Dp +! +! ! Constant +! CONST = 2.d0 * RHO * RWET**2 * g0 / 9.d0 +! +! !=========================================================== +! ! NOTE: Slip correction factor calculations following +! ! Seinfeld, pp464 which is thought to be more accurate +! ! but more computation required. (rjp, 1/24/02) +! ! +! ! # air molecule number density +! ! num = P * 1d3 * 6.023d23 / (8.314 * Temp) +! ! +! ! # gas mean free path +! ! lamda = 1.d6/( 1.41421 * num * 3.141592 * (3.7d-10)**2 ) +! ! +! ! # Slip correction +! ! Slip = 1. + 2. * lamda * (1.257 + 0.4 * exp( -1.1 * Dp +! ! & / (2. * lamda))) / Dp +! ! +! ! NOTE: Eq) 3.22 pp 50 in Hinds (Aerosol Technology) +! ! which produces slip correction factore with small error +! ! compared to the above with less computation. +! !=========================================================== +! +! ! Slip correction factor (as function of P*dp) +! Slip = 1.d0+(15.60d0 + 7.0d0 * EXP(-0.059d0 * PDp)) / PDp +! +! ! Viscosity [Pa*s] of air as a function of temperature +! VISC = 1.458d-6 * (Temp)**(1.5d0) / ( Temp + 110.4d0 ) +! +! ! Settling velocity [m/s] +! VTS(L) = CONST * Slip / VISC +! ENDDO +! +! ! Method is to solve bidiagonal matrix which is +! ! implicit and first order accurate in z (rjp, 1/24/02) +! +! ! Save initial tracer concentration in column +! DO L = 1, LLPAR +! TC0(L) = TC(I,J,L) +! ENDDO +! +! ! We know the boundary condition at the model top +! L = LLTROP +! DELZ = BXHEIGHT(I,J,L) +! +! TC(I,J,L) = TC(I,J,L) / ( 1.d0 + DTCHEM * VTS(L) / DELZ ) +! +! DO L = LLTROP-1, 1, -1 +! DELZ = BXHEIGHT(I,J,L) +! DELZ1 = BXHEIGHT(I,J,L+1) +! TC(I,J,L) = 1.d0 / ( 1.d0 + DTCHEM * VTS(L) / DELZ ) +! & * ( TC(I,J,L) + DTCHEM * VTS(L+1) / DELZ1 +! & * TC(I,J,L+1) ) +! ENDDO +! +! !============================================================== +! ! ND44 diagnostic: sea salt loss [molec/cm2/s] +! !============================================================== +! IF ( ND44 > 0 ) THEN +! +! ! Initialize +! TOT1 = 0d0 +! TOT2 = 0d0 +! +! ! Compute column totals of TCO(:) and TC(I,J,:,N) +! DO L = 1, LLPAR +! TOT1 = TOT1 + TC0(L) +! TOT2 = TOT2 + TC(I,J,L) +! ENDDO +! +! ! Surface area [cm2] +! AREA_CM2 = GET_AREA_CM2( J ) +! +! ! Convert sea salt flux from [kg/s] to [molec/cm2/s] +! FLUX = ( TOT1 - TOT2 ) / DTCHEM +! FLUX = FLUX * XNUMOL(IDTRC(N)) / AREA_CM2 +! +! ! Store in AD44 array +! AD44(I,J,IDDEP(N),1) = AD44(I,J,IDDEP(N),1) + FLUX +! ENDIF +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! Return to calling program +! END SUBROUTINE GRAV_SETTLING +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CHEM_DMS +!! +!!****************************************************************************** +!! Subroutine CHEM_DMS is the DMS chemistry subroutine from Mian Chin's +!! GOCART model, modified for use with the GEOS-CHEM model. +!! (rjp, bdf, bmy, 5/31/00, 10/25/05) +!! +!! Module Variables used: +!! ============================================================================ +!! (1 ) PSO2_DMS (REAL*8 ) : Array for P(SO2) from DMS [v/v] +!! (2 ) PMSA_DMS (REAL*8 ) : Array for P(MSA) from DMS [v/v] +!! +!! Reaction List (by Mian Chin, chin@rondo.gsfc.nasa.gov) +!! ============================================================================ +!! +!! R1: DMS + OH -> a*SO2 + b*MSA OH addition channel +!! k1 = { 1.7e-42*exp(7810/T)*[O2] / (1+5.5e-31*exp(7460/T)*[O2] } +!! a = 0.75, b = 0.25 +!! +!! R2: DMS + OH -> SO2 + ... OH abstraction channel +!! k2 = 1.2e-11*exp(-260/T) +!! +!! DMS_OH = DMS0 * exp(-(r1+r2)* NDT1) +!! where DMS0 is the DMS concentration at the beginning, +!! r1 = k1*[OH], r2 = k2*[OH]. +!! +!! R3: DMS + NO3 -> SO2 + ... +!! k3 = 1.9e-13*exp(500/T) +!! +!! DMS = DMS_OH * exp(-r3*NDT1) +!! where r3 = k3*[NO3]. +!! +!! R4: DMS + X -> SO2 + ... +!! assume to be at the rate of DMS+OH and DMS+NO3 combined. +!! +!! The production of SO2 and MSA here, PSO2_DMS and PMSA_DMS, are saved +!! for use in CHEM_SO2 and CHEM_MSA subroutines as a source term. They +!! are in unit of [v/v/timestep]. +!! +!! NOTES: +!! (1 ) Now reference AD, AIRDEN, and SUNCOS from "dao_mod.f". Added +!! parallel DO-loops. Also now extract OH and NO3 from SMVGEAR +!! for coupled chemistry-aerosol runs. (rjp, bdf, bmy, 9/16/02) +!! (2 ) Bug fix: remove duplicate definition of RK3 (bmy, 3/23/03) +!! (3 ) Now use function GET_TS_CHEM from "time_mod.f". (bmy, 3/27/03) +!! (4 ) Now reference STT and ITS_A_FULLCHEM_SIM from "tracer_mod.f" +!! Now replace IJSURF w/ an analytic function. (bmy, 7/20/04) +!! (5 ) Shift rows 8,9 in AD05 to 9,10 in to make room for P(SO4) from O3 +!! oxidation in sea-salt aerosols (bec, bmy, 4/13/05) +!! (6 ) Now remove reference to CMN, it's obsolete. Now reference +!! ITS_IN_THE_STRAT from "tropopause_mod.f". (bmy, 8/22/05) +!! (7 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE DAO_MOD, ONLY : AD, AIRDEN, SUNCOS, T +! USE DIAG_MOD, ONLY : AD05 +! USE DRYDEP_MOD, ONLY : DEPSAV +! USE TIME_MOD, ONLY : GET_TS_CHEM +! USE TRACER_MOD, ONLY : STT, ITS_A_FULLCHEM_SIM, XNUMOL +! USE TRACERID_MOD, ONLY : IDTDMS +! USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_GCTM" ! AIRMW +!# include "CMN_DIAG" ! ND05, LD05 +! +! ! Local variables +! LOGICAL :: IS_FULLCHEM +! INTEGER :: I, J, L, IJLOOP +! REAL*8 :: TK, O2, RK1, RK2, RK3, F +! REAL*8 :: DMS, DMS0, DMS_OH, DTCHEM, XOH, XN3 +! REAL*8 :: XX, OH, OH0, XNO3, XNO30, LOH +! REAL*8 :: LNO3 +! +! ! Parameters +! REAL*8, PARAMETER :: FX = 1.0d0 +! REAL*8, PARAMETER :: A = 0.75d0 +! REAL*8, PARAMETER :: B = 0.25d0 +! +! ! From D4: only 0.8 efficiency, also some goes to DMSO and lost. +! ! So we assume 0.75 efficiency for DMS addtion channel to form +! ! products. +! REAL*8, PARAMETER :: EFF = 1d0 +! +! ! External functions +! REAL*8, EXTERNAL :: BOXVL +! +! !================================================================= +! ! CHEM_DMS begins here! +! !================================================================= +! IF ( IDTDMS == 0 ) RETURN +! +! ! Flag for fullchem simulation +! IS_FULLCHEM = ITS_A_FULLCHEM_SIM() +! +! ! DTCHEM is the chemistry timestep in seconds +! DTCHEM = GET_TS_CHEM() * 60d0 +! +! ! Factor to convert AIRDEN from kgair/m3 to molecules/cm3: +! f = 1000.d0 / AIRMW * 6.022d23 * 1.d-6 +! +! !================================================================= +! ! Do the chemistry over all tropospheric grid boxes! +! !================================================================= +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, IJLOOP, J, L, TK, O2, DMS0, OH, XNO3, RK1, RK2 ) +!!$OMP+PRIVATE( RK3, DMS_OH, DMS, OH0, XNO30, XOH, XN3, XX, LOH, LNO3 ) +!!$OMP+SCHEDULE( DYNAMIC ) +! DO L = 1, LLTROP +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Skip stratospheric boxes +! IF ( ITS_IN_THE_STRAT( I, J, L ) ) CYCLE +! +! ! IJLOOP is the 1-D grid box index for SUNCOS +! IJLOOP = ( (J-1) * IIPAR ) + I +! +! ! Temperature [K] +! TK = T(I,J,L) +! +! ! Get O2 [molec/cm3], DMS [v/v], OH [molec/cm3], NO3 [molec/cm3] +! O2 = AIRDEN(L,I,J) * f * 0.21d0 +! DMS0 = STT(I,J,L,IDTDMS) +! OH = GET_OH( I, J, L ) +! XNO3 = GET_NO3( I, J, L ) +! +! !============================================================== +! ! (1) DMS + OH: RK1 - addition channel +! ! RK2 - abstraction channel +! !============================================================== +! RK1 = 0.d0 +! RK2 = 0.d0 +! RK3 = 0.d0 +! +! IF ( OH > 0.d0 ) THEN +! RK1 = ( 1.7d-42 * EXP( 7810.d0 / TK ) * O2 ) / +! & ( 1.d0 + 5.5d-31 * EXP( 7460.d0 / TK ) * O2 ) * OH +! +! RK2 = 1.2d-11 * EXP( -260.d0 / TK ) * OH +! ENDIF +! +! !============================================================== +! ! (2) DMS + NO3 (only happens at night): +! !============================================================== +! IF ( SUNCOS(IJLOOP) <= 0d0 ) THEN +! RK3 = 1.9d-13 * EXP( 500.d0 / TK ) * XNO3 +! ENDIF +! +! !============================================================== +! ! Update DMS concentrations after reaction with OH and NO3, +! ! and also account for DMS + X assuming at a rate as +! ! (DMS+OH)*Fx in the day and (DMS+NO3)*Fx at night: +! ! +! ! DMS_OH : DMS concentration after reaction with OH +! ! DMS : DMS concentration after reaction with NO3 +! ! (min(DMS) = 1.0E-32) +! ! +! ! NOTE: If we are doing a coupled fullchem/aerosol run, then +! ! also modify OH and NO3 concentrations after rxn w/ DMS. +! !============================================================== +! DMS_OH = DMS0 * EXP( -( RK1 + RK2 ) * Fx * DTCHEM ) +! DMS = DMS_OH * EXP( -( RK3 ) * Fx * DTCHEM ) +! IF ( DMS < SMALLNUM ) DMS = 0d0 +! +! ! Archive initial OH and NO3 for diagnostics +! OH0 = OH +! XNO30 = XNO3 +! +! IF ( IS_FULLCHEM ) THEN +! +! ! Update OH after rxn w/ DMS (coupled runs only) +! OH = OH0 - ( ( DMS0 - DMS_OH ) * AIRDEN(L,I,J) * f ) +! IF ( OH < SMALLNUM ) OH = 0d0 +! +! ! Update NO3 after rxn w/ DMS (coupled runs only) +! XNO3 = XNO30 - ( ( DMS_OH - DMS ) * AIRDEN(L,I,J) * f ) +! IF ( XNO3 < SMALLNUM ) XNO3 = 0d0 +! +! ENDIF +! +! ! Save DMS back to the tracer array +! STT(I,J,L,IDTDMS) = DMS +! +! !============================================================== +! ! Save SO2 and MSA production from DMS oxidation +! ! in [mixing ratio/timestep]: +! ! +! ! SO2 is formed in DMS+OH addition (0.85) and abstraction +! ! (1.0) channels as well as DMS + NO3 reaction. We also +! ! assume that SO2 yield from DMS + X is 1.0. +! ! +! ! MSA is formed in DMS + OH addition (0.15) channel. +! !============================================================== +! IF ( ( RK1 + RK2 ) == 0.d0 ) THEN +! PMSA_DMS(I,J,L) = 0.d0 +! ELSE +! PMSA_DMS(I,J,L) = ( DMS0 - DMS_OH ) * +! & B*RK1 / ( ( RK1 + RK2 ) * Fx ) * EFF +! ENDIF +! +! PSO2_DMS(I,J,L) = DMS0 - DMS - PMSA_DMS(I,J,L) +! +! !============================================================== +! ! ND05 diagnostic: production and loss +! ! +! ! For the offline run, we are reading in monthly mean OH, NO3 +! ! from disk. We don't modify these, so LOH = 0 and LNO3 = 0. +! !============================================================== +! IF ( ND05 > 0 .and. L <= LD05 ) THEN +! +! ! P(SO2) from DMS+OH, DMS+NO3, and DMS+X +! XOH = ( DMS0 - DMS_OH ) / Fx * AD(I,J,L) / TCVV_S +! XN3 = ( DMS_OH - DMS ) / Fx * AD(I,J,L) / TCVV_S +! XX = ( ( DMS0 - DMS ) * AD(I,J,L) / TCVV_S ) - XOH - XN3 +! +! ! Convert L(OH) and L(NO3) from [molec/cm3] to [kg/timestep] +! LOH = ( OH0 - OH ) * BOXVL(I,J,L) / XNUMOL_OH +! LNO3 = ( XNO30 - XNO3 ) * BOXVL(I,J,L) / XNUMOL_NO3 +! +! ! Store P(SO2) from DMS + OH [kg S/timestep] +! AD05(I,J,L,1) = AD05(I,J,L,1) + XOH +! +! ! Store P(SO2) from DMS + NO3 [kg S/timestep] +! AD05(I,J,L,2) = AD05(I,J,L,2) + XN3 +! +! ! Store total P(SO2) from DMS [kg S/timestep] +! AD05(I,J,L,3) = AD05(I,J,L,3) + +! & ( PSO2_DMS(I,J,L) * AD(I,J,L) / TCVV_S ) +! +! ! Store P(MSA) from DMS [kg S/timestep] +! AD05(I,J,L,4) = AD05(I,J,L,4) + +! & ( PMSA_DMS(I,J,L) * AD(I,J,L) / TCVV_S ) +! +! ! Store L(OH) by DMS [kg OH/timestep] +! AD05(I,J,L,9) = AD05(I,J,L,9) + LOH +! +! ! Store L(NO3) by DMS [kg NO3/timestep] +! AD05(I,J,L,10) = AD05(I,J,L,10) + LNO3 +! +! ENDIF +! +! !============================================================== +! ! For a coupled fullchem/aerosol run, save OH [molec/cm3] +! ! and NO3 [molec/cm3] back into the CSPEC array of SMVGEAR +! !============================================================== +! IF ( IS_FULLCHEM ) THEN +! CALL SET_OH( I, J, L, OH ) +! CALL SET_NO3( I, J, L, XNO3 ) +! ENDIF +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! Return to calling program +! END SUBROUTINE CHEM_DMS +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CHEM_H2O2 +!! +!!****************************************************************************** +!! Subroutine CHEM_H2O2 is the H2O2 chemistry subroutine for offline sulfate +!! simulations. For coupled runs, H2O2 chemistry is already computed by +!! the SMVGEAR module. (rjp, bmy, 11/26/02, 10/25/05) +!! +!! NOTES: +!! (1 ) Bug fix: need to multiply DXYP by 1d4 for cm2 (bmy, 3/23/03) +!! (2 ) Now replace DXYP(JREF)*1d4 with routine GET_AREA_CM2 of "grid_mod.f" +!! Now use functions GET_MONTH and GET_TS_CHEM from "time_mod.f". +!! (bmy, 3/27/03) +!! (3 ) Now references PBLFRAC from "drydep_mod.f". Now apply dry deposition +!! throughout the entire PBL. Added FREQ variable. (bmy, 8/1/03) +!! (4 ) Now use ND44_TMP array to store vertical levels of drydep flux, then +!! sum into AD44 array. This preents numerical differences when using +!! multiple processors. (bmy, 3/24/04) +!! (5 ) Now use diurnally-varying JO1D. Now use new unit conversion for +!! the ND44 diagnostic. (rjp, bmy, 3/30/04) +!! (6 ) Now use parallel DO-loop to zero ND44_TMP. Now uses ITS_A_NEW_MONTH +!! from time_mod.f. (bmy, 4/14/04) +!! (7 ) Now reference STT & TCVV from "tracer_mod.f". Also replace IJSURF +!! with an analytic function. Now references DATA_DIR from +!! "directory_mod.f". (bmy, 7/20/04) +!! (8 ) Now suppress output from READ_BPCH with QUIET keyword (bmy, 1/25/05) +!! (9 ) Replace PBLFRAC from "drydep_mod.f" with GET_FRAC_UNDER_PBLTOP +!! from "pbl_mix_mod.f" (bmy, 2/22/05) +!! (10) Now read offline files from "sulfate_sim_200508/offline". Now remove +!! reference to CMN, it's obsolete. Now reference ITS_IN_THE_STRAT from +!! "tropopause_mod.f". (bmy, 8/22/05) +!! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (12) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! USE DAO_MOD, ONLY : AD, AIRDEN, OPTD, SUNCOS, T +! USE DIAG_MOD, ONLY : AD44 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE DRYDEP_MOD, ONLY : DEPSAV +! USE GRID_MOD, ONLY : GET_AREA_CM2 +! USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP +! USE TIME_MOD, ONLY : GET_MONTH, GET_TS_CHEM, ITS_A_NEW_MONTH +! USE TRACER_MOD, ONLY : STT, TCVV, XNUMOL +! USE TRACERID_MOD, ONLY : IDTH2O2 +! USE TRANSFER_MOD, ONLY : TRANSFER_3D_TROP +! USE UVALBEDO_MOD, ONLY : UVALBEDO +! USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT +! +!# include "cmn_fj.h" ! IPAR, JPAR, LPAR, CMN_SIZE +!# include "CMN_GCTM" ! AIRMW +!# include "CMN_DIAG" ! ND44 +! +! ! Local variables +! LOGICAL :: FIRST = .TRUE. +! INTEGER, SAVE :: LASTMONTH = -99 +! INTEGER :: I, J, L, JLOOP +! REAL*4 :: ARRAY(IGLOB,JGLOB,LLTROP) +! REAL*8 :: ND44_TMP(IIPAR,JJPAR,LLTROP) +! REAL*8 :: DT, Koh, DH2O2, M, F , XTAU +! REAL*8 :: H2O20, H2O2, ALPHA, FLUX, FREQ, PHOTJ +! REAL*8, PARAMETER :: A = 2.9d-12 +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! CHEM_H2O2 begins here! +! !================================================================= +! IF ( IDTH2O2 == 0 .or. DRYH2O2 == 0 ) RETURN +! +! ! Chemistry timestep [s] +! DT = GET_TS_CHEM() * 60d0 +! +! ! Factor to convert AIRDEN from kgair/m3 to molecules/cm3: +! F = 1000.d0 / AIRMW * 6.022d23 * 1.d-6 +! +! ! Zero ND44_TMP array +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLTROP +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! ND44_TMP(I,J,L) = 0d0 +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF +! +! !================================================================= +! ! For offline run: read J(H2O2) from disk below +! !================================================================= +! IF ( ITS_A_NEW_MONTH() ) THEN +! +! ! File name to read data +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/offline/JH2O2.' // +! & GET_NAME_EXT() // '.' // GET_RES_EXT() +! +! ! Print filename +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - CHEM_H2O2: Reading ', a ) +! +! ! Get TAU0 value for this month in "generic" year 1985 +! XTAU = GET_TAU0( GET_MONTH(), 1, 1985 ) +! +! ! Read J(H2O2) [s-1] from disk (only up to tropopause) +! ! limit array 3d dimension to LLTROP_FIX, i.e, case of annual mean +! ! tropopause. This is backward compatibility with +! ! offline data set. +! CALL READ_BPCH2( FILENAME, 'JV-MAP-$', 3, +! & XTAU, IGLOB, JGLOB, +! & LLTROP_FIX, ARRAY(:,:,1:LLTROP_FIX), QUIET=.TRUE. ) +!! & XTAU, IGLOB, JGLOB, +!! & LLTROP, ARRAY, QUIET=.TRUE. ) +! +! +! +! ! Cast to REAL*8 and resize if necessary +! CALL TRANSFER_3D_TROP( ARRAY, JH2O2 ) +! +! ! Reset LASTMONTH +! !LASTMONTH = GET_MONTH() +! ENDIF +! +! !================================================================= +! ! Loop over tropopsheric grid boxes and do chemistry +! !================================================================= +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L, M, H2O20, KOH, FREQ, ALPHA, DH2O2, H2O2, FLUX ) +!!$OMP+PRIVATE( JLOOP, PHOTJ ) +!!$OMP+SCHEDULE( DYNAMIC ) +! DO L = 1, LLTROP +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Initialize for safety's sake +! FLUX = 0d0 +! FREQ = 0d0 +! +! ! Skip stratospheric boxes +! IF ( ITS_IN_THE_STRAT( I, J, L ) ) CYCLE +! +! ! Density of air [molec/cm3] +! M = AIRDEN(L,I,J) * f +! +! ! Initial H2O2 [v/v] +! H2O20 = STT(I,J,L,IDTH2O2) +! +! ! Loss frequenty due to OH oxidation [s-1] +! KOH = A * EXP( -160.d0 / T(I,J,L) ) * GET_OH(I,J,L) +! +! ! H2O2 drydep frequency [1/s]. Account for the fraction +! ! of grid box (I,J,L) that is located beneath the PBL top. +! FREQ = DEPSAV(I,J,DRYH2O2) * GET_FRAC_UNDER_PBLTOP( I, J, L ) +! +! ! 1-D grid box index for SUNCOS +! JLOOP = ( (J-1) * IIPAR ) + I +! +! ! Impose a diurnal variation of jH2O2 by multiplying COS of +! ! solar zenith angle normalized by maximum solar zenith angle +! ! because the archived JH2O2 is for local noon time +! IF ( COSZM(I,J) > 0.d0 ) THEN +! PHOTJ = JH2O2(I,J,L) * SUNCOS(JLOOP) / COSZM(I,J) +! PHOTJ = MAX( PHOTJ, 0d0 ) +! ELSE +! PHOTJ = 0d0 +! ENDIF +! +! ! Compute loss fraction from OH, photolysis, drydep [unitless]. +! ALPHA = 1.D0 + ( KOH + PHOTJ + FREQ ) * DT +! +! ! Delta H2O2 [v/v] +! DH2O2 = PH2O2m(I,J,L) * DT / ( ALPHA * M ) +! +! ! Final H2O2 [v/v] +! H2O2 = ( H2O20 / ALPHA + DH2O2 ) +! IF ( H2O2 < SMALLNUM ) H2O2 = 0d0 +! +! ! Store final H2O2 in STT +! STT(I,J,L,IDTH2O2) = H2O2 +! +! !============================================================== +! ! ND44 diagnostics: H2O2 drydep loss [molec/cm2/s] +! !============================================================== +! IF ( ND44 > 0 .AND. FREQ > 0d0 ) THEN +! +! ! Convert H2O2 from [v/v] to H2O2 [molec/cm2/s] +! FLUX = H2O20 * FREQ * DT / ( 1.D0 + FREQ * DT ) +! FLUX = FLUX * AD(I,J,L) / TCVV(IDTH2O2) +! FLUX = FLUX * XNUMOL(IDTH2O2) / ( GET_AREA_CM2( J ) * DT ) +! +! ! Save dryd flx in ND44_TMP as a placeholder +! ND44_TMP(I,J,L) = ND44_TMP(I,J,L) + FLUX +! ENDIF +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! !=============================================================== +! ! ND44: Sum drydep fluxes by level into the AD44 array in +! ! order to ensure that we get the same results w/ sp or mp +! !=============================================================== +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! DO L = 1, LLTROP +! AD44(I,J,DRYH2O2,1) = AD44(I,J,DRYH2O2,1) + ND44_TMP(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE CHEM_H2O2 +! +!!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_SO2_ADJ +! +!****************************************************************************** +! Subroutine CHEM_SO2_ADJ is the adjoint of the SO2 chemistry subroutine +! (dkh, 10/11/05) +! +! Based on forward model subroutine CHEM_SO2 (rjp, bmy, 11/26/02, 10/25/05) +! +! NOTES: +! (1 ) Now reference WETSCAV_MOD instead of WETSCAV_ADJ_MOD. (dkh, 10/24/05) +! (2 ) BUG FIX Add ADL3S to list of PRIVATE variables. (dkh, 10/08/06) +! (3 ) BUG FIX Initialize ADL3S to zero. (dkh, 01/25/07) +! (4 ) Updated to GCv8 adj (dkh, 09/27/09) +! (5 ) Several bugs fixed (Jamin, Daven) +! (6 ) Watch for L3 = 1d0 (dkh, 01/06/12, adj32_005) +! (7 ) Add support for dry deposition (fp) +!****************************************************************************** +! + ! Reference to diagnostic arrays + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE CHECKPT_MOD, ONLY : SO2_CHK + USE CHECKPT_MOD, ONLY : H2O2_CHK + USE DAO_MOD, ONLY : AD, AIRDEN, T + USE DIAG_MOD, ONLY : AD05, AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE ERROR_MOD, ONLY : ERROR_STOP + USE ERROR_MOD, ONLY : IS_SAFE_DIV + USE ERROR_MOD, ONLY : IS_SAFE_EXP + USE ERROR_MOD, ONLY : IT_IS_NAN + USE GLOBAL_HNO3_MOD, ONLY : GET_GLOBAL_HNO3 + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_MONTH + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH + USE TRACER_MOD, ONLY : STT, TCVV, ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTH2O2, IDTSO2 + USE SEASALT_MOD, ONLY : GET_ALK + USE WETSCAV_MOD, ONLY : H2O2s, SO2s + USE WETSCAV_ADJ_MOD, ONLY : H2O2s_ADJ, SO2s_ADJ + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT + +!support for dry deposition of so2 + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS, LADJ_DDEP_TRACER + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION, ADJOINT_AREA_M2 + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER, DEP_UNIT + USE ADJ_ARRAYS_MOD, ONLY : NSPAN, TR_DDEP_CONV + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! AIRMW + + ! Local variables + LOGICAL :: IS_OFFLINE + INTEGER :: I, J, L, I1, I2 + INTEGER :: II, NSTEP + REAL*8 :: K0, Ki, KK, M, L1 + REAL*8 :: L2, L3, Ld, F, Fc + REAL*8 :: RK, RKT, DTCHEM, DT_T, TK + REAL*8 :: F1, RK1, RK2, RK3, SO20 + REAL*8 :: SO2_cd, H2O20, O3, L2S, L3S + REAL*8 :: LWC, KaqH2O2, KaqO3, PATM, FLUX + REAL*8 :: ALK, ALK1, ALK2, SO2_ss + REAL*8 :: Kt1, Kt2, AREASS1, AREASS2 + REAL*8 :: PSO4E, PSO4F, Kt1N, Kt2N + REAL*8 :: AREA_CM2 + REAL*8 :: XX_ADJ + REAL*8 :: XX + REAL*8 :: tmp1, tmp2 + + !for dry deposition forcing + REAL*8, SAVE :: NTSCHEM + REAL*8, SAVE :: FACT + LOGICAL :: FORCE + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER, SAVE :: OBS_COUNT = 0 + + + ! Parameters + REAL*8, PARAMETER :: HPLUS = 3.16227766016837953d-5 !pH = 4.5 + REAL*8, PARAMETER :: MINDAT = 1.d-20 + +C============================================== +C define local TAMC generated variables +C============================================== + real*8 adh2o20 + real*8 adl1 + real*8 adl2 + real*8 adl2s + real*8 adl3 + real*8 adl3s + real*8 ado3 + real*8 adso20 + real*8 adso2_cd + + + + !================================================================= + ! CHEM_SO2_ADJ begins here! + !================================================================= + IF ( IDTH2O2 == 0 .or. IDTSO2 == 0 .or. DRYSO2 == 0 ) RETURN + + !determine if it is time to apply deposition forcing + FORCE = .FALSE. + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + 1 + IF ( OBS_COUNT <= NSPAN + & .and. LADJ_DDEP_TRACER + & .and. OBS_THIS_TRACER(IDTSO2) ) THEN + FORCE = .TRUE. + + WRITE(6,100) , 'SO2' , TRIM( DEP_UNIT ) + + ENDIF + + ELSEIF ( LADJ_DDEP_TRACER .and. OBS_THIS_TRACER(IDTSO2) ) THEN + + FORCE = .TRUE. + WRITE(6,100) , 'SO2' , TRIM( DEP_UNIT ) + + ENDIF + 100 FORMAT('Forcing ',a,' drydep (', a,')') + + ! DTCHEM is the chemistry timestep in seconds + DTCHEM = GET_TS_CHEM() * 60d0 + ! initialize some constants for depostion forcing + IF ( FORCE .and. FIRST ) THEN + + ! here we aren't assuming that TS_CHEM is necessarily 1 hr + NTSCHEM = NSPAN / ( GET_TS_CHEM() / 60D0 ) + + !default is molec/cm2/s + FACT = XNUMOL(IDTSO2) / DTCHEM + & / TCVV(IDTSO2) / NTSCHEM + + FIRST = .FALSE. + ENDIF + + ! Is it an offline simulation? + IS_OFFLINE = ITS_AN_AEROSOL_SIM() + + ! Read HNO3 for offline simulation + IF ( IS_OFFLINE ) THEN + IF ( ITS_A_NEW_MONTH() ) THEN + CALL GET_GLOBAL_HNO3( GET_MONTH() ) + ENDIF + ENDIF + + ! Factor to convert AIRDEN from [kg air/m3] to [molec air/cm3] + F = 1000.d0 / AIRMW * 6.022d23 * 1.d-6 + Ki = 1.5d-12 + + + ! Loop over tropospheric grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, SO20, H2O20, O3, PATM, TK, K0, M, KK, F1, RK1 ) +!$OMP+PRIVATE( RK2, RK, RKT, SO2_cd, L1, Ld, L2, L2S, L3, L3S, FC, LWC ) +!$OMP+PRIVATE( KaqH2O2, KaqO3, AREA_CM2, FLUX, ALK, ALK1, ALK2 ) +!$OMP+PRIVATE( Kt1, Kt2, AREASS1, AREASS2, SO2_ss, Kt1N, Kt2N ) +!$OMP+PRIVATE( PSO4E, PSO4F ) +!$OMP+PRIVATE( ADH2O20, ADL1, ADL2, ADL2S, ADL3, ADO3, ADSO20, ADSO2_CD) +!$OMP+PRIVATE( ADL3S ) +!$OMP+PRIVATE( XX, XX_ADJ, TMP1, TMP2 ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, LLTROP + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Initialize for safety's sake + AREA_CM2 = 0d0 + FLUX = 0d0 + Ld = 0d0 + + ! Skip stratospheric boxes + IF ( ITS_IN_THE_STRAT( I, J, L ) ) CYCLE + + ! Initial SO2, H2O2 and O3 [v/v] + SO20 = SO2_CHK(I,J,L) + H2O20 = H2O2_CHK(I,J,L) + O3 = GET_O3(I,J,L) + + ! Initialize local adjoint variables. + ! Note: O3 influences sulfate chemistry but not vice versa, hence + ! we initialize ADO3 to zeroo here and update the global array + ! later. Also, adpso4_so2 got it's initial value during + ! ADJ_CHEM_SO4. adso2s(:,:,:) and adh2o2s(:,:,:) get their + ! values from adj_wetdep + ! ( would it be faster to intialize them to zero outside the loop + ! and then declare them FIRSTPRIVATE ? ) + ADO3 = 0d0 + ADL1 = 0d0 + ADL2 = 0d0 + ADL2S = 0d0 + ADL3S = 0d0 + ADL3 = 0d0 + ADSO20 = 0d0 + ADH2O20 = 0D0 + ADSO2_CD = 0d0 + XX_ADJ = 0d0 + + !--------------------------------------------------------- + ! Initialize parameters not affected by active variables + !--------------------------------------------------------- + + ! PATM : Atmospheric pressure in atm + PATM = GET_PCENTER( I, J, L ) / 1013.25d0 + + ! TK : Temperature [K] + TK = T(I,J,L) + + IF ( IS_OFFLINE ) THEN + + ! Not yet supported in adjoint: + !! Gas phase SO4 production is done here in offline run only + !! RK1: SO2 + OH(g) [s-1] (rjp, bmy, 3/23/03) + !K0 = 3.0d-31 * ( 300.d0 / TK )**3.3d0 + !M = AIRDEN(L,I,J) * F + !KK = K0 * M / Ki + !F1 = ( 1.d0 + ( LOG10( KK ) )**2 )**( -1 ) + !RK1 = ( K0 * M / ( 1.d0 + KK ) ) * 0.6d0**F1 * GET_OH(I,J,L) + ! + CALL ERROR_STOP(' IS_OFFLINE ', 'sulfate_adj_mod.f') + + ELSE + + ! For online runs, SMVGEAR deals w/ this computation, + ! so we can simply set RK1 = 0 (rjp, bmy, 3/23/03) + K0 = 0.d0 + M = 0.d0 + KK = 0.d0 + F1 = 0.d0 + RK1 = 0.d0 + + ENDIF + + ! SO2 drydep frequency [1/s]. Also accounts for the fraction + ! of grid box (I,J,L) that is located beneath the PBL top. + RK2 = DEPSAV(I,J,DRYSO2) * GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! RK: total reaction rate [1/s] + RK = ( RK1 + RK2 ) + + ! RKT: RK * DTCHEM [unitless] (bmy, 6/1/00) + RKT = RK * DTCHEM + + ! Volume cloud fraction (Sundqvist et al 1989) [unitless] + FC = VCLDF(I,J,L) + + ! Liquid water content in cloudy area of grid box [m3/m3] + LWC = GET_LWC( TK ) * FC + + ! Zero variables + KaqH2O2 = 0.d0 + KaqO3 = 0.d0 + L2 = 0.d0 + L3 = 0.d0 + L2S = 0.d0 + L3S = 0.d0 + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + ! dkh debug + IF ( LPRINTFD .and. I == IFD .and. + & J == JFD .and. L == LFD ) THEN + print*, ' ADJ_CHEM_SO2: rk1, rk2, rk ! ' , rk1, rk2, rk + ENDIF + + if (rk .gt. 0.d0) then + so2_cd = so20*exp(-rkt) + else + so2_cd = so20 + endif + + ! adjoint skips sea salt sulfate, so copy SO2_cd directly into SO2_ss + SO2_ss = SO2_cd + + adl1 = adl1+adpso4_so2(i,j,l) + adl2s = adl2s+adpso4_so2(i,j,l) + adl3s = adl3s+adpso4_so2(i,j,l) + adpso4_so2(i,j,l) = 0.d0 + + ! Initialize with global arrays above. "in" and "out" + ! were just dummy variables used to create the adjoint code. + !adpso4_so2(i,j,l) = adpso4_so2(i,j,l)+adout(3) + !adout(3) = 0. + !adso2s(i,j,l) = adso2s(i,j,l)+adout(2) + !!adout(2) = 0. + !adh2o2s(i,j,l) = adh2o2s(i,j,l)+adout(1) + !adout(1) = 0. + SO2s_ADJ(I,J,L) = SO2s_ADJ(I,J,L) + STT_ADJ(I,J,L,IDTSO2) + STT_ADJ(I,J,L,IDTSO2) = 0d0 + H2O2s_ADJ(I,J,L) = H2O2s_ADJ(I,J,L) + STT_ADJ(I,J,L,IDTH2O2) + STT_ADJ(I,J,L,IDTH2O2) = 0d0 + + + if (fc .gt. 0.d0 .and. so2_cd .gt. mindat .and. tk .gt. 258.) then + ! Strange, though true, this routine's output, kaqh2o2 and + ! kaqo3, don't actually depend upon h2o20 or o3 ! + call aqchem_so2( lwc,tk,patm,so2_cd,h2o20,o3,hplus,kaqh2o2, + $kaqo3 ) + + ! Argument of the exponential + XX = ( SO2_ss - O3 ) * KaqO3 * DTCHEM + + IF ( IS_SAFE_EXP( XX ) .and. ABS( XX ) > 0d0 ) THEN + + ! Aqueous phase SO2 loss rate w/ O3 [v/v/timestep] + L3 = EXP( XX ) + + ! Loss by O3 + L3S = SO2_ss * O3 * (L3 - 1.D0) / ((SO2_ss * L3) - O3) + + ELSE + + ! Follow the same logic for L3S as described in + ! Jintai Lin's note above (bmy, 4/28/10) + IF ( XX > 0.d0 ) THEN + L3S = O3 + ELSE + L3S = SO2_ss + ENDIF + ENDIF + + + ! fwd: + !SO2s( I,J,L) = SO2_ss + !H2O2s(I,J,L) = H2O20 + ! adj: + !adh2o20 = adh2o20+adh2o2s(i,j,l) + !adh2o2s(i,j,l) = 0.d0 + adh2o20 = adh2o20+H2O2s_ADJ(i,j,l) + H2O2s_ADJ(i,j,l) = 0.d0 + !adso2_cd = adso2_cd+adso2s(i,j,l) + !adso2s(i,j,l) = 0.d0 + adso2_cd = adso2_cd+SO2s_ADJ(i,j,l) + SO2s_ADJ(i,j,l) = 0.d0 + + + ! fwd: + !SO2_ss = MAX( SO2_ss - ( L2S + L3S ), MINDAT ) + !H2O20 = MAX( H2O20 - L2S, MINDAT ) + ! adj: + adl2s = adl2s-adh2o20*(0.5+sign(0.5d0,h2o20-l2s-mindat)) + adh2o20 = adh2o20*(0.5+sign(0.5d0,h2o20-l2s-mindat)) + adl2s = adl2s-adso2_cd* + & (0.5+sign(0.5d0,so2_cd-(l2s+l3s)-mindat)) + adl3s = adl3s-adso2_cd* + & (0.5+sign(0.5d0,so2_cd-(l2s+l3s)-mindat)) + adso2_cd = adso2_cd* + & (0.5+sign(0.5d0,so2_cd-(l2s+l3s)-mindat)) + + IF ( IS_SAFE_EXP( XX ) .and. ABS( XX ) > 0d0 .and. + & ( SO2_CD * L3 - O3 ) .ne. 0d0 ) THEN + + ! fwd: + !L3S = SO2_ss * O3 * (L3 - 1.D0) / ((SO2_ss * L3) - O3) + ! adj: original TAMC code +! adl3 = adl3+adl3s*(so2_cd*o3/(so2_cd*l3-o3)-so2_cd*o3*(l3-1.d0)* +! $so2_cd/((so2_cd*l3-o3)*(so2_cd*l3-o3))) +! ado3 = ado3+adl3s*(so2_cd*(l3-1.d0)/(so2_cd*l3-o3)+so2_cd*o3* +! $(l3-1.d0)/((so2_cd*l3-o3)*(so2_cd*l3-o3))) +! adso2_cd = adso2_cd+adl3s*(o3*(l3-1.d0)/(so2_cd*l3-o3)-so2_cd* +! $o3*(l3-1.d0)*l3/((so2_cd*l3-o3)*(so2_cd*l3-o3))) + ! adj: numerically stable code avoids L3^2 terms. + TMP1 = ( L3 - 1D0 ) / ( SO2_cd * L3 - O3 ) + TMP2 = 1D0 / ( SO2_cd * L3 - O3 ) + ADO3 = ADO3 + ADL3S * + & ( SO2_cd * TMP1 + SO2_cd * O3 * TMP1 * TMP2 ) + + ADL3 = ADL3 + ADL3S * + & ( SO2_CD * O3 * TMP2 + & - SO2_CD * O3 * SO2_cd * TMP1 * TMP2 ) + + ADSO2_cd = ADSO2_cd + ADL3S * + & ( O3 * TMP1 + & - SO2_cd * O3 * L3 * TMP1 * TMP2 ) + + ! dkh debug + IF ( LPRINTFD .and. I == IFD .and. + & J == JFD .and. L == LFD ) THEN + print*, ' ADJ_CHEM_SO2: adl3s = ', adl3s + print*, ' ADJ_CHEM_SO2: adl3 = ', adl3 + print*, ' ADJ_CHEM_SO2: ado3 = ', ado3 + print*, ' ADJ_CHEM_SO2: adso2_cd = ', adso2_cd + print*, ' ADJ_CHEM_SO2: L3 = ', L3 + print*, ' ADJ_CHEM_SO2: SO2_SS = ', SO2_SS, SO2_cd + print*, ' ADJ_CHEM_SO2: O3 = ', O3 + ENDIF + + ADL3S = 0.d0 + + ! fwd: + !L3 = EXP( XX ) + ! adj: + XX_ADJ = XX_ADJ + ADL3 * L3 + ADL3 = 0d0 + + + ELSE + + ! Follow the same logic for L3S as described in + ! Jintai Lin's note above (bmy, 4/28/10) + IF ( XX > 0.d0 ) THEN + + ! fwd: + !L3S = O3 + ! adj: + ADO3 = ADO3 + ADL3S + ADL3S = 0d0 + + ELSE + + ! fwd: + !L3S = SO2_ss + ! adj: + ADSO2_CD = ADSO2_CD + ADL3S + ADL3S = 0d0 + + ENDIF + ENDIF + + ! fwd: + !XX = ( SO2_ss - O3 ) * KaqO3 * DTCHEM + ! adj: + ADSO2_CD = ADSO2_CD + XX_ADJ * KaqO3 * DTCHEM + ADO3 = ADO3 - XX_ADJ * KaqO3 * DTCHEM + + ! dkh debug + IF ( LPRINTFD .and. I == IFD .and. + & J == JFD .and. L == LFD ) THEN + print*, ' ADJ_CHEM_SO2: ADSO2_CD = ', ADSO2_CD + print*, ' ADJ_CHEM_SO2: XX_ADJ = ', XX_ADJ + ENDIF + + XX_ADJ = 0d0 + + ! Argument of the exponential + XX = ( SO2_ss - H2O20 ) * KaqH2O2 * DTCHEM + + + IF ( IS_SAFE_EXP( XX ) .and. ABS( XX ) > 0d0 ) THEN + + ! Aqueous phase SO2 loss rate w/ H2O2 [v/v/timestep] + L2 = EXP( XX ) + + ! Loss by H2O2 + L2S = SO2_ss * H2O20 * ( L2 - 1.D0 ) / + & ( (SO2_ss * L2) - H2O20 ) + ELSE + + ! NOTE from Jintai Lin (4/28/10): + ! However, in the case of a negative XX, L2S should be + ! approximated as SO2_ss, instead of H2O20. In other words, + ! L2S = SO2_ss * H2O20 * ( L2 - 1.D0 ) / ( (SO2_ss*L2) - H2O20 ) + ! reaches different limits when XX reaches positive infinity + ! and negative infinity. + IF ( XX > 0.d0 ) THEN + L2S = H2O20 + ELSE + L2S = SO2_ss + ENDIF + + ENDIF + + IF ( IS_SAFE_EXP( XX ) .and. ABS( XX ) > 0d0 .and. + & (SO2_CD * L2 - H2O20) .ne. 0d0 ) THEN + + ! fwd: + !L2S = SO2_ss * H2O20 * ( L2 - 1.D0 ) / + ! ( (SO2_ss * L2) - H2O20 ) + ! adj: original TAMC code +! adh2o20 = adh2o20+adl2s*(so2_cd*(l2-1.d0)/(so2_cd*l2-h2o20)+ +! $so2_cd*h2o20*(l2-1.d0)/((so2_cd*l2-h2o20)*(so2_cd*l2-h2o20))) +! adl2 = adl2+adl2s*(so2_cd*h2o20/(so2_cd*l2-h2o20)-so2_cd*h2o20* +! $(l2-1.d0)*so2_cd/((so2_cd*l2-h2o20)*(so2_cd*l2-h2o20))) +! adso2_cd = adso2_cd+adl2s*(h2o20*(l2-1.d0)/(so2_cd*l2-h2o20)- +! $so2_cd*h2o20*(l2-1.d0)*l2/((so2_cd*l2-h2o20)*(so2_cd*l2-h2o20))) + ! adj: numerically stable code avoids L2^2 terms. + TMP1 = ( L2 - 1D0 ) / ( SO2_cd * L2 - H2O20 ) + TMP2 = 1D0 / ( SO2_cd * L2 - H2O20 ) + ADH2O20 = ADH2O20 + ADL2S * + & ( SO2_cd * TMP1 + SO2_cd * H2O20 * TMP1 * TMP2 ) + + ADL2 = ADL2 + ADL2S * + & ( SO2_CD * H2O20 * TMP2 + & - SO2_CD * H2O20 * SO2_cd * TMP1 * TMP2 ) + + ADSO2_cd = ADSO2_cd + ADL2S * + & ( H2O20 * TMP1 + & - SO2_cd * H2O20 * L2 * TMP1 * TMP2 ) + + ! dkh debug + IF ( LPRINTFD .and. I == IFD .and. + & J == JFD .and. L == LFD ) THEN + print*, ' ADJ_CHEM_SO2: adl2s = ', adl2s + print*, ' ADJ_CHEM_SO2: adh2o20 = ', adh2o20 + print*, ' ADJ_CHEM_SO2: adl2 = ', adl2 + print*, ' ADJ_CHEM_SO2: adso2_cd = ', adso2_cd + print*, ' ADJ_CHEM_SO2: SO2_ss = ', SO2_ss, so2_cd + print*, ' ADJ_CHEM_SO2: H2O20 = ', H2O20 + print*, ' ADJ_CHEM_SO2: L2 = ', L2 + ENDIF + + ADL2S = 0.d0 + + ! fwd: + !L2 = EXP( XX ) + ! adj: + XX_ADJ = XX_ADJ + ADL2 * L2 + ADL2 = 0d0 + + ELSE + + ! and negative infinity. + IF ( XX > 0.d0 ) THEN + + ! fwd: + !L2S = H2O20 + ! adj: + ADH2O20 = ADH2O20 + ADL2S + ADL2S = 0d0 + + ELSE + + ! fwd: + !L2S = SO2_ss + ! adj: + ADSO2_CD = ADSO2_CD + ADL2S + ADL2S = 0d0 + + ENDIF + + ENDIF + + ! fwd: + !XX = ( SO2_ss - H2O20 ) * KaqH2O2 * DTCHEM + ! adj: + ADSO2_CD = ADSO2_CD + XX_ADJ * KaqH2O2 * DTCHEM + ADH2O20 = ADH2O20 - XX_ADJ * KaqH2O2 * DTCHEM + XX_ADJ = 0d0 + + +!------------------------------------------------------------------------- + + + else +! adso2_cd = adso2_cd+adso2s(i,j,l)*(0.5+sign(0.5d0,so2_cd-1.d-32) +! $) +! adso2s(i,j,l) = 0.d0 + adso2_cd = adso2_cd+SO2s_ADJ(i,j,l)* + &(0.5+sign(0.5d0,so2_cd-1.d-32)) + SO2s_ADJ(i,j,l) = 0.d0 + !adh2o20 = adh2o20+adh2o2s(i,j,l)*(0.5+sign(0.5d0,h2o20-1.d-32)) + !adh2o2s(i,j,l) = 0.d0 + adh2o20 = adh2o20+H2O2s_ADJ(i,j,l) + & *(0.5+sign(0.5d0,h2o20-1.d-32)) + H2O2s_ADJ(i,j,l) = 0.d0 + ! dkh debug + IF ( LPRINTFD .and. I == IFD .and. + & J == JFD .and. L == LFD ) THEN + print*, ' ADJ_CHEM_SO2: no aqchem ! ' + ENDIF + endif + if (rk .gt. 0.d0) then + adso20 = adso20+adl1*(rk1/rk) + adso2_cd = adso2_cd-adl1*(rk1/rk) + adl1 = 0.d0 + adso20 = adso20+adso2_cd*exp(-rkt) + adso2_cd = 0.d0 + + !fp + if (force) then + adso20 = adso20 + & + (1D0 - exp(-rk2*dtchem)) + & * AD(I,J,L)*FACT/GET_AREA_CM2(J) + & * GET_CF_REGION(I,J,L) + & * TR_DDEP_CONV(J,IDTSO2) + endif + else + adso20 = adso20+adso2_cd + adso2_cd = 0.d0 + !no forcing since no dry deposition (fp) + endif + + IF ( IT_IS_NAN( ADSO20 ) .or. IT_IS_NAN( ADH2O20 ) ) THEN + print*, ' CHEM_SO2_ADJ error ' + print*, ' ADSO20 = ', ADSO20 + print*, ' ADH2O20 = ', ADH2O20 + print*, ' SO2_ss = ', SO2_ss + print*, ' H2O20 = ', H2O20 + print*, ' XX = ', ( SO2_ss - H2O20 ) * KaqH2O2 * DTCHEM + print*, ' I, J, L = ', I, J, L + CALL ERROR_STOP( 'sulfate_adj_mod.f', 'chem_so2_adj') + ENDIF + + ! Update global adjoint arrays and reset local variables to zero. + ! ADJ_STT(IDADJSO2) should be zero at this point, as it will be zeroed + ! after passing off values to ADSO2s ? -- NO, they both coexist. H2O2s + ! and SO2s are just control variables. The actual running concentrations + ! are kept in STT. + STT_ADJ(I,J,L,IDTSO2) = STT_ADJ(I,J,L,IDTSO2) + ADSO20 + STT_ADJ(I,J,L,IDTH2O2) = STT_ADJ(I,J,L,IDTH2O2) + ADH2O20 + CALL GET_O3_ADJ( ADO3, I, J, L ) + + ado3 = 0.d0 + adh2o20 = 0.d0 + adso20 = 0.d0 + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE CHEM_SO2_ADJ + +!------------------------------------------------------------------------------ +! +! SUBROUTINE SEASALT_CHEM ( I, J, L, ALK1, ALK2, +! & SO2_cd, Kt1, Kt2, Kt1N, Kt2N, +! & SO2_ss, PSO4E, PSO4F ) +!! +!!****************************************************************************** +!! Function SEASALT_CHEM computes SO4 formed from S(IV) + O3 on seasalt +!! aerosols as a function of seasalt alkalinity. (bec, bmy, 4/13/05, 10/7/08) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) I (INTEGER) : +!! (2 ) J (INTEGER) : +!! (3 ) L (INTEGER) : +!! (4 ) O30 (REAL*8) : Initial O3 mixing ratio (v/v] +!! (5 ) ALK (REAL*8) : Alkalinity [kg] from seasalt from seasalt_mod +!! (6 ) SO2_cd (REAL*8) : SO2 mixing ratio [v/v] after gas phase chemistry +!! and dry deposition +!! (7 ) Kt1 (REAL*8) : Rate constant [s-1] for sulfate formation on +!! fine sea-salt aerosols from GET_ALK +!! (8 ) Kt2 (REAL*8) : Rate constant [s-1] for sulfate formation on +!! coarse sea-salt aerosols from GET_ALK +!! +!! Arguments as Output: +!! ============================================================================ +!! (9 ) SO2_ss (REAL*8) : SO2 mixing ratio [v/v] updated after SS chemistry +!! (10) SO4E (REAL*8) : SO4E (sulfate produced by S(IV)+O3 on fine seasalt) +!! mixing ratio [v/v] +!! (11) SO4F (REAL*8) : SO4F(sulfate produced by S(IV)+O3 on coarse seasalt) +!! mixing ratio [v/v] +!! (12) O3 (REAL*8) : Updated O3 mixing ratio [v/v] for fullchem runs +!! only. Otherwise O30=O3. +!! +!! Chemical reactions: +!! ============================================================================ +!! (R1) SO2 + O3 + ALK => SO4 + O2 +!! Modeled after Chamedies and Stelson, 1992? +!! +!! NOTES: +!! (1 ) Now references XNUMOLAIR from "tracer_mod.f" (bmy, 10/25/05) +!! (2 ) Bug fix: now avoid seg fault error if IDTHNO3 is zero, as it would +!! be for an offline aerosol simulation. (bmy, 3/29/06) +!! (3 ) Fixed typo in FALK_A_SO2 equation: C_FLUX_C should be C_FLUX_A. +!! (havala, bec, bmy, 12/8/06) +!! (4 ) Bug fix for mass balance, replace TITR_HNO3 w/ HNO3_SSC in the +!! expression for HNO3_ss. Bug fix: now do equivalent computation +!! for GET_GNO3, which is now no longer called because it's in +!! "isoropiaii_adj_mod.f". (bec, bmy, 7/30/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE COMODE_MOD, ONLY : CSPEC, JLOP, VOLUME +! USE DAO_MOD, ONLY : AD, AIRDEN, AIRVOL +! USE TRACERID_MOD +! !---------------------------------------------------------------- +! ! DIAGNOSTIC -- leave commented out for now (bec, bmy, 4/13/05) +! !USE DIAG_MOD, ONLY : AD09 +! !---------------------------------------------------------------- +! USE ERROR_MOD, ONLY : GEOS_CHEM_STOP +! USE TIME_MOD, ONLY : GET_TS_CHEM, GET_ELAPSED_SEC +! USE ERROR_MOD, ONLY : IT_IS_NAN +! USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, STT +! USE TRACER_MOD, ONLY : TCVV, XNUMOLAIR +! USE GLOBAL_HNO3_MOD, ONLY : GET_HNO3_UGM3 +! USE TIME_MOD, ONLY : GET_ELAPSED_SEC, GET_MONTH +! USE TIME_MOD, ONLY : ITS_A_NEW_MONTH +! USE ISOROPIAII_ADJ_MOD, ONLY : GET_GNO3 +! +! ! Add these for GET_GNO3 fix (lyj, bmy, 10/7/08) +! USE GLOBAL_HNO3_MOD, ONLY : GET_HNO3_UGM3 +! USE DAO_MOD, ONLY : AIRVOL +! +!# include "CMN_SIZE" ! Size parameters +!!--------------------------------------------------------------- +!! DIAGNOSTIC -- leave commented out for now (bec, bmy, 4/13/05) +!!# include "CMN_DIAG" ! ND19 +!!--------------------------------------------------------------- +!# include "CMN_GCTM" ! AIRMW +! +! ! Arguments +! INTEGER, INTENT(IN) :: I, J, L +! REAL*8, INTENT(IN) :: SO2_cd, Kt1, Kt2, Kt1N, Kt2N +! REAL*8, INTENT(IN) :: ALK1, ALK2 +! REAL*8, INTENT(OUT) :: SO2_ss, PSO4E, PSO4F +! +! ! Local variables +! INTEGER :: JLOOP +! REAL*8 :: SO2_chem, DTCHEM +! REAL*8 :: O3_cspec, O3_lost +! REAL*8 :: EQ_1_C, EQ_2_C +! REAL*8 :: SO4E, SO2_new, SO4F +! REAL*8 :: SO2_eq, N_FLUX_A, N_FLUX_C +! REAL*8 :: END_ALK, L5A, L5C +! REAL*8 :: EQ1, EQ2, TITR_SO2 +! REAL*8 :: TITR_HNO3, NIT_vv, NITs_vv +! REAL*8 :: NIT0, NITS0 +! REAL*8 :: F_SO2, FALK_A_SO2, FALK_C_SO2 +! REAL*8 :: EQ_BEG, F_SO2_A, F_SO2_C +! REAL*8 :: ALKA, ALKC, TOTAL_ACID_FLUX +! REAL*8 :: HNO3_EQ, TOT_FLUX_A, TOT_FLUX_C +! REAL*8 :: FALK_A_HNO3, HNO3_vv +! REAL*8 :: FALK_C_HNO3, F_HNO3_A, F_HNO3_C +! REAL*8 :: EQ_1_N, EQ_2_N, F_HNO3 +! REAL*8 :: HNO3_SSA, HNO3_SSC, N_FLUX +! REAL*8 :: HNO3_EQ_C, L6A, L6C +! REAL*8 :: C_FLUX_A, C_FLUX_C, C_FLUX +! REAL*8 :: HNO3_ss, HNO3_kg +! REAL*8, PARAMETER :: MINDAT = 1.0d-20 +! REAL*8, PARAMETER :: TCVV_HNO3 = 28.97d0 / 63.0d0 +! +! !================================================================= +! ! SEASALT_CHEM begins here! +! !================================================================= +! +! ! DTCHEM is the chemistry timestep in seconds +! DTCHEM = GET_TS_CHEM() * 60d0 +! +! ! Convert SO2 [v/v] to [eq/gridbox] +! SO2_eq = ( 2.d0 * SO2_cd * AD(I,J,L) ) / ( TCVV(IDTSO2) * 0.064d0) +! SO2_eq = MAX( SO2_eq, MINDAT ) +! +! IF ( ITS_A_FULLCHEM_SIM() ) THEN +! +! ! Convert HNO3 [v/v] to [equivalents] +! HNO3_vv = STT(I,J,L,IDTHNO3) +! HNO3_eq = HNO3_vv * AD(I,J,L) / ( 28.97d0 / 63d0 ) / 63.d-3 +! +! ELSE +! +! !-------------------------------------------------------------------- +! ! Prior to 10/7/08: +! ! Now that we have switched from ISORROPIA to RPMARES, GET_GNO3 +! ! is no longer defined. We therefore need to do the equivalent +! ! computation. NOTE: This is only an issue for the offline +! ! aerosol simulation. (lyj, bmy, 10/7/08) +! ! +! ! For more information, please see this Wiki post: +! ! http://wiki.seas.harvard.edu/geos-chem/index.php/Aerosol_thermodynamical_equilibrium#Bug_in_sulfate_mod.f_caused_by_switch_to_RPMARES +! ! +! !! Get gas-phase HNO3 from ISORROPIA code +! !CALL GET_GNO3( I, J, L, HNO3_kg ) +! !-------------------------------------------------------------------- +! +! ! Get HNO3 in ug/m3, then multiply by volume in m3 +! ! and 1e-6 kg/ug to get HNO3 in kg +! HNO3_kg = GET_HNO3_UGM3( I, J, L ) * AIRVOL(I,J,L) * 1e-6 +! +! ! Convert HNO3 [kg] first to [v/v] +! HNO3_vv = HNO3_kg * ( 28.97d0 / 63d0 ) / AD(I,J,L) +! +! ! Then convert HNO3 [kg] to [equivalents] +! HNO3_eq = HNO3_kg / 63d-3 +! +! ENDIF +! +! !----------- +! ! SO2 +! !----------- +! +! ! Available flux of SO2 to accum sea salt aerosols [v/v/timestep] +! L5A = EXP( -Kt1 * DTCHEM ) +! F_SO2_A = SO2_cd * ( 1.d0 - L5A ) +! F_SO2_A = MAX( F_SO2_A, 1.d-32 ) +! +! ! Convert to [eq/timestep] +! C_FLUX_A = 2.d0 * F_SO2_A * AD(I,J,L) / TCVV(IDTSO2) / 0.064d0 +! +! ! Available flux of SO2 to coarse sea salt aerosols [v/v/timestep] +! L5C = EXP( - Kt2 * DTCHEM ) +! F_SO2_C = SO2_cd * ( 1.d0 - L5C ) +! F_SO2_C = MAX( F_SO2_C, 1.0d-32 ) +! +! ! Convert to [eq/timestep] +! C_FLUX_C = 2.d0 * F_SO2_C * AD(I,J,L) / TCVV(IDTSO2) / 0.064d0 +! +! ! Total flux of SO2 [v/v/timestep] +! F_SO2 = F_SO2_A + F_SO2_C +! +! ! Total flux of SO2 [eq/timestep] +! C_FLUX = C_FLUX_A + C_FLUX_C +! +! !----------- +! ! HNO3 +! !----------- +! +! ! Available flux of HNO3 to accum sea salt aerosols [v/v/timestep] +! L6A = EXP( - Kt1N * DTCHEM ) +! F_HNO3_A = HNO3_vv * ( 1.D0 - L6A ) +! F_HNO3_A = MAX( F_HNO3_A, 1.0D-32 ) +! +! ! Convert to [eq/timestep] +! N_FLUX_A = F_HNO3_A * AD(I,J,L)/( 28.97d0 / 63d0 )/0.063d0 +! +! ! Available flux of HNO3 to coarse sea salt aerosols [v/v/timestep] +! L6C = EXP( - Kt2N * DTCHEM ) +! F_HNO3_C = HNO3_vv * ( 1.D0 - L6C ) +! F_HNO3_C = MAX( F_HNO3_C, 1.0D-32 ) +! +! ! convert to [eq/timestep] +! N_FLUX_C = F_HNO3_C * AD(I,J,L)/( 28.97d0 / 63d0 )/0.063d0 +! +! ! Total flux of HNO3 +! F_HNO3 = F_HNO3_A + F_HNO3_C ![v/v/timestep] +! N_FLUX = N_FLUX_A + N_FLUX_C ![eq/timestep] +! +! !----------- +! ! Acid +! !----------- +! +! ! Total acid flux to accum sea-salt aerosols [eq/box/timestep] +! TOT_FLUX_A = C_FLUX_A + N_FLUX_A +! TOT_FLUX_A = MAX( TOT_FLUX_A, MINDAT ) +! +! ! Total acid flux to coarse sea-salt aerosols [eq/box/timestep] +! TOT_FLUX_C = C_FLUX_C + N_FLUX_C +! TOT_FLUX_C = MAX( TOT_FLUX_C, MINDAT ) +! +! ! Total acid flux to sea salt aerosols +! TOTAL_ACID_FLUX = TOT_FLUX_A + TOT_FLUX_C +! +! ! Total available alkalinity [eq] +! EQ1 = ALK1 * 0.07d0 +! EQ2 = ALK2 * 0.07d0 +! +! !---------------------------------------------------------------------- +! ! NOTE: This was a sensitivity simulation, keep for future reference +! ! cf Alexander et al 2005 (bec, bmy, 4/13/05) +! !! Total available alkalinity [eq] doubled for Sievering run +! !EQ1 = ALK1 * 0.14d0 +! !EQ2 = ALK2 * 0.14d0 +! !---------------------------------------------------------------------- +! +! !---------------------------------------------------------------------- +! ! DIAGNOSTIC -- leave uncommented for now (bec, bmy, 4/13/05) +! !! Write out beginning alkalinity [eq SO4] +! !EQ_BEG = EQ1 + EQ2 +! !IF ( ND09 > 0 ) AD09(I,J,L,1) = AD09(I,J,L,1) + EQ_BEG +! !---------------------------------------------------------------------- +! +! IF ( TOT_FLUX_A > EQ1 ) THEN +! +! ! Fraction of alkalinity available for each acid +! FALK_A_SO2 = C_FLUX_A / TOT_FLUX_A +! FALK_A_HNO3 = N_FLUX_A / TOT_FLUX_A +! FALK_A_SO2 = MAX( FALK_A_SO2, MINDAT ) +! FALK_A_HNO3 = MAX( FALK_A_HNO3, MINDAT ) +! +! ELSE +! +! FALK_A_SO2 = 1.0d0 +! FALK_A_HNO3 = 1.0d0 +! +! ENDIF +! +! IF ( TOT_FLUX_C > EQ2 ) THEN +! +! ! Fraction of flkalinity available for each acid +! FALK_C_SO2 = C_FLUX_C/TOT_FLUX_C +! FALK_C_HNO3 = N_FLUX_C/TOT_FLUX_C +! FALK_C_SO2 = MAX( FALK_C_SO2, MINDAT ) +! FALK_C_HNO3 = MAX( FALK_C_HNO3, MINDAT ) +! +! ELSE +! +! FALK_C_SO2 = 1.0d0 +! FALK_C_HNO3 = 1.0d0 +! +! ENDIF +! +! ! Alkalinity available for S(IV) --> S(VI) +! EQ_1_C = EQ1 * FALK_A_SO2 +! EQ_1_C = MAX( EQ_1_C, MINDAT ) +! EQ_1_N = EQ1 * FALK_A_HNO3 +! EQ_1_N = MAX( EQ_1_N, MINDAT ) +! +! EQ_2_C = EQ2 * FALK_C_SO2 +! EQ_2_C = MAX( EQ_2_C, MINDAT ) +! EQ_2_N = EQ2 * FALK_C_HNO3 +! EQ_2_N = MAX( EQ_2_N, MINDAT ) +! +! !----------------- +! ! Fine Seasalt +! !----------------- +! +! ! don't produce more SO4 than available ALK or SO2 +! SO4E = MIN( C_FLUX_A, EQ_1_C, SO2_eq ) +! SO4E = MAX( SO4E, MINDAT ) +! +! ! Update SO2 concentration [eq/box] +! SO2_new = SO2_eq - SO4E +! SO2_new = MAX( SO2_new, MINDAT ) +! +! !----------------- +! ! Coarse Seasalt +! !----------------- +! IF ( SO2_new > MINDAT ) THEN +! +! ! don't produce more SO4 than available ALK or SO2 +! SO4F = MIN( C_FLUX_C, SO2_new, EQ_2_C ) +! SO4F = MAX( SO4F, MINDAT ) +! +! !Update SO2 concentration [eq] +! SO2_chem = SO2_new - SO4F +! SO2_chem = MAX( SO2_chem, MINDAT ) +! ELSE +! SO4F = MINDAT +! SO2_chem = MINDAT +! ENDIF +! +! ! Alkalinity titrated by S(IV) --> S(VI) [eq] +! TITR_SO2 = SO4E + SO4F +! +! !------------------------------------------------------------------- +! ! DIAGNOSTIC -- leave uncommented for now +! !! write out in diagnostic +! !IF ( ND09 > 0 ) AD09(I,J,L,2) = AD09(I,J,L,2) + TITR_SO2 +! !------------------------------------------------------------------- +! +! !Modified SO2 [eq] converted back to [v/v] +! SO2_ss = SO2_chem * 0.064 * TCVV(IDTSO2)/AD(I,J,L)/2.0d0 +! SO2_ss = MAX( SO2_ss, MINDAT ) +! +! !SO4E produced converted from [eq/timestep] to [v/v/timestep] +! PSO4E = SO4E * 0.096 * TCVV(IDTSO4)/AD(I,J,L)/2.0d0 +! +! !SO4F produced converted from [eq/timestep] to [v/v/timestep] +! PSO4F = SO4F * 0.096 * TCVV(IDTSO4S)/AD(I,J,L)/2.0d0 +! +! ! Alkalinity titrated by HNO3 +! HNO3_SSA = MIN(N_FLUX_A, HNO3_EQ, EQ_1_N) +! HNO3_SSA = MAX(HNO3_SSA, MINDAT) +! HNO3_EQ_C = HNO3_EQ - HNO3_SSA +! HNO3_EQ_C = MAX(HNO3_EQ_C, MINDAT) +! HNO3_SSC = MIN(N_FLUX_C, HNO3_EQ_C, EQ_2_N) +! HNO3_SSC = MAX(HNO3_SSC, MINDAT) +! TITR_HNO3 = HNO3_SSA + HNO3_SSC +! +! !---------------------------------------------------------------------- +! ! DIAGNOSTIC -- leave commented out for now +! ! !write out alkalinity titrated by HNO3(g) +! !IF ( ND09 > 0 ) AD09(I,J,L,3) = AD09(I,J,L,3) + TITR_HNO3 +! !---------------------------------------------------------------------- +! +! ! HNO3 lost [eq/timestep] converted back to [v/v/timestep] +! IF ( IDTHNO3 > 0 ) THEN +! +! ! Coupled sim: IDTHNO3 is defined, so use it +! HNO3_ss = HNO3_SSC * 0.063 * TCVV(IDTHNO3)/AD(I,J,L) +! STT(I,J,L,IDTHNO3) = MAX( HNO3_vv - HNO3_ss, MINDAT ) +! +! ELSE +! +! ! Offline aerosol sim: IDTHNO3 isn't defined, use TCVV_HNO3 +! HNO3_ss = TITR_HNO3 * 0.063 * TCVV_HNO3 / AD(I,J,L) +! +! ENDIF +! +! ! NITS produced converted from [eq/timestep] to [v/v/timestep] +! PNITs(I,J,L) = HNO3_SSC * 0.063 * TCVV(IDTNITS)/AD(I,J,L) +! +! ! Modified accum alkalinity +! ALKA = EQ1 - (SO4E + HNO3_SSA) +! ALKA = MAX( ALKA, MINDAT ) +! +! !------------------------------------------------------------------------ +! ! Uncomment this if you want to transport alkalinity (bec, bmy, 4/13/05) +! ![eq] --> [kg] --> [v/v] use this only if transporting alkalinity +! !ALKAvv = (ALKA * TCVV(IDTSAL1))/(7.0d-2 * AD(I,J,L)) +! !ALKAvv = MAX( ALKAvv, MINDAT ) +! !------------------------------------------------------------------------ +! +! ! Modified accum alkalinity +! ALKC = EQ2 - (SO4F + HNO3_SSC) +! ALKC = MAX( ALKC, MINDAT ) +! +! !------------------------------------------------------------------------ +! ! Uncomment this if you want to transport alkalinity (bec, bmy, 4/13/05) +! !! [eq] --> [kg] --> [v/v] use this only if transporting alkalinity +! !ALKCvv = (ALKC * TCVV(IDTSAL2))/(7.0d-2 * AD(I,J,L)) +! !ALKCvv = MAX(ALKCvv, MINDAT) +! !------------------------------------------------------------------------ +! +! !------------------------------------------------------------------------ +! ! DIAGNOSTIC -- leave commented out for now (bec, bmy, 4/13/05) +! !! write out ending alkalinity +! !END_ALK = ALKA + ALKC +! !IF ( ND09 > 0 ) AD09(I,J,L,4) = AD09(I,J,L,4) + END_ALK +! !------------------------------------------------------------------------ +! +! ! Return to calling program +! END SUBROUTINE SEASALT_CHEM +! +!!------------------------------------------------------------------------------ + + SUBROUTINE AQCHEM_SO2( LWC, T, P, SO2, H2O2, + & O3, Hplus, KaqH2O2, KaqO3 ) +! +!****************************************************************************** +! Function AQCHEM_SO2 computes the reaction rates for aqueous SO2 chemistry. +! (rjp, bmy, 10/31/02, 12/12/02) +! +! Arguments as Input: +! ============================================================================ +! (1 ) LWC (REAL*8) : Liquid water content [m3/m3] = 1.E-6*L [g/m3] +! (2 ) T (REAL*8) : Temperature [K] +! (3 ) P (REAL*8) : Pressure [atm] +! (4 ) SO2 (REAL*8) : SO2 mixing ratio [v/v] +! (5 ) H2O2 (REAL*8) : H2O2 mixing ratio [v/v] +! (6 ) O3 (REAL*8) : O3 mixing ratio [v/v] +! (7 ) HPLUS (REAL*8) : Concentration of H+ ion (i.e. the pH) [v/v] +! +! Arguments as Output: +! ============================================================================ +! (8 ) KaqH2O2 (REAL*8) : Reaction rate for H2O2 +! (9 ) KaqO3 (REAL*8) : Reaction rate for O3 +! +! Chemical Reactions: +! ============================================================================ +! (R1) HSO3- + H2O2(aq) + H+ => SO4-- + 2H+ + H2O [Jacob, 1986] +! +! d[S(VI)]/dt = k[H+][H2O2(aq)][HSO3-]/(1 + K[H+]) +! [Seinfeld and Pandis, 1998, page 366] +! +! (R2) SO2(aq) + O3(aq) => +! HSO3- + O3(aq) => +! SO3-- + O3(aq) => +! [Jacob, 1986; Jacobson, 1999] +! +! d[S(VI)]/dt = (k0[SO2(aq)] + k1[HSO3-] + K2[SO3--])[O3(aq)] +! [Seinfeld and Pandis, 1998, page 363] +! +! Reaction rates can be given as +! Ra = k [H2O2(ag)] [S(IV)] [mole/liter*s] OR +! Krate = Ra LWC R T / P [1/s] +! +! Where: +! LWC = Liquid water content(g/m3)*10-6 [m3(water)/m3(gas)] +! R = 0.08205 (atm L / mol-K), Universal gas const. +! T = Temperature (K) +! P = Pressure (atm) +! +! Procedure: +! ============================================================================ +! (a ) Given [SO2] which is assumed to be total SO2 (gas+liquid) in +! equilibrium between gas and liquid phase. +! +! (b ) We can compute SO2(g) using Henry's law +! P(so2(g)) = Xg * [SO2] +! Xg = 1/(1 + Faq), Fraction of SO2 in gas +! where: +! Faq = Kheff * R * T * LWC, +! KHeff = Effective Henry's constant +! +! (c ) Then Calculate Aquous phase, S[IV] concentrations +! S[IV] = Kheff * P(so2(g) in atm) [M] +! +! (d ) The exact same procedure is applied to calculate H2O2(aq) +! +! NOTES: +! (1 ) Updated by Rokjin Park (rjp, bmy, 12/12/02) +!****************************************************************************** +! + ! Arguments + REAL*8, INTENT(IN) :: LWC, T, P, SO2, H2O2, O3, HPLUS + REAL*8, INTENT(OUT) :: KaqH2O2, KaqO3 + + ! Local variables + REAL*8, PARAMETER :: R = 0.08205d0 + REAL*8 :: KH2O2, RA, KS1, KS2, HCSO2 + REAL*8 :: FHCSO2, XSO2G, SIV, HSO3, XSO2AQ + REAL*8 :: XHSO3, XSO3, KH1, HCH2O2, FHCH2O2 + REAL*8 :: XH2O2G, H2O2aq, KO0, KO1, KO2 + REAL*8 :: HCO3, XO3g, O3aq + + !================================================================= + ! AQCHEM_SO2 begins here! + ! + ! Aqueous reaction rate + ! HSO3- + H2O2 + H+ => SO4-- + 2H+ + H2O [Jacob, 1986] + !================================================================= + + ! [Jacob, 1986] + KH2O2 = 6.31d14 * EXP( -4.76d3 / T ) + +! ! [Jacobson, 1999] +! KH2O2 = 7.45d07 * EXP( -15.96d0 * ( (298.15/T) - 1.) ) / +! & ( 1.d0 + 13.d0 * Hplus) + + !================================================================= + ! Equilibrium reaction of SO2-H2O + ! SO2 + H2O = SO2(aq) (s0) + ! SO2(ag) = HSO3- + H+ (s1) + ! HSO3- = SO3-- + H+ (s2) + ! + ! Reaction constant for Aqueous chemistry -- No big difference + ! between Jacob and Jacobson, choose one of them. + ! + ! Reaction rate dependent on Temperature is given + ! H = A exp ( B (T./T - 1) ) + ! + ! For equilibrium reactions of SO2: + ! As1 Bs1 As2 Bs2 + ! Seinfeld 1.30d-2 7.02 6.60d-8 3.76 [1998] + ! Jacob 1.30d-2 6.75 6.31d-8 5.05 [1986] + ! Jacobson 1.71d-2 7.04 5.99d-8 3.74 [1996] + !================================================================= + Ks1 = 1.30d-2 * EXP( 6.75d0 * ( 298.15d0 / T - 1.d0 ) ) + Ks2 = 6.31d-8 * EXP( 5.05d0 * ( 298.15d0 / T - 1.d0 ) ) + + ! SIV Fraction + XSO2aq = 1.d0/(1.d0 + Ks1/Hplus + Ks1*Ks2/(Hplus*Hplus)) + XHSO3 = 1.d0/(1.d0 + Hplus/Ks1 + Ks2/Hplus) + XSO3 = 1.d0/(1.d0 + Hplus/Ks2 + Hplus*Hplus/(Ks1*Ks2)) + + ! Henry's constant [mol/l-atm] and Effective Henry's constant for SO2 + HCSO2 = 1.22d0 * EXP( 10.55d0 * ( 298.15d0 / T - 1.d0) ) + FHCSO2 = HCSO2 * (1.d0 + (Ks1/Hplus) + (Ks1*Ks2 / (Hplus*Hplus))) + + XSO2g = 1.d0 / ( 1.d0 + ( FHCSO2 * R * T * LWC ) ) + SIV = FHCSO2 * XSO2g * SO2 * P +! HSO3 = Ks1 * HCSO2 * XSO2g * SO2 * P + + !================================================================= + ! H2O2 equilibrium reaction + ! H2O2 + H2O = H2O2.H2O + ! H2O2.H2O = HO2- + H+ 1) + ! + ! Reaction rate dependent on Temperature is given + ! H = A exp ( B (T./T - 1) ) + ! + ! For equilibrium reactions of SO2 + ! Ah1 Bh1 + ! Jacob 1.58E-12 -12.49 [1986] + ! Jacobson 2.20E-12 -12.52 [1996] + !================================================================= + Kh1 = 2.20d-12 * EXP( -12.52d0 * ( 298.15d0 / T - 1.d0 ) ) + + ! Henry's constant [mol/l-atm] and Effective Henry's constant for H2O2 + ! [Seinfeld and Pandis, 1998] + ! HCH2O2 = 7.45D4 * EXP( 24.48d0 * ( 298.15d0 / T - 1.d0) ) + + ! [Jacobson,1999] + HCH2O2 = 7.45D4 * EXP( 22.21d0 * (298.15d0 / T - 1.d0) ) + FHCH2O2 = HCH2O2 * (1.d0 + (Kh1 / Hplus)) + + XH2O2g = 1.d0 / ( 1.d0 + ( FHCH2O2 * R * T * LWC ) ) +! H2O2aq = FHCH2O2 * XH2O2g * H2O2 * P + + ! Conversion rate from SO2 to SO4 via reaction with H2O2 + KaqH2O2 = kh2o2 * Ks1 * FHCH2O2 * HCSO2 * XH2O2g * XSO2g + & * P * LWC * R * T ! [v/v/s] + + !================================================================= + ! Aqueous reactions of SO2 with O3 + ! SO2(aq) + O3 => (0) + ! HSO3- + O3 => SO4-- + H+ + O2 (1) + ! SO3-- + O3 => SO4-- + O2 (2) + ! + ! NOTE + ! [Jacob, 1986] + ! KO1 = 3.49E12 * EXP( -4.83E3 / T ) + ! KO2 = 7.32E14 * EXP( -4.03E3 / T ) + ! + ! [Jacobson, 1999] + ! KO0 = 2.40E+4 + ! KO1 = 3.70E+5 * EXP( -18.56 * ((298.15/T) - 1.)) + ! KO2 = 1.50E+9 * EXP( -17.72 * ((298.15/T) - 1.)) + ! + ! Rate constants from Jacobson is larger than those of Jacob + ! and results in faster conversion from S(IV) to S(VI) + ! We choose Jacob 1) 2) and Jacobson 0) here + !================================================================= + KO0 = 2.40d+4 + KO1 = 3.49d12 * EXP( -4.83d3 / T ) + KO2 = 7.32d14 * EXP( -4.03d3 / T ) + + !================================================================= + ! H2O2 equilibrium reaction + ! O3 + H2O = O3.H2O + ! HCO3 = 1.13E-2 * EXP( 8.51 * (298.15/T -1.) ), S & P + ! HCO3 = 1.13E-2 * EXP( 7.72 * (298.15/T -1.) ), Jacobson + !================================================================= + + ! Calculate Henry's Law constant for atmospheric temperature + HCO3 = 1.13d-2 * EXP( 8.51d0 * ( 298.15d0 / T - 1.d0 ) ) + + XO3g = 1.d0 / ( 1.d0 + ( HCO3 * R * T * LWC ) ) +! O3aq = HCO3 * XO3g * O3 * P + + ! Conversion rate from SO2 to SO4 via reaction with O3 + KaqO3 = (KO0*XSO2AQ + KO1*XHSO3 + KO2*XSO3) * FHCSO2 * XSO2g + & * P * HCO3 * XO3g * LWC * R * T ! [v/v/s] + + ! Return to calling program + END SUBROUTINE AQCHEM_SO2 + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_SO4_ADJ +! +!****************************************************************************** +! Subroutine CHEM_SO4_ADJ is the adjoint SO4 chemistry subroutine for the +! fwd routine CHEM_SO4. (dkh, 10/13/05) +! +! * Does not yet include seasalt sulfate * +! +! See original routine for notes. (rjp, bdf, cas, bmy, 5/31/00, 5/23/06) +! +! Module Variables Used: +! ============================================================================ +! (1 ) ADPSO4_SO2 (REAL*8 ) : Array for adjoint of P(SO4) from SO2 +! +! Reaction List (by Mian Chin, chin@rondo.gsfc.nasa.gov) +! ============================================================================ +! The Only production is from SO2 oxidation (save in CHEM_SO2), and the only +! loss is dry depsition here. Wet deposition will be treated in "wetdep.f". +! +! SO4 = SO4_0 * exp(-kt) + PSO4_SO2/kt * (1.-exp(-kt)) +! where k = dry deposition. +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE DAO_MOD, ONLY : AD + USE DIAG_MOD, ONLY : AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LCRYST, LSSALT + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : STT, TCVV, XNUMOL + USE TRACERID_MOD, ONLY : IDTSO4, IDTSO4s, IDTAS, IDTAHS + USE TRACERID_MOD, ONLY : IDTLET, IDTSO4aq, IDTNH4aq + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT +!fp + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS, LADJ_DDEP_TRACER + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION, ADJOINT_AREA_M2 + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER, DEP_UNIT + USE ADJ_ARRAYS_MOD, ONLY : NSPAN, TR_DDEP_CONV + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND44 + + ! Local variables + INTEGER :: I, J, L, N, N_ND44 + REAL*8 :: AS, AS0, AHS, AHS0, LET + REAL*8 :: LET0, SO4, SO40, SO4aq, SO4aq0 + REAL*8 :: SO4s, SO40s, RKT, RKTs, E_RKT + REAL*8 :: E_RKTs, DTCHEM, AREA_CM2, FLUX + REAL*8 :: ADJ_SO4, ADJ_SO40 + + REAL*8, SAVE :: NTSCHEM + REAL*8, SAVE :: FACT + LOGICAL :: FORCE + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER, SAVE :: OBS_COUNT = 0 + !================================================================= + ! CHEM_SO4_ADJ begins here! + !================================================================= + + ! Return if tracers are not defined + IF ( IDTSO4 == 0 .or. IDTSO4s == 0 ) RETURN + IF ( DRYSO4 == 0 .or. DRYSO4s == 0 ) RETURN + !for dry dep forcing (fp) + ! Determine if it is time to apply deposition forcing + FORCE = .FALSE. + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + 1 + IF ( OBS_COUNT <= NSPAN + & .and. LADJ_DDEP_TRACER + & .and. OBS_THIS_TRACER(IDTSO4) ) THEN + FORCE = .TRUE. + WRITE(6,100) , 'SO4' , TRIM( DEP_UNIT ) + ENDIF + ELSEIF ( LADJ_DDEP_TRACER .and. OBS_THIS_TRACER(IDTSO4) ) THEN + FORCE = .TRUE. + WRITE(6,100) , 'SO4' , TRIM( DEP_UNIT ) + ENDIF + 100 FORMAT('Forcing ',a,' drydep (', a,')') + + ! DTCHEM is the chemistry timestep in seconds + DTCHEM = GET_TS_CHEM() * 60d0 + ! initialize some constants for depostion forcing + IF ( FORCE .and. FIRST ) THEN + + ! here we aren't assuming that TS_CHEM is necessarily 1 hr + NTSCHEM = NSPAN / ( GET_TS_CHEM() / 60D0 ) + + !default is molec/cm2/s + FACT = XNUMOL(IDTSO4) / DTCHEM + & / TCVV(IDTSO4) / NTSCHEM + + FIRST = .FALSE. + ENDIF + + ! Loop over tropospheric grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, AREA_CM2, RKT, RKTs, E_RKT ) +!$OMP+PRIVATE( E_RKTs, FLUX, SO4, SO4s, SO40, SO40s ) +!$OMP+PRIVATE( ADJ_SO40, ADJ_SO4 ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, LLTROP + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Initialize for safety's sake + AREA_CM2 = 0d0 + RKT = 0d0 + RKTs = 0d0 + E_RKT = 0d0 + E_RKTs = 0d0 + FLUX = 0d0 + SO4 = 0d0 + SO4s = 0d0 + + + ! Skip stratospheric boxes + IF ( ITS_IN_THE_STRAT( I, J, L ) ) CYCLE + + !============================================================== + ! Initial concentrations before chemistry + !============================================================== + + ! Initial ADJ_SO4 + ADJ_SO4 = STT_ADJ(I,J,L,IDTSO4) + + ! SO4 drydep frequency [1/s]. Also accounts for the fraction + ! of each vertical level that is located below the PBL top + RKT = DEPSAV(I,J,DRYSO4) * GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! RKT > 0 denotes that we have SO4 drydep occurring + IF ( RKT > 0d0 ) THEN + + !----------------------------------------------------------- + ! CASE 1: SO4 production from SO2 and SO4 loss by drydep + !----------------------------------------------------------- + + ! Fraction of SO4 lost to drydep [unitless] + RKT = RKT * DTCHEM + + ! Pre-compute exponential term for use below + E_RKT = EXP( -RKT ) + + ! Adjoint of SO4 change due to deposition + ADJ_SO40 = ADJ_SO4 * E_RKT + + ! Adjoint of SO4 change due to SO2 production + ADPSO4_SO2(I,J,L) = + & ADJ_SO4 / RKT * ( 1.d0 - E_RKT ) + + !add forcings (fp) + IF ( FORCE ) THEN + + ADJ_SO40 = ADJ_SO40 + & + ( 1d0 - E_RKT ) + & * AD(I,J,L) * FACT / GET_AREA_CM2(J) + & * GET_CF_REGION(I,J,L) + & * TR_DDEP_CONV(J,IDTSO4) + + ADPSO4_SO2(I,J,L) = ADPSO4_SO2(I,J,L) + & + ( 1D0 - ( 1D0 - E_RKT ) / RKT ) + & * AD(I,J,L) * FACT / GET_AREA_CM2(J) + & * GET_CF_REGION(I,J,L) + & * TR_DDEP_CONV(J,IDTSO4) + + ENDIF + ELSE + + !----------------------------------------------------------- + ! CASE 2: Production of SO4 from SO2; no SO4 drydep loss + !----------------------------------------------------------- + + ! Adjoint of SO4 change due to SO2 production + ADJ_SO40 = ADJ_SO4 + ADPSO4_SO2(I,J,L) = ADJ_SO4 + + !no dry deposition so no forcing for wet dep sensitivity + ENDIF + + ! Update global array + STT_ADJ(I,J,L,IDTSO4) = ADJ_SO40 + + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE CHEM_SO4_ADJ + +!!------------------------------------------------------------------------------ +! +! !SUBROUTINE PHASE_SO4 +! ! +! ! *** Currently under development *** +! ! +! !END SUBROUTINE PHASE_SO4 +! +!!------------------------------------------------------------------------------ +! +! !SUBROUTINE PHASE_RADIATIVE +! ! +! ! *** Currently under development *** +! ! +! !END SUBROUTINE PHASE_RADIATIVE +! +!!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_MSA_ADJ +! +!****************************************************************************** +! Subroutine ADJ_CHEM_MSA is the adjoint MSA chemistry subroutine for the +! fwd routine CHEM_MSA. See original routine for notes. (dkh, 10/13/05) +! +! See original routine (rjp, bdf, bmy, 5/31/00, 10/25/05) for notes. +! +! Reaction List (by Mian Chin, chin@rondo.gsfc.nasa.gov) +! ============================================================================ +! +! MSA = MSA_0 * exp(-kt) +! where k = dry deposition. +! +! NOTES: +! (1 ) Updated to GCv8 adjoint (dkh, 09/28/09) +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE DAO_MOD, ONLY : AD + USE DIAG_MOD, ONLY : AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP, GET_PBL_MAX_L + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : STT, TCVV, XNUMOL + USE TRACERID_MOD, ONLY : IDTMSA + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! AIRMW +# include "CMN_DIAG" ! ND44 + + ! Local variables + INTEGER :: I, J, L, PBL_MAX + REAL*8 :: DTCHEM, MSA0, MSA, RK + REAL*8 :: RKT, FLUX, AREA_CM2, F_UNDER_TOP + REAL*8 :: ADJ_MSA, ADJ_MSA0 + + !================================================================= + ! CHEM_MSA_ADJ begins here! + !================================================================= + IF ( IDTMSA == 0 .or. DRYMSA == 0 ) RETURN + + ! DTCHEM is the chemistry interval in seconds + DTCHEM = GET_TS_CHEM() * 60d0 + + ! Model level where maximum PBL height occurs + PBL_MAX = GET_PBL_MAX_L() + + ! Loop over tropospheric grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, F_UNDER_TOP, MSA0, RKT, MSA, AREA_CM2, FLUX ) +!$OMP+PRIVATE( ADJ_MSA0, ADJ_MSA ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, PBL_MAX + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Initialize for safety's sake + RKT = 0d0 + + ! Fraction of box (I,J,L) underneath the PBL top [unitless] + F_UNDER_TOP = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! Initial ADJ_MSA + ADJ_MSA = STT_ADJ(I,J,L,IDTMSA) + + ! Only apply drydep loss to boxes w/in the PBL + IF ( F_UNDER_TOP > 0 ) THEN + + ! MSA drydep frequency [1/s]. Also accounts for the fraction + ! of each grid box (I,J,L) that is located beneath the PBL top + RKT = DEPSAV(I,J,DRYMSA) * F_UNDER_TOP + + ! RKT > 0 denotes that we have drydep occurring + IF ( RKT > 0.d0 ) THEN + + ! Fraction of MSA lost to drydep [unitless] + RKT = RKT * DTCHEM + + ! Adjoint of MSA change due to deposition + ADJ_MSA0 = ADJ_MSA * EXP( -RKT ) + + ELSE + + ADJ_MSA0 = ADJ_MSA + + ENDIF + + ! Update global array + STT_ADJ(I,J,L,IDTMSA) = ADJ_MSA0 + + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE CHEM_MSA_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_NH3_ADJ +! +!****************************************************************************** +! Subroutine ADJ_CHEM_NH3 is the adjoint NH3 chemistry subroutine for the +! fwd routine CHEM_NH3. (dkh, 10/13/05) +! +! See originat routine (rjp, bdf, bmy, 1/2/02, 10/25/05) for notes. +! +! Reaction List (by Mian Chin, chin@rondo.gsfc.nasa.gov) +! ============================================================================ +! +! NH3 = NH3_0 * exp(-kt) +! where k = dry deposition. +! +! NOTES: +! (1 ) Updated to GCv8 adjoint (dkh, 09/28/09) +! (2 ) Now support deposition cost function (fp, dkh, 03/04/13) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE DAO_MOD, ONLY : AD + USE DIAG_MOD, ONLY : AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP, GET_PBL_MAX_L + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : STT, TCVV, XNUMOL + USE TRACERID_MOD, ONLY : IDTNH3 + + USE LOGICAL_ADJ_MOD, ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION, ADJOINT_AREA_M2 + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER, DEP_UNIT + USE ADJ_ARRAYS_MOD, ONLY : TR_DDEP_CONV + + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, PBL_MAX + REAL*8 :: DTCHEM, NH30, NH3 + REAL*8 :: FREQ, AREA_CM2, FLUX, F_UNDER_TOP + REAL*8 :: ADJ_NH3, ADJ_NH30 + + REAL*8, SAVE :: NTSCHEM + REAL*8, SAVE :: FACT + LOGICAL :: FORCE + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER, SAVE :: OBS_COUNT = 0 + + + !================================================================= + ! CHEM_NH3_ADJ begins here! + !================================================================= + IF ( IDTNH3 == 0 .or. DRYNH3 == 0 ) RETURN + + ! DTCHEM is the chemistry interval in seconds + DTCHEM = GET_TS_CHEM() * 60d0 + + ! Model level where maximum PBL height occurs + PBL_MAX = GET_PBL_MAX_L() + + ! Determine if it is time to apply deposition forcing + FORCE = .FALSE. + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + 1 + IF ( OBS_COUNT <= NSPAN + & .and. LADJ_DDEP_TRACER + & .and. OBS_THIS_TRACER(IDTNH3) ) THEN + FORCE = .TRUE. + WRITE(6,100) , 'NH3' , TRIM( DEP_UNIT ) + ENDIF + + ELSEIF ( LADJ_DDEP_TRACER .and. OBS_THIS_TRACER(IDTNH3) ) THEN + FORCE = .TRUE. + WRITE(6,100) , 'NH3' , TRIM( DEP_UNIT ) + ENDIF + + 100 FORMAT('Forcing ',a,' drydep (', a,')') + + ! initialize some constants for depostion forcing + IF ( FORCE .and. FIRST ) THEN + + ! here we aren't assuming that TS_CHEM is necessarily 1 hr + NTSCHEM = NSPAN / ( GET_TS_CHEM() / 60D0 ) + + !default is molec/cm2/s + FACT = XNUMOL(IDTNH3) / DTCHEM + & / TCVV(IDTNH3) / NTSCHEM +! FACT = 1d0 / DTCHEM +! & / 1d0 / NTSCHEM + + FIRST = .FALSE. + + ENDIF + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, F_UNDER_TOP, FREQ, NH30, NH3, AREA_CM2, FLUX ) +!$OMP+PRIVATE( ADJ_NH30, ADJ_NH3 ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, PBL_MAX + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Fraction of box (I,J,L) underneath the PBL top [unitless] + F_UNDER_TOP = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! Only apply drydep to boxes w/in the PBL + IF ( F_UNDER_TOP > 0d0 ) THEN + + ! NH3 drydep frequency [1/s]. Also accounts for the fraction + ! of each grid box (I,J,L) that is located beneath the PBL top + FREQ = DEPSAV(I,J,DRYNH3) * F_UNDER_TOP + + ! Only compute drydep loss if FREQ is nonzero + IF ( FREQ > 0d0 ) THEN + + ! Initial ADJ_NH3 + ADJ_NH3 = STT_ADJ(I,J,L,IDTNH3) + + ADJ_NH30 = ADJ_NH3 * EXP( -FREQ * DTCHEM ) + + STT_ADJ(I,J,L,IDTNH3) = ADJ_NH30 + + IF ( FORCE ) THEN + + ! note: the forcing corresponds to this cost function: + ! COST_FUNC = SUM ( STT * ( 1 - EXP( - FREQ * DTCHEM) ) + ! * AD(I,J,L) * FACT / GET_AREA_CM2(J) + ! the forcing is thus: + STT_ADJ(I,J,L,IDTNH3) = STT_ADJ(I,J,L,IDTNH3) + & + ( 1d0 - EXP( - FREQ * DTCHEM ) ) + & * AD(I,J,L) * FACT / GET_AREA_CM2(J) + & * GET_CF_REGION(I,J,L) + & * TR_DDEP_CONV(J,IDTNH3) + + ENDIF + + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ! Return to calling program + END SUBROUTINE CHEM_NH3_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_NH4_ADJ +! +!****************************************************************************** +! Subroutine CHEM_NH4_ADJ is the adjoint NH4 chemistry subroutine for the +! fwd routine CHEM_NH4. (dkh, 10/13/05) +! +! See original (rjp, bdf, bmy, 1/2/02, 10/25/05) for notes. +! +! Reaction List (by Mian Chin, chin@rondo.gsfc.nasa.gov) +! ============================================================================ +! +! NH4 = NH4_0 * exp(-kt) +! where k = dry deposition. +! +! NOTES: +! (1 ) Updated to GCv8 adjoint +! (2 ) Now support deposition cost function (fp, dkh, 03/04/13) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION, ADJOINT_AREA_M2 + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER, DEP_UNIT + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE DAO_MOD, ONLY : AD + USE DIAG_MOD, ONLY : AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_ADJ_MOD,ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD,ONLY : LMAX_OBS + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP, GET_PBL_MAX_L + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : STT, TCVV, XNUMOL + USE TRACERID_MOD, ONLY : IDTNH4 + USE ADJ_ARRAYS_MOD, ONLY : TR_DDEP_CONV + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, PBL_MAX + REAL*8 :: DTCHEM, NH4, NH40 + REAL*8 :: FREQ, FLUX, AREA_CM2, F_UNDER_TOP + REAL*8 :: ADJ_NH4, ADJ_NH40 + + REAL*8, SAVE :: FACT + REAL*8, SAVE :: NTSCHEM + INTEGER, SAVE :: OBS_COUNT = 0 + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: FORCE + + !================================================================= + ! CHEM_NH4_ADJ begins here! + !================================================================= + IF ( IDTNH4 == 0 .or. DRYNH4 == 0 ) RETURN + + ! DTCHEM is the chemistry interval in seconds + DTCHEM = GET_TS_CHEM() * 60d0 + + ! Model level where maximum PBL height occurs + PBL_MAX = GET_PBL_MAX_L() + + FORCE = .FALSE. + + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + 1 + IF ( OBS_COUNT <= NSPAN + & .and. LADJ_DDEP_TRACER + & .and. OBS_THIS_TRACER(IDTNH4) ) THEN + FORCE = .TRUE. + WRITE(6,100) , 'NH4' , TRIM( DEP_UNIT ) + ENDIF + ELSEIF ( LADJ_DDEP_TRACER .and. OBS_THIS_TRACER(IDTNH4) ) THEN + FORCE = .TRUE. + WRITE(6,100) , 'NH4' , TRIM( DEP_UNIT ) + ENDIF + 100 FORMAT('Forcing ',a,' drydep (', a,')') + + IF ( FORCE .and. FIRST ) THEN + + ! here we aren't assuming that TS_CHEM is necessarily 1 hr + NTSCHEM = NSPAN / ( GET_TS_CHEM() / 60D0 ) + + ! default is molec/cm2/s + FACT = XNUMOL(IDTNH4) / DTCHEM + & / TCVV(IDTNH4) / NTSCHEM + + FIRST = .FALSE. + + ENDIF + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, F_UNDER_TOP, FREQ, NH40, NH4, AREA_CM2, FLUX ) +!$OMP+PRIVATE( ADJ_NH40, ADJ_NH4 ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, PBL_MAX + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Fraction of box (I,J,L) underneath the PBL top [unitless] + F_UNDER_TOP = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! Only apply drydep to boxes w/in the PBL + IF ( F_UNDER_TOP > 0d0 ) THEN + + ! NH4 drydep frequency [1/s]. Also accounts for the fraction + ! of each grid box (I,J,L) that is located beneath the PBL top + FREQ = DEPSAV(I,J,DRYNH4) * F_UNDER_TOP + + ! Only apply drydep loss if FREQ is nonzero + IF ( FREQ > 0d0 ) THEN + + ! Initial ADJ_NH4 + ADJ_NH4 = STT_ADJ(I,J,L,IDTNH4) + + ! Adjoint of NH4 change due to deposition + ADJ_NH40 = ADJ_NH4 * EXP( -FREQ * DTCHEM ) + + ! Update global array + STT_ADJ(I,J,L,IDTNH4) = ADJ_NH40 + + IF ( FORCE ) THEN + + ! note: the forcing corresponds to this cost function: + ! COST_FUNC = SUM ( STT * ( 1 - EXP( - FREQ * DTCHEM) ) + ! * AD(I,J,L) * FACT / GET_AREA_CM2(J) + ! the forcing is thu: + STT_ADJ(I,J,L,IDTNH4) = STT_ADJ(I,J,L,IDTNH4) + & + ( 1d0 - EXP( - FREQ * DTCHEM ) ) + & * AD(I,J,L) * FACT / GET_AREA_CM2(J) + & * GET_CF_REGION(I,J,L) + & * TR_DDEP_CONV(J,IDTNH4) + + ENDIF + + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + + ! Return to calling program + END SUBROUTINE CHEM_NH4_ADJ + +!!------------------------------------------------------------------------------ +! +! SUBROUTINE CHEM_NH4aq +!! +!!****************************************************************************** +!! Subroutine CHEM_NH4aq removes NH4aq from the surface via dry deposition. +!! (cas, bmy, 1/6/05, 10/25/05) +!! +!! Reaction List: +!! ============================================================================ +!! (1 ) NH4aq = NH4_0aq * EXP( -dt ) where d = dry deposition rate [s-1] +!! +!! NOTES: +!! (1 ) Replace PBLFRAC from "drydep_mod.f" with GET_FRAC_UNDER_PBLTOP from +!! "pbl_mix_mod.f". Also reference GET_PBL_MAX_L from "pbl_mix_mod.f" +!! Vertical DO-loops can run up to PBL_MAX and not LLTROP. (bmy, 2/22/05) +!! (31) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE DAO_MOD, ONLY : AD +! USE DIAG_MOD, ONLY : AD44 +! USE DRYDEP_MOD, ONLY : DEPSAV +! USE GRID_MOD, ONLY : GET_AREA_CM2 +! USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP, GET_PBL_MAX_L +! USE TIME_MOD, ONLY : GET_TS_CHEM +! USE TRACER_MOD, ONLY : STT, TCVV, XNUMOL +! USE TRACERID_MOD, ONLY : IDTNH4aq +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_DIAG" ! ND44 +! +! ! Local variables +! INTEGER :: I, J, L, PBL_MAX +! REAL*8 :: DTCHEM, NH4aq, NH4aq0 +! REAL*8 :: FREQ, FLUX, AREA_CM2, F_UNDER_TOP +! REAL*8 :: T44(IIPAR,JJPAR,LLTROP) +! +! !================================================================= +! ! CHEM_NH4 begins here! +! !================================================================= +! IF ( IDTNH4aq == 0 .or. DRYNH4aq == 0 ) RETURN +! +! ! DTCHEM is the chemistry interval in seconds +! DTCHEM = GET_TS_CHEM() * 60d0 +! +! ! Model level where maximum PBL height occurs +! PBL_MAX = GET_PBL_MAX_L() +! +! ! Zero T44 array +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO L = 1, LLTROP +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! T44(I,J,L) = 0d0 +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L, F_UNDER_TOP, FREQ ) +!!$OMP+PRIVATE( NH4aq0, NH4aq, AREA_CM2, FLUX ) +!!$OMP+SCHEDULE( DYNAMIC ) +! DO L = 1, PBL_MAX +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Fraction of box (I,J,L) underneath the PBL top [unitless] +! F_UNDER_TOP = GET_FRAC_UNDER_PBLTOP( I, J, L ) +! +! ! Only apply drydep to boxes w/in the PBL +! IF ( F_UNDER_TOP > 0d0 ) THEN +! +! ! NH4 drydep frequency [1/s] -- PBLFRAC accounts for the fraction +! ! of each grid box (I,J,L) that is located beneath the PBL top +! FREQ = DEPSAV(I,J,DRYNH4aq) * F_UNDER_TOP +! +! ! Only apply drydep loss if FREQ is nonzero +! IF ( FREQ > 0d0 ) THEN +! +! ! Initial NH4 [v/v] +! NH4aq0 = STT(I,J,L,IDTNH4aq) +! +! ! Amount of NH4 lost to drydep [v/v] +! NH4aq = NH4aq0 * ( 1d0 - EXP( -FREQ * DTCHEM ) ) +! +! ! Prevent underflow condition +! IF ( NH4aq < SMALLNUM ) NH4aq = 0d0 +! +! ! Subtract NH4 lost to drydep from initial NH4 [v/v] +! STT(I,J,L,IDTNH4aq) = NH4aq0 - NH4aq +! +! !======================================================== +! ! ND44 diagnostic: Drydep flux of NH4 [molec/cm2/s] +! !======================================================== +! IF ( ND44 > 0 .and. NH4aq > 0d0 ) THEN +! +! ! Surface area [cm2] +! AREA_CM2 = GET_AREA_CM2( J ) +! +! ! Convert drydep loss from [v/v/timestep] to [molec/cm2/s] +! FLUX = NH4aq * AD(I,J,L) / TCVV(IDTNH4aq) +! FLUX = FLUX * XNUMOL(IDTNH4aq) / AREA_CM2 / DTCHEM +! +! ! Store dryd flx in ND44_TMP as a placeholder +! T44(I,J,L) = T44(I,J,L) + FLUX +! ENDIF +! ENDIF +! ENDIF +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! !=============================================================== +! ! ND44: Sum drydep fluxes by level into the AD44 array in +! ! order to ensure that we get the same results w/ sp or mp +! !=============================================================== +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! DO L = 1, PBL_MAX +! AD44(I,J,DRYNH4aq,1) = AD44(I,J,DRYNH4aq,1) + T44(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE CHEM_NH4aq +! +!!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_NIT_ADJ +! +!****************************************************************************** +! Subroutine ADJ_CHEM_NIT is the adjoint NIT chemistry subroutine for the +! fwd routine CHEM_NIT. See original routine for notes. (dkh, 10/13/05) +! +! * Does not deal with NITs * +! +! See original (rjp, bdf, bmy, 1/2/02, 5/23/06) for notes. +! +! Reaction List: +! ============================================================================ +! (1 ) NIT = NIT_0 * EXP( -dt ) where d = dry deposition rate [s-1] +! +! NOTES: +! (1 ) Updates to GCv8 adjoint (dkh, 09/28/09) +! (2 ) Now support deposition cost function (fp, dkh, 03/04/13) +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION + USE ADJ_ARRAYS_MOD, ONLY : OBS_THIS_TRACER + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE DAO_MOD, ONLY : AD + USE DIAG_MOD, ONLY : AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LSSALT + USE LOGICAL_ADJ_MOD,ONLY : LADJ_DDEP_TRACER + USE LOGICAL_ADJ_MOD,ONLY : LMAX_OBS + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP, GET_PBL_MAX_L + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TIME_MOD, ONLY : GET_TAU + USE TRACER_MOD, ONLY : STT, TCVV, XNUMOL + USE TRACERID_MOD, ONLY : IDTNIT, IDTNITs + USE ADJ_ARRAYS_MOD, ONLY : TR_DDEP_CONV, DEP_UNIT + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, N, N_ND44, PBL_MAX + REAL*8 :: DTCHEM, NIT, NITs, NIT0, NIT0s, E_RKT + REAL*8 :: E_RKTs, FLUX, FREQ, FREQs, RKT, RKTs + REAL*8 :: AREA_CM2, F_UNDER_TOP + REAL*8 :: ADJ_NIT, ADJ_NIT0 + + REAL*8, SAVE :: NTSCHEM + REAL*8, SAVE :: FACT + LOGICAL,SAVE :: FIRST = .TRUE. + LOGICAL :: FORCE + INTEGER, SAVE :: OBS_COUNT = 0 + + !================================================================= + ! CHEM_NIT_ADJ begins here! + !================================================================= + + ! Return if tracers are not defined + !IF ( IDTNIT == 0 .or. IDTNITs == 0 ) RETURN + !IF ( DRYNIT == 0 .or. DRYNITs == 0 ) RETURN + IF ( IDTNIT == 0 ) RETURN + IF ( DRYNIT == 0 ) RETURN + + ! DTCHEM is the chemistry interval in seconds + DTCHEM = GET_TS_CHEM() * 60d0 + + ! Model level where maximum PBL height occurs + PBL_MAX = GET_PBL_MAX_L() + + ! Model level where maximum PBL height occurs + PBL_MAX = GET_PBL_MAX_L() + + ! Determine if it is time to apply deposition forcing + FORCE = .FALSE. + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + 1 + IF ( OBS_COUNT <= NSPAN + & .and. LADJ_DDEP_TRACER + & .and. OBS_THIS_TRACER(IDTNIT) ) THEN + FORCE = .TRUE. + + WRITE(6,100) , 'NIT' , + & TRIM( DEP_UNIT ) + + 100 FORMAT('Forcing ',a,' drydep (', a,')') + + ENDIF + ENDIF + + ! initialize some constants for depostion forcing + IF ( FORCE .and. FIRST ) THEN + + ! here we aren't assuming that TS_CHEM is necessarily 1 hr + NTSCHEM = NSPAN / ( GET_TS_CHEM() / 60D0 ) + + !default is molec/cm2/s + FACT = XNUMOL(IDTNIT) / DTCHEM + & / TCVV(IDTNIT) / NTSCHEM + + FIRST = .FALSE. + + ENDIF + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, NIT0, NIT0s, NIT ) +!$OMP+PRIVATE( NITs, FREQ, FREQs, F_UNDER_TOP, RKT, E_RKT ) +!$OMP+PRIVATE( RKTs, E_RKTs, AREA_CM2, FLUX ) +!$OMP+PRIVATE( ADJ_NIT0, ADJ_NIT ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, PBL_MAX + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Initialize variables + NIT = 0d0 + NITs = 0d0 + FREQ = 0d0 + FREQs = 0d0 + + ! Fraction of box (I,J,L) underneath the PBL top [unitless] + F_UNDER_TOP = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! Only apply drydep to boxes w/in the PBL + IF ( F_UNDER_TOP > 0d0 ) THEN + + !=========================================================== + ! NIT chemistry + !=========================================================== + + ! NIT drydep frequency [1/s]. Also accounts for the fraction + ! of each vertical level that is located below the PBL top + FREQ = DEPSAV(I,J,DRYNIT) * F_UNDER_TOP + + ! If there is drydep ... + IF ( FREQ > 0d0 ) THEN + + ! Fraction of NIT lost to drydep [unitless] (bec, 12/15/04) + RKT = FREQ * DTCHEM + + ! Pre-compute the exponential term + E_RKT = EXP( -RKT ) + + ! Initial ADJ_NIT + ADJ_NIT = STT_ADJ(I,J,L,IDTNIT) + + ! Adjoint of NIT change due to deposition + ADJ_NIT0 = ADJ_NIT * E_RKT + + ! Update global array + STT_ADJ(I,J,L,IDTNIT) = ADJ_NIT0 + + IF ( FORCE ) THEN + + ! note: the forcing corresponds to this cost function: + ! COST_FUNC = SUM ( STT * ( 1 - EXP( - FREQ * DTCHEM) ) + ! * AD(I,J,L) * FACT / GET_AREA_CM2(J) + ! the forcing is thu: + STT_ADJ(I,J,L,IDTNIT) = STT_ADJ(I,J,L,IDTNIT) + & + ( 1d0 - EXP( - RKT ) ) + & * AD(I,J,L) * FACT / GET_AREA_CM2(J) + & * GET_CF_REGION(I,J,L) + & * TR_DDEP_CONV(J,IDTNIT) + + ENDIF + + ENDIF + + ENDIF + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE CHEM_NIT_ADJ + +!----------------------------------------------------------------------------- + + SUBROUTINE EMISSSULFATE_ADJ +! +!****************************************************************************** +! Subroutine EMISSSULFATE_ADJ is the interface between the adjoint +! of GEOS-CHEM and the adjoint of the sulfate emission routines. +! (dkh, 04/19/06) +! +! Based on forward routine EMISSSULFATE (bmy, 6/7/00, 10/3/05) +! +! NOTES: +! (1 ) Update to GCv8 (dkh, 11/03/09) +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : DEBUG_MSG + USE LOGICAL_MOD, ONLY : LSHIPSO2, LPRT, LBIOMASS !(win,5/1/09) + USE TIME_MOD, ONLY : GET_SEASON, GET_MONTH + USE TIME_MOD, ONLY : GET_YEAR, ITS_A_NEW_MONTH + USE TRACER_MOD, ONLY : STT, ITS_AN_AEROSOL_SIM + USE TRACERID_MOD, ONLY : IDTNITs, IDTSO4s + USE TRACERID_MOD, ONLY : IDTDMS, IDTSO2 + USE TRACERID_MOD, ONLY : IDTSO4, IDTNH3 + USE GFED2_BIOMASS_MOD, ONLY : GFED2_IS_NEW + USE LOGICAL_MOD, ONLY : LANTHRO + + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRSTEMISS = .TRUE. + INTEGER :: NSEASON, MONTH, YEAR + + !================================================================= + ! EMISSSULFATE_ADJ begins here! + !================================================================= + + ! Get the season and month + NSEASON = GET_SEASON() + MONTH = GET_MONTH() + YEAR = GET_YEAR() + + ! fwd code: + !!================================================================= + !! Add emissions into the STT tracer array + !!================================================================= + !IF ( IDTDMS /= 0 ) CALL SRCDMS( STT(:,:,:,IDTDMS) ) + !IF ( IDTSO2 /= 0 ) CALL SRCSO2( STT(:,:,:,IDTSO2), NSEASON ) + !IF ( IDTSO4 /= 0 ) CALL SRCSO4( STT(:,:,:,IDTSO4) ) + !IF ( IDTNH3 /= 0 ) CALL SRCNH3( STT(:,:,:,IDTNH3) ) + ! adj code: + IF ( IDTNH3 /= 0 ) CALL SRCNH3_ADJ( STT_ADJ(:,:,:,IDTNH3) ) + ! add these later as needed + !IF ( IDTSO4 /= 0 ) CALL SRCSO4_ADJ( STT_ADJ(:,:,:,IDTSO4) ) + IF ( IDTSO2 /= 0 ) CALL SRCSO2_ADJ( STT_ADJ(:,:,:,IDTSO2),NSEASON) + !IF ( IDTDMS /= 0 ) CALL SRCDMS_ADJ( STT_ADJ(:,:,:,IDTDMS) ) + + ! If we wanted to pass sensitivities all the way back to specific + ! emissions inventories, we could carry on like so... +! IF( ( GFED2_IS_NEW() .or. ITS_A_NEW_MONTH_ADJ() ) .AND. +! & ( LBIOMASS ) ) THEN +! +! ! fwd code: +! !CALL GET_BIOMASS_NH3 +! ! adj code: +! print*, ' need to add GET_BIOMASS_NH3_ADJ ' +! !CALL GET_BIOMASS_NH3_ADJ +! !IF ( LPRT ) CALL DEBUG_MSG('### EMISSSULFATE: GET_BM_NH3_ADJ') +! +! ! fwd code: +! !CALL GET_BIOMASS_SO2 +! ! adj code: +! print*, ' need to add GET_BIOMASS_SO2_ADJ' +! !CALL GET_BIOMASS_SO2_ADJ +! !IF ( LPRT ) CALL DEBUG_MSG('### EMISSSULFATE: GET_BM_SO2_ADJ') +! +! ENDIF +! +! !================================================================= +! ! If this is a new month, read in the monthly mean quantities +! !================================================================= +! IF ( ITS_A_NEW_MONTH() ) THEN +! +! ! fwd code: +! !! Read oxidants for the offline simulation only +! !IF ( ITS_AN_AEROSOL_SIM() ) CALL READ_OXIDANT( MONTH ) +! ! adj code: not supported +! +! ! fwd code: +! !! Also read ship exhaust SO2 if necessary +! !CALL READ_SHIP_SO2( MONTH ) +! ! adj code: +! CALL READ_SHIP_SO2_ADJ( MONTH ) +! +! +! ! Add LANTHRO switch to turn off anthropogenic emissions. +! ! (ccc, 4/15/09) +! IF ( LANTHRO ) THEN +! +! ! fwd code: +! !CALL READ_AIRCRAFT_SO2( MONTH ) +! !CALL READ_ANTHRO_SOx( MONTH, NSEASON ) +! !CALL READ_ANTHRO_NH3( MONTH ) +! ! adj code: +! CALL READ_ANTHRO_NH3_ADJ( MONTH ) +! CALL READ_ANTHRO_SOx_ADJ( MONTH, NSEASON ) +! CALL READ_AIRCRAFT_SO2_ADJ( MONTH ) +! +! ENDIF +! +! ! fwd code: +! !! Read monthly mean data +! !CALL READ_SST( MONTH, YEAR ) +! !CALL READ_OCEAN_DMS( MONTH ) +! !CALL READ_BIOFUEL_SO2( MONTH ) +! !CALL READ_BIOFUEL_NH3( MONTH ) +! !CALL READ_NATURAL_NH3( MONTH ) +! ! adj code: +! CALL READ_NATURAL_NH3_ADJ( MONTH ) +! CALL READ_BIOFUEL_NH3_ADJ( MONTH ) +! CALL READ_BIOFUEL_SO2_ADJ( MONTH ) +! CALL READ_OCEAN_DMS_ADJ( MONTH ) +! CALL READ_SST_ADJ( MONTH, YEAR ) +! +! +! ENDIF + + + ! Return to calling program + END SUBROUTINE EMISSSULFATE_ADJ + +!----------------------------------------------------------------------------- + + SUBROUTINE SRCNH3_ADJ( TC_ADJ ) +! +!****************************************************************************** +! Subroutine ADJ_SRCNH3 computes adjoint of emission from adjoint of tracer +! (dkh, 05/05/06) +! +! Based on forward routine SRCNH3 (rjp, bmy, 12/17/01, 2/22/05) +! +! Arguments as Input +! ============================================================================ +! (1 ) TC_ADJ (REAL*8 ) : Array for adjoint of NH3 tracer mass in kg +! +! NOTES: +! (1 ) Update to GCv8 +! (2 ) Now adjoints are w.r.t. NH3an, ENH3_bb, NH3bf and ENH3_na +! (3 ) Add LEMS_ABS option (dkh, 02/17/11) +! (4 ) Add support for LNEI05 (dkh, 02/19/11) +!****************************************************************************** +! + ! References to F90 modules + USE CAC_ANTHRO_MOD, ONLY : GET_CANADA_MASK + USE CAC_ANTHRO_MOD, ONLY : GET_CAC_ANTHRO + USE DIAG_MOD, ONLY : AD13_NH3_an, AD13_NH3_bb + USE DIAG_MOD, ONLY : AD13_NH3_bf, AD13_NH3_na + USE DAO_MOD, ONLY : PBL + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE EPA_NEI_MOD, ONLY : GET_EPA_ANTHRO, GET_EPA_BIOFUEL + USE EPA_NEI_MOD, ONLY : GET_USA_MASK + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LNEI99, LCAC, LNEI05, LNEI08 + USE LOGICAL_MOD, ONLY : LRCP + USE NEI2005_ANTHRO_MOD, ONLY : GET_NEI2005_ANTHRO + USE NEI2005_ANTHRO_MOD, ONLY : NEI05_MASK => USA_MASK + USE NEI2008_ANTHRO_MOD, ONLY : GET_NEI2008_ANTHRO + USE NEI2008_ANTHRO_MOD, ONLY : NEI08_MASK => USA_MASK + USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_TOP_L + USE TIME_MOD, ONLY : GET_DAY_OF_WEEK, GET_TS_EMIS, GET_HOUR + USE TIME_MOD, ONLY : GET_DAY_OF_WEEK_LT + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTNH3 + + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_an + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_na + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_bb + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ENH3_bf + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD + USE ADJ_ARRAYS_MOD, ONLY : EMS_ADJ + USE LOGICAL_ADJ_MOD,ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD,ONLY : LEMS_ABS + USE LOGICAL_MOD, ONLY : LHTAP + USE SULFATE_MOD, ONLY : ENH3_an + USE SULFATE_MOD, ONLY : ENH3_bb + USE SULFATE_MOD, ONLY : ENH3_bf + USE SULFATE_MOD, ONLY : ENH3_na + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND13 +# include "CMN_GCTM" ! SCALE_HEIGHT + + ! Argumetns + REAL*8, INTENT(IN) :: TC_ADJ(IIPAR,JJPAR,LLPAR) + + ! Local variables + LOGICAL :: WEEKDAY + INTEGER :: I, J, L, K, NTOP, DAY_NUM, IH, DOW_LT + REAL*8 :: FEMIS, DTSRCE + REAL*8 :: AREA_CM2, EPA_AN, EPA_BF + REAL*8 :: CAC_AN + REAL*8 :: NH3an(IIPAR,JJPAR) + REAL*8 :: NH3bf(IIPAR,JJPAR) + REAL*8 :: TNH3_ADJ + + !================================================================= + ! SRCNH3_ADJ begins here! + !================================================================= + + + ! Emission timestep [s] + DTSRCE = GET_TS_EMIS() * 60d0 + + ! Get current day of the week + DAY_NUM = GET_DAY_OF_WEEK() + + ! Is it a weekday? + WEEKDAY = ( DAY_NUM > 0 .and. DAY_NUM < 6 ) + + ! Get hour (for NEI08) + IH = GET_HOUR() + 1 + + !================================================================= + ! Overwrite USA with EPA/NEI NH3 emissions (if necessary) + ! Store emissions into local arrays NH3an, NH3bf + !================================================================= +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, AREA_CM2, EPA_AN, EPA_BF, CAC_AN ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, AREA_CM2, EPA_AN, EPA_BF, CAC_AN, L ) +!$OMP+PRIVATE( DOW_LT, WEEKDAY ) + DO J = 1, JJPAR + + !------------------------------------------------------------------- + ! NOTE: There seems to be some problems with the EPA/NEI NH3 + ! emissions. Therefore we will use the existing emissions for NH3 + ! until further notice. Comment out the lines below until + ! further notice. (bmy, 11/17/04) + !! Grid box surface area [cm2] + AREA_CM2 = GET_AREA_CM2( J ) + !------------------------------------------------------------------- + + DO I = 1, IIPAR + + !----------------------------------------------------------------- + ! NOTE: There seems to be some problems with the EPA/NEI NH3 + ! emissions. Therefore we will use the existing emissions for + ! NH3 until further notice. Comment out the lines below until + ! further notice. (bmy, 11/17/04) + ! + !! If we are using EPA/NEI99 emissions ... + !IF ( LNEI99 ) THEN + ! + ! ! If we are over the USA ... + ! IF ( GET_USA_MASK( I, J ) > 0d0 ) THEN + ! + ! ! Read NH3 anthro emissions in [molec NH3/cm2/s] + ! EPA_AN = GET_EPA_ANTHRO( I, J, IDTNH3, WEEKDAY ) + ! EPA_BF = GET_EPA_BIOFUEL( I, J, IDTNH3, WEEKDAY ) + ! + ! ! Convert from [molec NH3/cm2/s] to [kg NH3/box/sec] + ! NH3an(I,J) = EPA_AN * AREA_CM2 / XNUMOL(IDTNH3) + ! NH3bf(I,J) = EPA_BF * AREA_CM2 / XNUMOL(IDTNH3) + ! + ! ELSE + ! + ! ! If we are not over the USA, just use the regular + ! ! emissions in NH3_an and NH3bf (bmy, 11/16/04) + ! NH3an(I,J) = ENH3_an(I,J) + ! NH3bf(I,J) = ENH3_bf(I,J) + ! + ! ENDIF + ! + !ELSE + !----------------------------------------------------------------- + + ! If we are not using the EPA/NEI emissions, just copy the + ! regular ENH3_an and ENH3_bf to local arrays. (bmy, 11/16/04) + NH3an(I,J) = ENH3_an(I,J) + NH3bf(I,J) = ENH3_bf(I,J) + + ! The RCP anthropogenic emission inventory already includes + ! biofuel emissions, so we turn off the additional biofuel + ! inventory (cdh, 8/31/12) + IF ( LRCP ) NH3bf(I,J) = 0d0 + + !----------------------------------------------------------------- + ! NOTE: There seems to be some problems with the EPA/NEI NH3 + ! emissions. Therefore we will use the existing emissions for + ! NH3 until further notice. Comment out the lines below until + ! further notice. (bmy, 11/17/04) + !ENDIF + !----------------------------------------------------------------- + + ! If we are using CAC emissions and over CANADA + IF ( LCAC .and. .not. LHTAP .and. .not. LRCP ) THEN + IF ( GET_CANADA_MASK( I, J ) > 0d0 ) THEN + + ! Read NH3 anthro emissions in [molec NH3/cm2/s] + CAC_AN = GET_CAC_ANTHRO( I, J, IDTNH3, + & MOLEC_CM2_S=.TRUE.) + + ! Convert from [molec NH3/cm2/c] to [kg NH3/box/sec] + NH3an(I,J) = CAC_AN * AREA_CM2 / XNUMOL(IDTNH3) + + ENDIF + ENDIF + + ! If we are using NEI 2005 over North America + IF ( LNEI05 .and. .not. LHTAP .and. .not. LRCP ) THEN + IF ( NEI05_MASK( I, J ) > 0d0 ) THEN + + DOW_LT = GET_DAY_OF_WEEK_LT( I, J, 1 ) + WEEKDAY = ( DOW_LT > 0 .and. DOW_LT < 6 ) + + ! For 2D NH3an (dkh, 02/19/11) + NH3an(I,J) = 0d0 + + DO L = 1, NOXLEVELS + + ! Read NH3 anthro emissions in [molec NH3/cm2/s] + EPA_AN = GET_NEI2005_ANTHRO( I, J, L, IDTNH3, + & WEEKDAY, MOLEC_CM2_S=.TRUE.) + + ! Convert from [molec NH3/cm2/c] to [kg NH3/box/sec] + ! Keep NH3an 2D for now. (dkh, 02/19/11) + !NH3an(I,J,L) = EPA_AN * AREA_CM2 / XNUMOL(IDTNH3) + NH3an(I,J) = NH3an(I,J) + & + EPA_AN * AREA_CM2 / XNUMOL(IDTNH3) + + ENDDO + + ENDIF + ENDIF + + ! If we are using NEI 2008 over North America + IF ( LNEI08 .and. .not. LHTAP .and. .not. LRCP ) THEN + IF ( NEI08_MASK( I, J ) > 0d0 ) THEN + + DOW_LT = GET_DAY_OF_WEEK_LT( I, J, 1 ) + WEEKDAY = ( DOW_LT > 0 .and. DOW_LT < 6 ) + + NH3an(I,J) = 0d0 + + DO L = 1, NOXLEVELS + + ! Read NH3 anthro emissions in [molec NH3/cm2/s] + EPA_AN = GET_NEI2008_ANTHRO( I, J, L, IH, IDTNH3, + & WEEKDAY ) + + ! Convert from [molec NH3/cm2/c] to [kg NH3/box/sec] + ! same as daven keep NH3an 2d + ! NH3an(I,J,L) = EPA_AN * AREA_CM2 / XNUMOL(IDTNH3) + NH3an(I,J) = NH3an(I,J) + & + EPA_AN * AREA_CM2 / XNUMOL(IDTNH3) + ENDDO + ENDIF + ENDIF + + + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Partition NH3 emissions into the STT tracer array + !================================================================= + + ! Loop over surface grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, NTOP, L, FEMIS ) +!$OMP+PRIVATE( TNH3_ADJ ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Layer where the PBL top happens + NTOP = CEILING( GET_PBL_TOP_L( I, J ) ) + + !============================================================== + ! Add NH3 emissions [kg NH3/box] into the tracer array + ! Partition total NH3 throughout the entire boundary layer + !============================================================== + + TNH3_ADJ = 0d0 + + ! Loop over all levels in the boundary layer + DO L = 1, NTOP + + ! Fraction of PBL spanned by grid box (I,J,L) [unitless] + FEMIS = GET_FRAC_OF_PBL( I, J, L ) + + ! fwd code: + !! Add NH3 emissions into tracer array [kg NH3/timestep] + !TC(I,J,L) = TC(I,J,L) + ( TNH3 * FEMIS * DTSRCE ) + ! adj code: + TNH3_ADJ = TNH3_ADJ + ( TC_ADJ(I,J,L) * FEMIS * DTSRCE ) + + ENDDO + + ! fwd code: + !! Sum all types of NH3 emission [kg/box/s] + !TNH3 = NH3an(I,J) + ENH3_bb(I,J) + + & ! NH3bf(I,J) + ENH3_na(I,J) + ! adj code: + EMS_SF_ADJ(I,J,1,IDADJ_ENH3_an) = + & EMS_SF_ADJ(I,J,1,IDADJ_ENH3_an) + TNH3_ADJ * NH3an(I,J) + EMS_SF_ADJ(I,J,1,IDADJ_ENH3_bb) = + & EMS_SF_ADJ(I,J,1,IDADJ_ENH3_bb) + TNH3_ADJ * ENH3_bb(I,J) + EMS_SF_ADJ(I,J,1,IDADJ_ENH3_bf) = + & EMS_SF_ADJ(I,J,1,IDADJ_ENH3_bf) + TNH3_ADJ * NH3bf(I,J) + EMS_SF_ADJ(I,J,1,IDADJ_ENH3_na) = + & EMS_SF_ADJ(I,J,1,IDADJ_ENH3_na) + TNH3_ADJ * ENH3_na(I,J) + + ! dkh debug + IF ( I == IFD .and. J == JFD .AND. LPRINTFD ) THEN + print*, ' SRCNH3 adj : NH3an = ', NH3an(I,J) + print*, ' SRCNH3 adj : ENH3_bb= ', ENH3_bb(I,J) + print*, ' SRCNH3 adj : NH3bf = ', NH3bf(I,J) + print*, ' SRCNH3 adj : ENH3_na= ', ENH3_na(I,J) + print*, ' SRCNH3 adj : TNH3_ADJ = ', TNH3_ADJ + print*, ' EMS_SF_ADJ(ENH3_an) = ', + & EMS_SF_ADJ(I,J,1,IDADJ_ENH3_an) + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Optional diagnostic -- add sensitivity w.r.t to absolute emissions (dkh, 02/17/11) + IF ( LEMS_ABS ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, NTOP, L, FEMIS ) +!$OMP+PRIVATE( TNH3_ADJ ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Layer where the PBL top happens + NTOP = CEILING( GET_PBL_TOP_L( I, J ) ) + + !============================================================== + ! Add NH3 emissions [kg NH3/box] into the tracer array + ! Partition total NH3 throughout the entire boundary layer + !============================================================== + + TNH3_ADJ = 0d0 + + ! Loop over all levels in the boundary layer + DO L = 1, NTOP + + ! Fraction of PBL spanned by grid box (I,J,L) [unitless] + FEMIS = GET_FRAC_OF_PBL( I, J, L ) + + ! fwd code: + !! Add NH3 emissions into tracer array [kg NH3/timestep] + !TC(I,J,L) = TC(I,J,L) + ( TNH3 * FEMIS * DTSRCE ) + ! adj code: + TNH3_ADJ = TNH3_ADJ + ( TC_ADJ(I,J,L) * FEMIS * DTSRCE ) + + ENDDO + + ! fwd code: + !! Sum all types of NH3 emission [kg/box/s] + !TNH3 = NH3an(I,J) + ENH3_bb(I,J) + + & ! NH3bf(I,J) + ENH3_na(I,J) + ! adj code: also convert to J / (kg/box/timestep) + EMS_ADJ(I,J,1,IDADJ_ENH3_an) + & = EMS_ADJ(I,J,1,IDADJ_ENH3_an) + TNH3_ADJ / DTSRCE + EMS_ADJ(I,J,1,IDADJ_ENH3_bb) + & = EMS_ADJ(I,J,1,IDADJ_ENH3_bb) + TNH3_ADJ / DTSRCE + EMS_ADJ(I,J,1,IDADJ_ENH3_bf) + & = EMS_ADJ(I,J,1,IDADJ_ENH3_bf) + TNH3_ADJ / DTSRCE + EMS_ADJ(I,J,1,IDADJ_ENH3_na) + & = EMS_ADJ(I,J,1,IDADJ_ENH3_na) + TNH3_ADJ / DTSRCE + + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ! Return to calling program + END SUBROUTINE SRCNH3_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE SRCSO2_ADJ( TC_ADJ, NSEASON ) +! +!****************************************************************************** +! Subroutine SRCSO2_ADJ computes the adjoint of SO2 emisson scaling factors. +! (dkh, 05/04/06, 02/04/10) +! +! Based on forward model code SRCSO2 (rjp, bdf, bmy, 6/2/00, 2/27/09) +! +! Arguments as Input/Output: +! =========================================================================== +! (1 ) NSEASON (INTEGER) : Season number: 1=DJF; 2=MAM; 3=JJA; 4=SON +! (2 ) TC_ADJ (REAL*8 ) : adoint of SO2 tracer mass +! +! NOTES: +! (1 ) Doesn't deal with aircraft or volcanoe source yet. +! (2 ) Updated to GCv8 (dkh, 02/04/10) +! (3 ) Add support for LEMS_ABS +!****************************************************************************** +! + ! Reference to diagnostic arrays + USE BRAVO_MOD, ONLY : GET_BRAVO_ANTHRO, GET_BRAVO_MASK + USE CAC_ANTHRO_MOD, ONLY : GET_CANADA_MASK, GET_CAC_ANTHRO + USE DIAG_MOD, ONLY : AD13_SO2_an, AD13_SO2_ac + USE DIAG_MOD, ONLY : AD13_SO2_bb, AD13_SO2_nv + USE DIAG_MOD, ONLY : AD13_SO2_ev, AD13_SO2_bf + USE DIAG_MOD, ONLY : AD13_SO2_sh + USE DAO_MOD, ONLY : BXHEIGHT, PBL + USE EPA_NEI_MOD, ONLY : GET_EPA_ANTHRO, GET_EPA_BIOFUEL + USE EPA_NEI_MOD, ONLY : GET_USA_MASK + USE ERROR_MOD, ONLY : ERROR_STOP + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LBRAVO, LNEI99, LSHIPSO2 + USE LOGICAL_MOD, ONLY : LCAC, LNEI05, LNEI08 + USE NEI2005_ANTHRO_MOD, ONLY : GET_NEI2005_ANTHRO + USE NEI2005_ANTHRO_MOD, ONLY : NEI05_MASK => USA_MASK + USE NEI2008_ANTHRO_MOD, ONLY : GET_NEI2008_ANTHRO + USE NEI2008_ANTHRO_MOD, ONLY : NEI08_MASK => USA_MASK + USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_TOP_L + USE TIME_MOD, ONLY : GET_TS_EMIS, GET_DAY_OF_YEAR + USE TIME_MOD, ONLY : GET_DAY_OF_WEEK, GET_HOUR + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTSO2 + USE LOGICAL_MOD, ONLY : LHTAP + USE HTAP_MOD, ONLY : GET_HTAP + + ! adj_group + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_an1, IDADJ_ESO2_an2 + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_bb, IDADJ_ESO2_bf + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_ESO2_sh + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : EMS_ADJ + USE LOGICAL_ADJ_MOD,ONLY : LEMS_ABS + USE SULFATE_MOD, ONLY : ESO2_an + USE SULFATE_MOD, ONLY : ESO2_bb + USE SULFATE_MOD, ONLY : ESO2_bf + USE SULFATE_MOD, ONLY : ESO2_sh + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND13, LD13 (for now) +# include "CMN_GCTM" ! SCALE_HEIGHT + + ! Arguments + INTEGER, INTENT(IN) :: NSEASON + REAL*8, INTENT(INOUT) :: TC_ADJ(IIPAR,JJPAR,LLPAR) + + ! Local variables + LOGICAL :: WEEKDAY + INTEGER :: I, J, K, L, LV1, LV2, NTOP, JDAY + INTEGER :: DAY_NUM, IH + REAL*8 :: ZH(0:LLPAR), DZ(LLPAR), SO2(LLPAR) + REAL*8 :: DTSRCE, HGHT, SO2SRC + REAL*8 :: SLAB, SLAB1 + REAL*8 :: TSO2, FEMIS + REAL*8 :: AREA_CM2, AN, BF + REAL*8 :: SO2an(IIPAR,JJPAR,2) + REAL*8 :: SO2bf(IIPAR,JJPAR) + REAL*8 :: HTAP + + ! for adjoint + REAL*8 :: SO2SRC_ADJ + REAL*8 :: SO2_ADJ(LLPAR) + REAL*8 :: TSO2_ADJ + + ! Ratio of molecular weights: S/SO2 + REAL*8, PARAMETER :: S_SO2 = 32d0 / 64d0 + + !================================================================= + ! SRCSO2_ADJ begins here! + !================================================================ + + ! DTSRCE is the emission timestep in seconds + DTSRCE = GET_TS_EMIS() * 60d0 + + ! JDAY is the day of year (0-365 or 0-366) + JDAY = GET_DAY_OF_YEAR() + + ! Get current day of the week + DAY_NUM = GET_DAY_OF_WEEK() + + ! Get hour (for NEI08) + IH = GET_HOUR() + 1 + + ! Is it a weekday? + WEEKDAY = ( DAY_NUM > 0 .and. DAY_NUM < 6 ) + + !================================================================= + ! First we recalculate fwd model emissions + !================================================================= +! Adjoint of LENV not supported yet +! !================================================================= +! ! SO2 emissions from non-eruptive volcanoes [kg SO2/box/s]. +! ! Assume that emission only occurs at the crater altitude. +! !================================================================= +! IF ( LENV ) THEN +! +! ! Initialize +! ESO2_nv = 0.d0 +! +! ! Loop thru each non-erupting volcano +! DO K = 1, NNVOL +! +! ! Elevation of volcano crater +! HGHT = DBLE( IELVn(k) ) +! +! ! Altitude of crater from the ground +! ZH(0) = 0.d0 +! +! ! Loop over levels +! DO L = 1, LLPAR +! +! ! Thickness of layer [m] w/ crater +! DZ(L) = BXHEIGHT(INV(K),JNV(K),L) +! +! ! Increment altitude +! ZH(L) = ZH(L-1) + DZ(L) +! +! ! If we are at the crater altitude, add emissions and exit +! IF ( ZH(L-1) <= HGHT .AND. ZH(L) > HGHT ) THEN +! ESO2_nv(INV(K),JNV(K),L) = +! & ESO2_nv(INV(K),JNV(K),L) + Env(K) +! EXIT +! ENDIF +! ENDDO +! ENDDO +! ENDIF +! +! !================================================================= +! ! Calculate eruptive volcanic emission of SO2. +! !================================================================= +! IF ( LEEV ) THEN +! +! ! Initialize +! ESO2_ev = 0.D0 +! +! ! Loop thru each erupting volcano +! DO K = 1, NEVOL +! +! ! Test to see if the volcano is erupting +! IF ( JDAY < IDAYS(K) .OR. JDAY > IDAYe(K) ) GOTO 20 +! +! !=========================================================== +! ! Define a slab at the top 1/3 of the volcano plume. +! !=========================================================== +! HGHT = DBLE( IHGHT(K) ) +! +! ! slab bottom height +! SLAB1 = HGHT - ( HGHT - DBLE ( IELVe(K) ) ) / 3.d0 +! +! ! Slab thickness +! SLAB = HGHT - SLAB1 +! ZH(0) = 0.d0 +! +! ! Loop over each level +! DO L = 1, LLPAR +! +! ! DZ is the thickness of level L [m] +! DZ(L) = BXHEIGHT(IEV(K),JEV(K),L) +! +! ! ZH is the height of the top edge of +! ! level L, measured from the ground up [m] +! ZH(L) = ZH(L-1) + DZ(L) +! +! ! max model erup.height +! IF ( L == LLPAR .AND. HGHT > ZH(L) ) THEN +! LV2 = LLPAR +! !HGHT = ZH(L) +! !SLAB1 = SLAB1 - ( HGHT - ZH(L) ) +! ENDIF +! +! !======================================================== +! ! If Zh(l) <= bottom of the slab, go to next level. +! !======================================================== +! IF ( ZH(L) <= SLAB1 ) GOTO 22 +! +! !======================================================== +! ! If the slab is only in current level: CASE 1 +! ! ---------------------------------- ZH(L) +! ! HGHT ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ! SLAB1 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ! ---------------------------------- ZH(L-1) +! !======================================================== +! IF ( ZH(L-1) <= SLAB1 .AND. ZH(L) >= HGHT ) THEN +! LV1 = L +! LV2 = L +! DZ(L) = SLAB +! +! !======================================================== +! ! The slab extends more then one level. Find the +! ! lowest (lv1) and the highest (lv2) levels: +! ! --------------------------------- ZH(L) +! ! HGHT ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ! --------------------------------- ZH(L-1) +! ! +! ! --------------------------------- ZH(L) +! ! SLAB1 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ! --------------------------------- ZH(L-1) +! !======================================================== +! ELSE IF (ZH(L-1) <= SLAB1 .AND. ZH(L) > SLAB1) THEN +! LV1 = L +! DZ(L) = ZH(L) - SLAB1 +! +! ELSE IF (ZH(L-1) < HGHT .AND. ZH(L) > HGHT ) THEN +! LV2 = L +! DZ(L) = HGHT - ZH(L-1) +! EXIT ! do 20 +! +! ENDIF +! +! ! Go to next level +! 22 CONTINUE +! ENDDO +! +! !=========================================================== +! ! Calculate SO2 emission in the levels between LV1 and LV2. +! ! Convert Eev from [kg SO2/box/event] to [kg SO2/box/s]. +! ! ESO2_ev is distributed evenly with altitude among the slab. +! !=========================================================== +! DO L = LV1, LV2 +! ESO2_ev(IEV(K),JEV(K),L) = ESO2_ev(IEV(K),JEV(K),L) + +! & EEV(K) / ( (IDAYe(K)-IDAYs(K)+1) * 24.d0 * 3600.d0 ) +! & * DZ(L) / SLAB +! ENDDO +! +! ! Go to next volcano +! 20 CONTINUE +! ENDDO +! +! ENDIF + + !================================================================= + ! Overwrite USA w/ EPA/NEI99 (anthro+biofuel) SO2 emissions + ! Overwrite MEXICO w/ BRAVO (anthro only ) SO2 emissions + ! Overwrite CANADA w/ CAC (anthro only ) SO2 emissions + !----------------------------------------------------------------- + ! Note that we: + ! Overwrite ASIA w/ STREETS and EUROPE w/ EMEP + ! in READ_ANTHRO_SOx. + ! + ! In both cases, SO4 is a fraction of provided SO2 (except for + ! EPA). It is done in READ_ANTHRO_SOX in the 1st case, and in + ! SRCSO4 for inventories dealt with here. EPA is the only one to + ! provide direct SO4, which is why we deal with it here, even + ! though it does not have to be like that. Historical. + ! + ! So, since we have EPA here, we have to deal with BRAVO and + ! CAC here to deal with their overlaping mask. + ! + ! (amv, phs, 3/12/08, 8/24/09) + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, AREA_CM2, AN, BF ) +!$OMP+PRIVATE( HTAP ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + + ! Initialize + AN = 0d0 + BF = 0d0 + + ! Grid box surface area [cm2] + AREA_CM2 = GET_AREA_CM2(J) + + DO I = 1, IIPAR +!------- Prior to 3/8/07 (phs) + !!----------------------------------------------------------- + !! If we are using EPA/NEI99 (anthro + biofuel) ... + !!----------------------------------------------------------- + !IF ( LNEI99 ) THEN + ! + ! ! If we are over the USA ... + ! IF ( GET_USA_MASK( I, J ) > 0d0 ) THEN + ! + ! ! Read EPA/NEI99 SO2 emissions in [molec/cm2/s] + ! AN = GET_EPA_ANTHRO( I, J, IDTSO2, WEEKDAY ) + ! BF = GET_EPA_BIOFUEL(I, J, IDTSO2, WEEKDAY ) + ! + ! ! Convert anthro SO2 from [molec/cm2/s] to [kg/box/s] + ! ! Place all anthro SO2 into surface layer + ! SO2an(I,J,1) = AN * AREA_CM2 / XNUMOL(IDTSO2) + ! SO2an(I,J,2) = 0d0 + ! + ! ! Convert anthro SO2 from [molec/cm2/s] to [kg/box/s] + ! SO2bf(I,J) = BF * AREA_CM2 / XNUMOL(IDTSO2) + ! + ! ELSE + ! + ! ! If we are not over the USA, then just use the regular + ! ! emissions from ESO2_an and ESO2_bf (bmy, 11/16/04) + ! SO2an(I,J,1) = ESO2_an(I,J,1) + ! SO2an(I,J,2) = ESO2_an(I,J,2) + ! SO2bf(I,J) = ESO2_bf(I,J) + ! + ! ENDIF + ! + !ELSE + ! + ! ! If we are not using EPA/NEI99 emissions, then just copy + ! ! ESO2_an and ESO2_bf into local arrays (bmy, 11/16/04) + ! SO2an(I,J,1) = ESO2_an(I,J,1) + ! SO2an(I,J,2) = ESO2_an(I,J,2) + ! SO2bf(I,J) = ESO2_bf(I,J) + ! + !ENDIF + ! + !!----------------------------------------------------------- + !! If we are using BRAVO emissions over Mexico ... + !!----------------------------------------------------------- + !IF ( LBRAVO ) THEN + ! + ! ! If we are over Mexico ... + ! IF ( GET_BRAVO_MASK( I, J ) > 0d0 ) THEN + ! + ! ! Read BRAVO SO2 emissions in [molec/cm2/s] + ! AN = GET_BRAVO_ANTHRO( I, J, IDTSO2 ) + ! + ! ! Convert anthro SO2 from [molec/cm2/s] to [kg/box/s] + ! ! Place all anthro SO2 into surface layer + ! SO2an(I,J,1) = AN * AREA_CM2 / XNUMOL(IDTSO2) + ! SO2an(I,J,2) = 0d0 + ! + ! ELSE + ! + ! ! If we are not over MEXICO, then just use + ! ! the regular emissions from ESO2_an + ! SO2an(I,J,1) = ESO2_an(I,J,1) + ! SO2an(I,J,2) = ESO2_an(I,J,2) + ! + ! ENDIF + ! + !ELSE + ! + ! ! If we are not using BRAVO emissions, then just copy + ! ! ESO2_an and ESO2_bf into local arrays + ! SO2an(I,J,1) = ESO2_an(I,J,1) + ! SO2an(I,J,2) = ESO2_an(I,J,2) + ! SO2bf(I,J) = ESO2_bf(I,J) + ! + !ENDIF + + !----------------------------------------------------------- + ! Default SO2 from GEIA or EDGAR (w/ optional STREETS for + ! ASIA, and EMEP for Europe) + !----------------------------------------------------------- + SO2an(I,J,1) = ESO2_an(I,J,1) + SO2an(I,J,2) = ESO2_an(I,J,2) + SO2bf(I,J) = ESO2_bf(I,J) + + !----------------------------------------------------------- + ! If we are using EPA/NEI99 over the USA (anthro + biofuel) + !----------------------------------------------------------- + IF ( LNEI99 ) THEN + IF ( GET_USA_MASK( I, J ) > 0d0 ) THEN + + ! Read EPA/NEI99 SO2 emissions in [molec/cm2/s] + AN = GET_EPA_ANTHRO( I, J, IDTSO2, WEEKDAY ) + BF = GET_EPA_BIOFUEL(I, J, IDTSO2, WEEKDAY ) + + ! Convert anthro SO2 from [molec/cm2/s] to [kg/box/s] + ! Place all anthro SO2 into surface layer + SO2an(I,J,1) = AN * AREA_CM2 / XNUMOL(IDTSO2) + SO2an(I,J,2) = 0d0 + + ! Convert biofuel SO2 from [molec/cm2/s] to [kg/box/s] + SO2bf(I,J) = BF * AREA_CM2 / XNUMOL(IDTSO2) + + ENDIF + ENDIF + + !----------------------------------------------------------- + ! If we are using BRAVO emissions over Mexico (anthro) + !----------------------------------------------------------- + IF ( LBRAVO ) THEN + IF ( GET_BRAVO_MASK( I, J ) > 0d0 ) THEN + + ! Read BRAVO SO2 emissions in [molec/cm2/s] + AN = GET_BRAVO_ANTHRO( I, J, IDTSO2 ) + + ! Convert anthro SO2 from [molec/cm2/s] to [kg/box/s] + ! Place all anthro SO2 into surface layer. + ! Add to USA emissions if on the border. + IF ( LNEI99 .and. GET_USA_MASK( I, J) > 0d0 ) THEN + + SO2an(I,J,1) = SO2an(I,J,1) + + & AN * AREA_CM2 / XNUMOL(IDTSO2) + ELSE + SO2an(I,J,1) = AN * AREA_CM2 / XNUMOL(IDTSO2) + ENDIF + + SO2an(I,J,2) = 0d0 + + ENDIF + ENDIF + + + !----------------------------------------------------------- + ! If we are using CAC emissions over Canada ... + !----------------------------------------------------------- + IF ( LCAC ) THEN + IF ( GET_CANADA_MASK( I, J ) > 0d0 ) THEN + + ! Read CAC SO2 emissions in [molec/cm2/s] + AN = GET_CAC_ANTHRO( I, J, IDTSO2, + & MOLEC_CM2_s=.TRUE. ) + + ! Convert anthro SO2 from [molec/cm2/s] to [kg/box/s] + ! Place all anthro SO2 into surface layer. + ! Add to USA emissions if on the border. + IF ( LNEI99 .and. GET_USA_MASK( I, J) > 0d0 ) THEN + + SO2an(I,J,1) = SO2an(I,J,1) + + & AN * AREA_CM2 / XNUMOL(IDTSO2) + ELSE + SO2an(I,J,1) = AN * AREA_CM2 / XNUMOL(IDTSO2) + ENDIF + + SO2an(I,J,2) = 0d0 + + ENDIF + ENDIF + + !----------------------------------------------------------- + ! If we are using EPA/NEI 2005 over USA. + ! Must be called after CAC and BRAVO to simply overwrite + ! where they overlap + ! Modify for use with 2-level SO2an (dkh, 02/19/11) + !----------------------------------------------------------- + IF ( LNEI05 ) THEN + IF ( NEI05_MASK( I, J ) > 0d0 ) THEN + + ! Read USA SO2 emissions in [molec/cm2/s] + ! Level L=1 (dkh, 02/19/11) + AN = GET_NEI2005_ANTHRO( I, J, 1, IDTSO2, WEEKDAY, + & MOLEC_CM2_s=.TRUE. ) + + ! Convert anthro SO2 from [molec/cm2/s] to [kg/box/s] + SO2an(I,J,1) = AN * AREA_CM2 / XNUMOL(IDTSO2) + SO2an(I,J,2) = 0d0 + + ! Read USA SO2 emissions in [molec/cm2/s] + DO L = 2, NOXLEVELS + AN = GET_NEI2005_ANTHRO( I, J, L, IDTSO2, WEEKDAY, + & MOLEC_CM2_s=.TRUE. ) + + ! Convert anthro SO2 from [molec/cm2/s] to [kg/box/s] + !SO2an(I,J,L) = AN * AREA_CM2 / XNUMOL(IDTSO2) + SO2an(I,J,2) = SO2an(I,J,2) + & + AN * AREA_CM2 / XNUMOL(IDTSO2) + ENDDO + + + ENDIF + ENDIF + + ! updated to NEI08 +! IF ( LNEI08 .and. .not. LHIST ) THEN + IF ( LNEI08 ) THEN + IF ( NEI08_MASK( I, J ) > 0d0 ) THEN + + SO2an(I,J,:) = 0d0 + + ! Read USA SO2 emissions in [molec/cm2/s] + DO L = 1, NOXLEVELS + + AN = GET_NEI2008_ANTHRO( I, J, L, IH, IDTSO2, WEEKDAY ) + + !fp for compatibility + IF ( L == 1 ) THEN + ! Convert anthro SO2 from [molec/cm2/s] to [kg/box/s] + SO2an(I,J,L) = AN * AREA_CM2 / XNUMOL(IDTSO2) + ELSE + SO2an(I,J,2) = SO2an(I,J,2) + + & AN * AREA_CM2 / XNUMOL(IDTSO2) !put everything in level 2 + ENDIF + + ENDDO + ENDIF + ENDIF + + IF ( LHTAP ) THEN + + DO L = 1, NOXLEVELS + + HTAP = GET_HTAP( I, J, IDTSO2 ) + + IF ( L == 1 ) THEN + ! Convert anthro SO2 from [kg/m2/s] to [kg/box/s] + SO2an(I,J,1) = HTAP * AREA_CM2 * 1d-4 + ELSE +! SO2an(I,J,2) = SO2an(I,J,2) + HTAP(I,J) +! & * AREA_CM2 * 1d-4 + SO2an(I,J,2) = 0d0 + ENDIF + + ENDDO + + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Adjoint of Add SO2 emissions into model levels + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, NTOP, L, SO2, TSO2, FEMIS, SO2SRC ) +!$OMP+PRIVATE( SO2SRC_ADJ, SO2_ADJ, TSO2_ADJ ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Top of the boundary layer + NTOP = CEILING( GET_PBL_TOP_L( I, J ) ) + + DO L = 1, LLPAR + + ! Add SO2 to TC array [kg/box/timestep] + ! fwd code: + !TC(I,J,L) = TC(I,J,L) + ( SO2SRC * DTSRCE ) + ! adj code: + SO2SRC_ADJ = TC_ADJ(I,J,L) * DTSRCE + + ! SO2 emissions [kg/box/s] + ! fwd code: + !SO2SRC = SO2(L) + ESO2_ac(I,J,L) + + ! ESO2_nv(I,J,L) + ESO2_ev(I,J,L) + ! adj code: + SO2_ADJ(L) = SO2SRC_ADJ + ! adj code not implemented yet + ! ESO2_ac_ADJ(I,J,L) = ... etc + + ENDDO + + !=============================================================== + ! Partition the total anthro and biomass SO2 emissions thru + ! the entire boundary layer (if PBL top is higher than level 2) + !=============================================================== + IF ( NTOP > 2 ) THEN + + TSO2_ADJ = 0d0 + + ! Loop thru levels in the PBL + DO L = 1, NTOP + + ! Fraction of PBL spanned by grid box (I,J,L) [unitless] + FEMIS = GET_FRAC_OF_PBL( I, J, L ) + + ! Partition total SO2 into level K + ! fwd_code: + !SO2(L) = FEMIS * TSO2 + ! adj_code: + TSO2_ADJ = TSO2_ADJ + SO2_ADJ(L) * FEMIS + + + ENDDO + + ! Also add SO2 from ship exhaust if necessary (bec, bmy, 5/20/04) + ! fwd code: + !TSO2 = TSO2 + ESO2_sh(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_sh) + ! adj code: + EMS_SF_ADJ(I,J,1,IDADJ_ESO2_sh) = + & EMS_SF_ADJ(I,J,1,IDADJ_ESO2_sh) + ESO2_sh(I,J) * TSO2_ADJ + + ! Sum of anthro (surface + 100m), biomass, biofuel SO2 at (I,J) + ! fwd code: + !TSO2 = SO2an(I,J,1) * EMS_SF(I,J,1,IDADJ_ESO2_an1) + ! + SO2an(I,J,2) * EMS_SF(I,J,1,IDADJ_ESO2_an2) + ! + ESO2_bb(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_bb) + ! + SO2bf(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_bf) + ! adj code: + EMS_SF_ADJ(I,J,1,IDADJ_ESO2_an1) = + & EMS_SF_ADJ(I,J,1,IDADJ_ESO2_an1) + & + SO2an(I,J,1) * TSO2_ADJ + + EMS_SF_ADJ(I,J,1,IDADJ_ESO2_an2) = + & EMS_SF_ADJ(I,J,1,IDADJ_ESO2_an2) + & + SO2an(I,J,2) * TSO2_ADJ + + EMS_SF_ADJ(I,J,1,IDADJ_ESO2_bb) = + & EMS_SF_ADJ(I,J,1,IDADJ_ESO2_bb) + & + ESO2_bb(I,J) * TSO2_ADJ + + EMS_SF_ADJ(I,J,1,IDADJ_ESO2_bf) = + & EMS_SF_ADJ(I,J,1,IDADJ_ESO2_bf) + & + SO2bf(I,J) * TSO2_ADJ + + + !=============================================================== + ! If PBL top occurs lower than or close to the top of level 2, + ! then then surface SO2 goes into level 1 and the smokestack + ! stack SO2 goes into level 2. + !=============================================================== + ELSE + + + ! Also add ship exhaust SO2 into surface if necessary + ! (bec, bmy, 5/20/04) + ! fwd code: + !SO2(1) = SO2(1) + ! + ESO2_sh(I,J) * EMS_SF(I,J,IDADJ_ESO2_sh) + ! adj code: + EMS_SF_ADJ(I,J,1,IDADJ_ESO2_sh) = + & EMS_SF_ADJ(I,J,1,IDADJ_ESO2_sh) + + & ESO2_sh(I,J) * SO2_ADJ(1) + + ! fwd code: + !SO2(1) = SO2an(I,J,1) * EMS_SF(I,J,1,IDADJ_ESO2_an1) + ! + ESO2_bb(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_bb) + ! + SO2bf(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_bf) + !SO2(2) = SO2an(I,J,2) * EMS_SF(I,J,1,IDADJ_ESO2_an2) + ! adj code: + EMS_SF_ADJ(I,J,1,IDADJ_ESO2_an1) = + & EMS_SF_ADJ(I,J,1,IDADJ_ESO2_an1) + + & SO2an(I,J,1) * SO2_ADJ(1) + + EMS_SF_ADJ(I,J,1,IDADJ_ESO2_bb) = + & EMS_SF_ADJ(I,J,1,IDADJ_ESO2_bb) + + & ESO2_bb(I,J) * SO2_ADJ(1) + + EMS_SF_ADJ(I,J,1,IDADJ_ESO2_bf) = + & EMS_SF_ADJ(I,J,1,IDADJ_ESO2_bf) + + & SO2bf(I,J) * SO2_ADJ(1) + + EMS_SF_ADJ(I,J,1,IDADJ_ESO2_an2) = + & EMS_SF_ADJ(I,J,1,IDADJ_ESO2_an2) + + & SO2an(I,J,2) * SO2_ADJ(2) + + + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Optional diagnostic -- sensitivity w.r.t. absolute emissions (dkh, 02/17/11) + IF ( LEMS_ABS ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, NTOP, L, SO2, TSO2, FEMIS, SO2SRC ) +!$OMP+PRIVATE( SO2SRC_ADJ, SO2_ADJ, TSO2_ADJ ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Top of the boundary layer + NTOP = CEILING( GET_PBL_TOP_L( I, J ) ) + + DO L = 1, LLPAR + + ! Add SO2 to TC array [kg/box/timestep] + ! fwd code: + !TC(I,J,L) = TC(I,J,L) + ( SO2SRC * DTSRCE ) + ! adj code: + SO2SRC_ADJ = TC_ADJ(I,J,L) * DTSRCE + + ! SO2 emissions [kg/box/s] + ! fwd code: + !SO2SRC = SO2(L) + ESO2_ac(I,J,L) + + ! ESO2_nv(I,J,L) + ESO2_ev(I,J,L) + ! adj code: + SO2_ADJ(L) = SO2SRC_ADJ + ! adj code not implemented yet + ! ESO2_ac_ADJ(I,J,L) = ... etc + + ENDDO + + !=============================================================== + ! Partition the total anthro and biomass SO2 emissions thru + ! the entire boundary layer (if PBL top is higher than level 2) + !=============================================================== + IF ( NTOP > 2 ) THEN + + TSO2_ADJ = 0d0 + + ! Loop thru levels in the PBL + DO L = 1, NTOP + + ! Fraction of PBL spanned by grid box (I,J,L) [unitless] + FEMIS = GET_FRAC_OF_PBL( I, J, L ) + + ! Partition total SO2 into level K + ! fwd_code: + !SO2(L) = FEMIS * TSO2 + ! adj_code: + TSO2_ADJ = TSO2_ADJ + SO2_ADJ(L) * FEMIS + + + ENDDO + + ! Also add SO2 from ship exhaust if necessary (bec, bmy, 5/20/04) + ! fwd code: + !TSO2 = TSO2 + ESO2_sh(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_sh) + ! adj code: also convert to ( J / kg / box / timestep ) + EMS_ADJ(I,J,1,IDADJ_ESO2_sh) + & = EMS_ADJ(I,J,1,IDADJ_ESO2_sh) + & + TSO2_ADJ / DTSRCE + + ! Sum of anthro (surface + 100m), biomass, biofuel SO2 at (I,J) + ! fwd code: + !TSO2 = SO2an(I,J,1) * EMS_SF(I,J,1,IDADJ_ESO2_an1) + ! + SO2an(I,J,2) * EMS_SF(I,J,1,IDADJ_ESO2_an2) + ! + ESO2_bb(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_bb) + ! + SO2bf(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_bf) + ! adj code: also convert to J / ( kg/box/timestep ) + EMS_ADJ(I,J,1,IDADJ_ESO2_an1) + & = EMS_ADJ(I,J,1,IDADJ_ESO2_an1) + & + TSO2_ADJ / DTSRCE + + EMS_ADJ(I,J,1,IDADJ_ESO2_an2) + & = EMS_ADJ(I,J,1,IDADJ_ESO2_an2) + & + TSO2_ADJ / DTSRCE + + EMS_ADJ(I,J,1,IDADJ_ESO2_bb) + & = EMS_ADJ(I,J,1,IDADJ_ESO2_bb) + & + TSO2_ADJ / DTSRCE + + EMS_ADJ(I,J,1,IDADJ_ESO2_bf) + & = EMS_ADJ(I,J,1,IDADJ_ESO2_bf) + & + TSO2_ADJ / DTSRCE + + + !=============================================================== + ! If PBL top occurs lower than or close to the top of level 2, + ! then then surface SO2 goes into level 1 and the smokestack + ! stack SO2 goes into level 2. + !=============================================================== + ELSE + + + ! Also add ship exhaust SO2 into surface if necessary + ! (bec, bmy, 5/20/04) + ! fwd code: + !SO2(1) = SO2(1) + ! + ESO2_sh(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_sh) + ! adj code: also convert to J / (kg/box/timestep) + EMS_ADJ(I,J,1,IDADJ_ESO2_sh) + & = EMS_ADJ(I,J,1,IDADJ_ESO2_sh) + & + SO2_ADJ(1) / DTSRCE + + ! fwd code: + !SO2(1) = SO2an(I,J,1) * EMS_SF(I,J,1,IDADJ_ESO2_an1) + ! + ESO2_bb(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_bb) + ! + SO2bf(I,J) * EMS_SF(I,J,1,IDADJ_ESO2_bf) + !SO2(2) = SO2an(I,J,2) * EMS_SF(I,J,1,IDADJ_ESO2_an2) + ! adj code: also convert to kg/box/timestep + EMS_ADJ(I,J,1,IDADJ_ESO2_an1) + & = EMS_ADJ(I,J,1,IDADJ_ESO2_an1) + & + SO2_ADJ(1) / DTSRCE + + EMS_ADJ(I,J,1,IDADJ_ESO2_bb) + & = EMS_ADJ(I,J,1,IDADJ_ESO2_bb) + & + SO2_ADJ(1) / DTSRCE + + EMS_ADJ(I,J,1,IDADJ_ESO2_bf) + & = EMS_ADJ(I,J,1,IDADJ_ESO2_bf) + & + SO2_ADJ(1) / DTSRCE + + EMS_ADJ(I,J,1,IDADJ_ESO2_an2) + & = EMS_ADJ(I,J,1,IDADJ_ESO2_an2) + & + SO2_ADJ(2) / DTSRCE + + + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ! Return to calling program + END SUBROUTINE SRCSO2_ADJ + +!------------------------------------------------------------------------------ +! +! FUNCTION GET_OH( I, J, L ) RESULT( OH_MOLEC_CM3 ) +!! +!!****************************************************************************** +!! Function GET_OH returns OH from SMVGEAR's CSPEC array (for coupled runs) +!! or monthly mean OH (for offline runs). Imposes a diurnal variation on +!! OH for offline simulations. (bmy, 12/16/02, 7/20/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1-3) I, J, L (INTEGER) : Grid box indices for lon, lat, vertical level +!! +!! NOTES: +!! (1 ) We assume SETTRACE has been called to define IDOH (bmy, 11/1/02) +!! (2 ) Now use function GET_TS_CHEM from "time_mod.f" (bmy, 3/27/03) +!! (3 ) Now reference ITS_A_FULLCHEM_SIM, ITS_AN_AEROSOL_SIM from +!! "tracer_mod.f". Also replace IJSURF w/ an analytic function. +!! (bmy, 7/20/04) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE COMODE_MOD, ONLY : CSPEC, JLOP +! USE DAO_MOD, ONLY : SUNCOS +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GLOBAL_OH_MOD, ONLY : OH +! USE TIME_MOD, ONLY : GET_TS_CHEM +! USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_AN_AEROSOL_SIM +! USE TRACERID_MOD, ONLY : IDOH +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: I, J, L +! +! ! Local variables +! INTEGER :: JLOOP +! REAL*8 :: OH_MOLEC_CM3 +! +! !================================================================= +! ! GET_OH begins here! +! !================================================================= +! IF ( ITS_A_FULLCHEM_SIM() ) THEN +! +! !--------------------- +! ! Coupled simulation +! !--------------------- +! +! ! JLOOP = SMVGEAR 1-D grid box index +! JLOOP = JLOP(I,J,L) +! +! ! Take OH from the SMVGEAR array CSPEC +! ! OH is defined only in the troposphere +! IF ( JLOOP > 0 ) THEN +! OH_MOLEC_CM3 = CSPEC(JLOOP,IDOH) +! ELSE +! OH_MOLEC_CM3 = 0d0 +! ENDIF +! +! ELSE IF ( ITS_AN_AEROSOL_SIM() ) THEN +! +! !--------------------- +! ! Offline simulation +! !--------------------- +! +! ! 1-D grid box index for SUNCOS +! JLOOP = ( (J-1) * IIPAR ) + I +! +! ! Test for sunlight... +! IF ( SUNCOS(JLOOP) > 0d0 .and. TCOSZ(I,J) > 0d0 ) THEN +! +! ! Impose a diurnal variation on OH during the day +! OH_MOLEC_CM3 = OH(I,J,L) * +! & ( SUNCOS(JLOOP) / TCOSZ(I,J) ) * +! & ( 1440d0 / GET_TS_CHEM() ) +! +! ! Make sure OH is not negative +! OH_MOLEC_CM3 = MAX( OH_MOLEC_CM3, 0d0 ) +! +! ELSE +! +! ! At night, OH goes to zero +! OH_MOLEC_CM3 = 0d0 +! +! ENDIF +! +! ELSE +! +! !--------------------- +! ! Invalid simulation +! !--------------------- +! CALL ERROR_STOP( 'Invalid NSRCX!', 'GET_OH (sulfate_mod.f)') +! +! ENDIF +! +! ! Return to calling program +! END FUNCTION GET_OH +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE SET_OH( I, J, L, OH ) +!! +!!****************************************************************************** +!! Function SET_OH saves the modified OH value back to SMVGEAR's CSPEC array +!! for coupled sulfate/aerosol simulations. (bmy, 12/16/02) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1-3) I, J, L (INTEGER) : Grid box indices for lon, lat, vertical level +!! (4 ) OH (REAL*8 ) : OH at grid box (I,J,L) to be saved into CSPEC +!! +!! NOTES: +!! (1 ) We assume SETTRACE has been called to define IDOH (bmy, 12/16/02) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE COMODE_MOD, ONLY : CSPEC, JLOP +! USE TRACERID_MOD, ONLY : IDOH +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: I, J, L +! REAL*8, INTENT(IN) :: OH +! +! ! Local variables +! INTEGER :: JLOOP +! +! !================================================================= +! ! SET_OH begins here! +! !================================================================= +! +! ! JLOOP = SMVGEAR 1-D grid box index +! JLOOP = JLOP(I,J,L) +! +! ! Replace OH into CSPEC(troposphere only) +! IF ( JLOOP > 0 ) THEN +! CSPEC(JLOOP,IDOH) = OH +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE SET_OH +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_NO3( I, J, L ) RESULT( NO3_MOLEC_CM3 ) +!! +!!****************************************************************************** +!! Function GET_NO3 returns NO3 from SMVGEAR's CSPEC array (for coupled runs) +!! or monthly mean OH (for offline runs). For offline runs, the concentration +!! of NO3 is set to zero during the day. (rjp, bmy, 12/16/02) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1-3) I, J, L (INTEGER) : Grid box indices for lon, lat, vertical level +!! +!! NOTES: +!! (1 ) Now references ERROR_STOP from "error_mod.f". We also assume that +!! SETTRACE has been called to define IDNO3. Now also set NO3 to +!! zero during the day. (rjp, bmy, 12/16/02) +!! (2 ) Now reference ITS_A_FULLCHEM_SIM and ITS_AN_AEROSOL_SIM from +!! "tracer_mod.f". Also remove reference to CMN. Also replace +!! IJSURF with an analytic function. (bmy, 7/20/04) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE COMODE_MOD, ONLY : CSPEC, JLOP +! USE DAO_MOD, ONLY : AD, SUNCOS +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GLOBAL_NO3_MOD, ONLY : NO3 +! USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_AN_AEROSOL_SIM +! USE TRACERID_MOD, ONLY : IDNO3 +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: I, J, L +! +! ! Local variables +! INTEGER :: JLOOP +! REAL*8 :: NO3_MOLEC_CM3 +! +! ! External functions +! REAL*8, EXTERNAL :: BOXVL +! +! !================================================================= +! ! GET_NO3 begins here! +! !================================================================= +! IF ( ITS_A_FULLCHEM_SIM() ) THEN +! +! !-------------------- +! ! Coupled simulation +! !-------------------- +! +! ! 1-D SMVGEAR grid box index +! JLOOP = JLOP(I,J,L) +! +! ! Take NO3 from the SMVGEAR array CSPEC +! ! NO3 is defined only in the troposphere +! IF ( JLOOP > 0 ) THEN +! NO3_MOLEC_CM3 = CSPEC(JLOOP,IDNO3) +! ELSE +! NO3_MOLEC_CM3 = 0d0 +! ENDIF +! +! ELSE IF ( ITS_AN_AEROSOL_SIM() ) THEN +! +! !============================================================== +! ! Offline simulation: Read monthly mean GEOS-CHEM NO3 fields +! ! in [v/v]. Convert these to [molec/cm3] as follows: +! ! +! ! vol NO3 moles NO3 kg air kg NO3/mole NO3 +! ! ------- = --------- * -------- * ---------------- = kg NO3 +! ! vol air moles air 1 kg air/mole air +! ! +! ! And then we convert [kg NO3] to [molec NO3/cm3] by: +! ! +! ! kg NO3 molec NO3 mole NO3 1 molec NO3 +! ! ------ * --------- * -------- * ----- = --------- +! ! 1 mole NO3 kg NO3 cm3 cm3 +! ! ^ ^ +! ! |____________________| +! ! this is XNUMOL_NO3 +! ! +! ! If at nighttime, use the monthly mean NO3 concentration from +! ! the NO3 array of "global_no3_mod.f". If during the daytime, +! ! set the NO3 concentration to zero. We don't have to relax to +! ! the monthly mean concentration every 3 hours (as for HNO3) +! ! since NO3 has a very short lifetime. (rjp, bmy, 12/16/02) +! !============================================================== +! +! ! 1-D grid box index for SUNCOS +! JLOOP = ( (J-1) * IIPAR ) + I +! +! ! Test if daylight +! IF ( SUNCOS(JLOOP) > 0d0 ) THEN +! +! ! NO3 goes to zero during the day +! NO3_MOLEC_CM3 = 0d0 +! +! ELSE +! +! ! At night: Get NO3 [v/v] and convert it to [kg] +! NO3_MOLEC_CM3 = NO3(I,J,L) * AD(I,J,L) * ( 62d0/28.97d0 ) +! +! ! Convert NO3 from [kg] to [molec/cm3] +! NO3_MOLEC_CM3 = NO3_MOLEC_CM3 * XNUMOL_NO3 / BOXVL(I,J,L) +! +! ENDIF +! +! ! Make sure NO3 is not negative +! NO3_MOLEC_CM3 = MAX( NO3_MOLEC_CM3, 0d0 ) +! +! ELSE +! +! !-------------------- +! ! Invalid simulation +! !-------------------- +! CALL ERROR_STOP( 'Invalid NSRCX!','GET_NO3 (sulfate_mod.f)') +! +! ENDIF +! +! ! Return to calling program +! END FUNCTION GET_NO3 +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE SET_NO3( I, J, L, NO3 ) +!! +!!****************************************************************************** +!! Function SET_NO3 saves the modified NO3 value back to SMVGEAR's CSPEC array +!! for coupled lfate/aerosol simulations. (rjp, bmy, 12/16/02, 7/20/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1-3) I, J, L (INTEGER) : Grid box indices for lon, lat, vertical level +!! (4 ) NO3 (REAL*8 ) : OH at grid box (I,J,L) to be saved into CSPEC +!! +!! NOTES: +!! (1 ) We assume SETTRACE has been called to define IDNO3. (bmy, 12/16/02) +!! (2 ) Remove references to "error_mod.f" and CMN (bmy, 7/20/04) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE COMODE_MOD, ONLY : CSPEC, JLOP +! USE TRACERID_MOD, ONLY : IDNO3 +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: I, J, L +! REAL*8, INTENT(IN) :: NO3 +! +! ! Local variables +! INTEGER :: JLOOP +! +! !================================================================= +! ! SET_NO3 begins here! +! !================================================================= +! +! ! 1-D grid box index for CSPEC +! JLOOP = JLOP(I,J,L) +! +! ! Replace OH into CSPEC (troposphere only) +! IF ( JLOOP > 0 ) THEN +! CSPEC(JLOOP,IDNO3) = NO3 +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE SET_NO3 +! +!!------------------------------------------------------------------------------ + + FUNCTION GET_O3( I, J, L ) RESULT( O3_VV ) +! +!****************************************************************************** +! Function GET_O3 returns monthly mean O3 for offline sulfate aerosol +! simulations. (bmy, 12/16/02, 10/25/05) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I, J, L (INTEGER) : Grid box indices for lon, lat, vertical level +! +! NOTES: +! (1 ) We assume SETTRACE has been called to define IDO3. (bmy, 12/16/02) +! (2 ) Now reference inquiry functions from "tracer_mod.f" (bmy, 7/20/04) +! (3 ) Now remove reference to CMN, it's obsolete. (bmy, 8/22/05) +! (4 ) Now references XNUMOLAIR from "tracer_mod.f" (bmy, 10/25/05) +!****************************************************************************** +! + ! References to F90 modules + USE COMODE_MOD, ONLY : CSPEC, JLOP, VOLUME + USE DAO_MOD, ONLY : AIRDEN + USE ERROR_MOD, ONLY : ERROR_STOP + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACERID_MOD, ONLY : IDO3 + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L + + ! Local variables + INTEGER :: JLOOP + REAL*8 :: O3_VV + + !================================================================= + ! GET_O3 begins here! + !================================================================= + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + !-------------------- + ! Coupled simulation + !-------------------- + + ! JLOOP = SMVGEAR 1-D grid box index + JLOOP = JLOP(I,J,L) + + ! Get O3 from CSPEC [molec/cm3] and convert it to [v/v] + ! O3 data will only be defined below the tropopause + IF ( JLOOP > 0 ) THEN + O3_VV = ( CSPEC(JLOOP,IDO3) * 1d6 ) / + & ( AIRDEN(L,I,J) * XNUMOLAIR ) + ELSE + O3_VV = 0d0 + ENDIF + + ELSE IF ( ITS_AN_AEROSOL_SIM() ) THEN + + ! !-------------------- + ! ! Offline simulation + ! !-------------------- + ! + ! ! Get O3 [v/v] for this gridbox & month + ! ! O3 data will only be defined below the tropopause + ! IF ( L <= LLTROP ) THEN + ! O3_VV = O3m(I,J,L) + ! ELSE + ! O3_VV = 0d0 + ! ENDIF + ! + !ELSE + + !-------------------- + ! Invalid simulation + !-------------------- + CALL ERROR_STOP( 'Invalid NSRCX!', + $ 'GET_O3 (sulfate_adj_mod.f)') + + ENDIF + + ! Return to calling program + END FUNCTION GET_O3 + +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_NONERUP_VOLC +!! +!!****************************************************************************** +!! Subroutine READ_NONERUP_VOLC reads SO2 emissions from non-eruptive +!! volcanoes. (rjp, bdf, bmy, 9/19/02, 10/3/05) +!! +!! NOTES: +!! (1 ) Split off from old module routine "sulfate_readyr" (bmy, 9/19/02) +!! (2 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +!! (3 ) Now read files from "sulfate_sim_200508/" (bmy, 7/28/05) +!! (4 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : GET_RES_EXT, GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE FILE_MOD, ONLY : IU_FILE, IOERROR +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Local variables +! INTEGER :: I, IOS, J, K, L +! REAL*8 :: EE +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_NONERUP_VOLC begins here! +! !================================================================= +! +! ! Initialize +! K = 1 +! Env = 0.d0 +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/volcano.con.' // GET_RES_EXT() +! +! !================================================================= +! ! Read NON-eruptive volcanic SO2 emission (GEIA) into Env. +! ! Convert Env from [Mg SO2/box/day] to [kg SO2/box/s]. +! !================================================================= +! +! ! Fancy output +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_NONERUP_VOLC: Reading ', a ) +! +! ! Open file +! OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS ) +! IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'read_nonerup_volc:1' ) +! +! ! Read header lines +! DO L = 1, 2 +! READ( IU_FILE, '(a)', IOSTAT=IOS ) +! IF ( IOS > 0 ) THEN +! CALL IOERROR( IOS, IU_FILE, 'read_nonerup_volc:2' ) +! ENDIF +! ENDDO +! +! ! Read data values +! DO +! READ( IU_FILE, '(49x,i4,e11.3,1x,2i4)', IOSTAT=IOS ) +! & IELVn(k), EE, INV(K), JNV(k) +! +! ! Check for EOF +! IF ( IOS < 0 ) EXIT +! +! ! Trap I/O error +! IF ( IOS > 0 ) THEN +! CALL IOERROR( IOS, IU_FILE, 'read_nonerup_volc:3' ) +! ENDIF +! +! ! Unit conversion: [Mg SO2/box/day] -> [kg SO2/box/s] +! Env(k) = EE * 1000.d0 / ( 24.d0 * 3600.d0 ) +! +! ! Increment counter +! K = K + 1 +! ENDDO +! +! ! Close file +! CLOSE( IU_FILE ) +! +! ! NNVOL = Number of non-eruptive volcanoes +! NNVOL = K - 1 +! +! ! Return to calling program +! END SUBROUTINE READ_NONERUP_VOLC +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_ERUP_VOLC +!! +!!***************************************************************************** +!! Subroutine READ_ERUP_VOLC reads SO2 emissions from eruptive +!! volcanoes. (rjp, bdf, bmy, 9/19/02, 10/3/05) +!! +!! NOTES: +!! (1 ) Split off from old module routine "sulfate_readyr" (bmy, 9/19/02) +!! (2 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +!! (3 ) Now read files from "sulfate_sim_200508/" (bmy, 7/28/05) +!! (4 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!!***************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : GET_RES_EXT, GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE FILE_MOD, ONLY : IU_FILE, IOERROR +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Local variables +! INTEGER :: I, IOS, IUNIT, J, K, L, M +! REAL*8 :: A, B, Fe, X, EE +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================== +! ! READ_ERUP_VOLC begins here +! !================================================================== +! +! ! Initialize +! K = 1 +! Eev(:) = 0.d0 +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/volcano.erup.1990.' // +! & GET_RES_EXT() +! +! !================================================================== +! ! Read eruptive volcanic SO2 emission (based on Smithsonian data +! ! base, SO2 emission and cloud height are a function of VEI. +! ! Data are over-written if TOMS observations are available. +! ! Also define a slab with a thickness of 1/3 of the cloud column, +! ! and SO2 are emitted uniformely within the slab. +! ! +! ! Convert Ee from [kton SO2] to [kg SO2/box] and store in Eev. +! ! ESO2_ev(i,j,l) in [kg SO2/box/s] will be calculated in SRCSO2. +! !================================================================== +! +! ! Fancy output +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_ERUP_VOLC: Reading ', a ) +! +! ! Open file +! OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS ) +! IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'read_erup_volc:1' ) +! +! ! Read header lines +! DO L = 1, 2 +! READ( IU_FILE, '(a)', IOSTAT=IOS ) +! IF ( IOS > 0 ) THEN +! CALL IOERROR( IOS, IU_FILE, 'read_erup_volc:2' ) +! ENDIF +! ENDDO +! +! ! Read data values +! DO +! READ( IU_FILE, '(47x,3i6,6x,i6,es11.3,1x,2i4)', IOSTAT=IOS ) +! & IELVe(K), IDAYs(K), IDAYe(K), IHGHT(K), +! & Ee, IEV(K), JEV(K) +! +! ! Check for EOF +! IF ( IOS < 0 ) EXIT +! +! ! Trap I/O error +! IF ( IOS > 0 ) THEN +! CALL IOERROR( IOS, IU_FILE, 'sulfate_readyr:6' ) +! ENDIF +! +! ! Unit conversion: [kton SO2/box/event] -> [kg SO2/box/event] +! Eev(k) = Ee * 1.d6 +! +! ! Increment count +! K = K + 1 +! ENDDO +! +! ! Close file +! CLOSE( IU_FILE ) +! +! ! NEVOL = Number of eruptive volcanoes +! NEVOL = K - 1 +! +! ! Return to calling program +! END SUBROUTINE READ_ERUP_VOLC +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_ANTHRO_SOx( THISMONTH, NSEASON ) +!! +!!****************************************************************************** +!! Suborutine READ_ANTHRO_SOx reads the anthropogenic SOx from disk, +!! and partitions it into anthropogenic SO2 and SO4. +!! (rjp, bdf, bmy, 9/20/02, 10/31/08) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) THISMONTH (INTEGER) : Current month number (1-12) +!! +!! NOTES: +!! (1 ) Now use functions GET_XMID and GET_YMID to compute lon and lat +!! centers of grid box (I,J). Now replace DXYP(JREF)*1d4 with routine +!! GET_AREA_CM2 of "grid_mod.f". Now use functions GET_MONTH and +!! GET_YEAR of time_mod.f". Now call READ_BPCH2 with QUIET=.TRUE. +!! (bmy, 3/27/03) +!! (2 ) Now references DATA_DIR from "directory_mod.f". Also removed +!! reference to CMN, it's not needed. (bmy, 7/20/04) +!! (3 ) Now read files from "sulfate_sim_200508/". Now read data for both +!! GCAP and GEOS grids (bmy, 8/16/05) +!! (4 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (5 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +!! (6 ) Now computes future SOx emissions (swu, bmy, 5/30/06) +!! (7 ) Now can read either EDGAR or GEIA emissions (avd, bmy, 7/14/06) +!! (8 ) Now overwrite David Streets' SO2, if necessary (yxw, bmy, 8/14/06) +!! (9 ) Now accounts for FSCLYR (phs, 3/17/08) +!! (9 ) Bug fix: Using tracer #30 in the call to GET_STREETS_ANTHRO can cause +!! problems when adding or removing species. Replace w/ IDTNH3. +!! (dkh, 10/31/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE EDGAR_MOD, ONLY : GET_EDGAR_ANTH_SO2 +! USE EMEP_MOD, ONLY : GET_EMEP_ANTHRO +! USE EMEP_MOD, ONLY : GET_EUROPE_MASK +! USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_SO2ff +! USE GRID_MOD, ONLY : GET_XMID, GET_YMID +! USE GRID_MOD, ONLY : GET_AREA_CM2 +! USE LOGICAL_MOD, ONLY : LFUTURE, LEDGARSOx +! USE LOGICAL_MOD, ONLY : LSTREETS, LEMEP +! USE STREETS_ANTHRO_MOD, ONLY : GET_SE_ASIA_MASK +! USE STREETS_ANTHRO_MOD, ONLY : GET_STREETS_ANTHRO +! USE TIME_MOD, ONLY : GET_YEAR +! USE TRACER_MOD, ONLY : XNUMOL +! USE TRACERID_MOD, ONLY : IDTSO2, IDTSO4 +! USE TRANSFER_MOD, ONLY : TRANSFER_2D +! USE SCALE_ANTHRO_MOD, ONLY : GET_ANNUAL_SCALAR +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_O3" ! FSCALYR +! +! ! Arguments +! INTEGER, INTENT(IN) :: THISMONTH, NSEASON +! +! ! Local variables +! INTEGER :: I, J, L, IX, JX, IOS +! INTEGER, SAVE :: LASTYEAR = -99 +! INTEGER :: SCALEYEAR +! REAL*4 :: E_SOx(IGLOB,JGLOB,2) +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*8 :: XTAU, Fe, X, Y, AREA_CM2 +! REAL*8 :: EDG_SO2 +! CHARACTER(LEN=4) :: SYEAR +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_ANTHRO_SOx begins here! +! !================================================================= +! +! IF ( FSCALYR < 0 ) THEN +! SCALEYEAR = GET_YEAR() +! ELSE +! SCALEYEAR = FSCALYR +! ENDIF +! +! +! IF ( LEDGARSOx ) THEN +! +! !============================================================== +! ! Use EDGAR SOx emissions +! ! +! ! Partition SOx into SO2 and SO4, according to the following +! ! fractions (cf Chin et al, 2000): +! ! +! ! Europe [ 36N-78N, 12.5W-60.0E ]: 5.0% of SOx is SO4 +! ! 95.0% of SOx is SO2 +! ! +! ! N. America [ 26N-74N, 167.5W-52.5W ]: 1.4% of SOx is SO4 +! ! 98.6% of SOx is SO2 +! ! +! ! Everywhere else: 3.0% of SOx is SO4 +! ! 97.0% of SOx is SO2 +! !============================================================== +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, X, Y, EDG_SO2, Fe ) +! +! ! Loop over latitudes +! DO J = 1, JJPAR +! +! ! Latitude [degrees] +! Y = GET_YMID( J ) +! +! ! Loop over longitudes +! DO I = 1, IIPAR +! +! ! Longitude [degrees] +! X = GET_XMID( I ) +! +! ! Get EDGAR SO2 emissions [kg/s] +! ! NOTE: Future emissions are already applied! +! EDG_SO2 = GET_EDGAR_ANTH_SO2( I, J, KG_S=.TRUE. ) +! +! ! If we are using David Streets' emissions ... +! IF ( LSTREETS ) THEN +! +! ! If we are over the SE Asia region ... +! IF ( GET_SE_ASIA_MASK( I, J ) > 0d0 ) THEN +! +! ! Overwrite EDGAR SO2 w/ David Streets' [kg SO2/s] +! EDG_SO2 = GET_STREETS_ANTHRO( I, J, +! & IDTSO2, KG_S=.TRUE. ) +! +! ! Streets 2006 includes biofuels. +! IF ( SCALEYEAR >= 2006 ) ESO2_bf(I,J) = 0d0 +! +! ENDIF +! ENDIF +! +! ! If we are using EMEP over Europe... +! IF ( LEMEP ) THEN +! +! IF (GET_EUROPE_MASK(I,J) > 0d0) THEN +! +!!----------------------------------------------------------------------------- +!! Prior to 11/14/08: +!! BUG FIX: Using tracer #26 in the call to GET_EMEP_ANTHRO can cause +!! problems when adding or removing species. Replace w/ IDTSO2. +!! (phs, 11/14/08) +!! EDG_SO2 = GET_EMEP_ANTHRO( I, J, 26, KG_S=.TRUE. ) +!!----------------------------------------------------------------------------- +! EDG_SO2 = GET_EMEP_ANTHRO( I, J, +! $ IDTSO2, KG_S=.TRUE. ) +! +! ENDIF +! +! ENDIF +! +! ! Compute SO4/SOx fraction for EUROPE +! IF ( ( X >= -12.5 .and. X <= 60.0 ) .and. +! & ( Y >= 36.0 .and. Y <= 78.0 ) ) THEN +! Fe = 0.05d0 +! +! ! Compute SO4/SOx fraction for NORTH AMERICA +! ELSE IF ( ( X >= -167.5 .and. X <= -52.5 ) .and. +! & ( Y >= 26.0 .and. Y <= 74.0 ) ) THEN +! Fe = 0.014d0 +! +! ! Compute SO4/SOx fraction for EVERYWHERE ELSE +! ELSE +! Fe = 0.03d0 +! +! ENDIF +! +! ! Store SO2 emission [kg SO2/s] +! ESO2_an(I,J,1) = EDG_SO2 +! ESO4_an(I,J,2) = 0d0 +! +! ! Compute SO4 from SO2 [kg SO4/s] +! ESO4_an(I,J,1) = EDG_SO2 * Fe / ( 1.d0 - Fe ) +! ESO4_an(I,J,2) = 0d0 +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ELSE +! +! !============================================================== +! ! Use GEIA SOx emissions +! !============================================================== +! +! ! Define filename +! FILENAME = TRIM( DATA_DIR ) // +! & 'fossil_200104/merge_nobiofuels.' // +! & GET_NAME_EXT_2D() // '.' // GET_RES_EXT() +! +! ! Echo output +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_ANTHRO_SOx: Reading ', a ) +! +! ! Pick the right TAU value for the given season +! ! Seasons: 1=DJF, 2=MAM, 3=JJA, 4=SON +! SELECT CASE ( NSEASON ) +! CASE ( 1 ) +! XTAU = -744d0 +! CASE ( 2 ) +! XTAU = 1416d0 +! CASE ( 3 ) +! XTAU = 3624d0 +! CASE ( 4 ) +! XTAU = 5832d0 +! END SELECT +! +! ! Read anthropogenic SOx [molec/cm2/s] +! CALL READ_BPCH2( FILENAME, 'ANTHSRCE', 27, +! & XTAU, IGLOB, JGLOB, +! & 2, E_SOx, QUIET=.TRUE. ) +! +! !================================================================= +! ! Read in yearly SO2 scale factors here +! ! (For now we only have 1998, deal w/ other years later) +! !================================================================= +!!-- prior to 3/11/08 +! !IF ( LASTYEAR < 0 ) THEN +! ! +! ! ! put in SOX scale year here (hardwired to 1998 for now) +! ! SYEAR = '1998' +! ! FILENAME = TRIM( DATA_DIR ) // +! !& 'sulfate_sim_200508/scalefoss.SOx.' // +! !& GET_RES_EXT() // '.' // SYEAR +! ! +! ! ! Echo output +! ! WRITE( 6, 100 ) TRIM( FILENAME ) +! ! +! ! ! Get TAU value (use Jan 1, 1998 for scale factors) +! ! XTAU = GET_TAU0( 1, 1, 1998 ) +! ! +! ! ! Read anthropogenic SOx [molec/cm2/s] +! ! CALL READ_BPCH2( FILENAME, 'SCALFOSS', 3, +! !& XTAU, IGLOB, JGLOB, +! !& 1, ARRAY, QUIET=.TRUE. ) +! ! +! ! ! Cast from REAL*4 to REAL*8 +! ! CALL TRANSFER_2D( ARRAY(:,:,1), SOx_SCALE ) +! ! +! ! ! Reset LASTYEAR +! ! LASTYEAR = GET_YEAR() +! !ENDIF +! +! +! ! Get annual scalar factor (amv, 08/24/07) +! CALL GET_ANNUAL_SCALAR( 73, 1985, SCALEYEAR, SOx_SCALE ) +! +! !============================================================== +! ! Partition SOx into SO2 and SO4, according to the following +! ! fractions (cf Chin et al, 2000): +! ! +! ! Europe [ 36N-78N, 12.5W-60.0E ]: 5.0% of SOx is SO4 +! ! 95.0% of SOx is SO2 +! ! +! ! N. America [ 26N-74N, 167.5W-52.5W ]: 1.4% of SOx is SO4 +! ! 98.6% of SOx is SO2 +! ! +! ! Everywhere else: 3.0% of SOx is SO4 +! ! 97.0% of SOx is SO2 +! !============================================================== +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L, AREA_CM2, Y, X, Fe ) +! DO L = 1, 2 +! DO J = 1, JJPAR +! +! ! Grid box surface area [cm2] +! AREA_CM2 = GET_AREA_CM2( J ) +! +! ! Latitude [degrees] +! Y = GET_YMID( J ) +! +! DO I = 1, IIPAR +! +! ! Longitude [degrees] +! X = GET_XMID( I ) +! +! ! First scale SOx to the given fossil fuel year +! E_SOx(I,J,L) = E_SOx(I,J,L) * SOx_SCALE(I,J) +! +! ! Compute future SOx emissions (if necessary) +! IF ( LFUTURE ) THEN +! E_SOx(I,J,L) = E_SOx(I,J,L) * +! & GET_FUTURE_SCALE_SO2ff( I, J ) +! ENDIF +! +! ! Compute SO4/SOx fraction for EUROPE +! IF ( ( X >= -12.5 .and. X <= 60.0 ) .and. +! & ( Y >= 36.0 .and. Y <= 78.0 ) ) THEN +! Fe = 0.05d0 +! +! ! Compute SO4/SOx fraction for NORTH AMERICA +! ELSE IF ( ( X >= -167.5 .and. X <= -52.5 ) .and. +! & ( Y >= 26.0 .and. Y <= 74.0 ) ) THEN +! Fe = 0.014d0 +! +! ! Compute SO4/SOx fraction for EVERYWHERE ELSE +! ELSE +! Fe = 0.03d0 +! +! ENDIF +! +! ! Compute SO2 (tracer #2) from SOx +! ! Convert from [molec SOx/cm2/s] to [kg SO2/box/s] +! ESO2_an(I,J,L) = E_SOx(I,J,L) * ( 1.d0 - Fe ) * +! & AREA_CM2 / XNUMOL(IDTSO2) +! +! ! If we are using David Streets' emissions +! ! Remember: those include BF if Year is GE 2006 +! IF ( LSTREETS ) THEN +! +! ! If we are over the SE Asia region +! IF ( GET_SE_ASIA_MASK( I, J ) > 0d0 ) THEN +! +! ! Overwrite GEIA SO2 w/ David Streets' SO2 [kg SO2/s] +! ESO2_an(I,J,1) = GET_STREETS_ANTHRO( I, J, IDTSO2, +! & KG_S=.TRUE. ) +! +! ! Zero 2nd level of emissions +! ESO2_an(I,J,2) = 0d0 +! +! ENDIF +! ENDIF +! +! IF ( LEMEP ) THEN +! +! IF (GET_EUROPE_MASK(I,J) > 0d0 ) THEN +! +! ESO2_an(I,J,1) = GET_EMEP_ANTHRO( I, J, IDTSO2, +! & KG_S=.TRUE. ) +! +! ESO2_an(I,J,2) = 0d0 +! +! ENDIF +! +! ENDIF +! +!!--- prior 6/23/08 +!! Now calculate SO4 from SO2, since SOx not available with STREETS and EMEP +!! ! Compute SO4 (tracer #3) from SOx +!! ! Convert from [molec SOx/cm2/s] to [kg SO4/box/s] +!! ESO4_an(I,J,L) = E_SOx(I,J,L) * Fe * +!! & AREA_CM2 / XNUMOL(IDTSO4) +! +! ESO4_an(I,J,L) = ESO2_an(I,J,L) * Fe / (1.d0-Fe) +! +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE READ_ANTHRO_SOx +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_OCEAN_DMS( THISMONTH ) +!! +!!***************************************************************************** +!! Subroutine READ_OCEAN_DMS reads seawater concentrations of DMS (nmol/L). +!! (rjp, bdf, bmy, 9/20/02, 10/3/05) +!! +!! Arguments as input: +!! =========================================================================== +!! (1 ) THISMONTH (INTEGER) : Current month number (1-12) +!! +!! NOTES: +!! (1 ) Extracted from old module routine SULFATE_READMON (bmy, 9/18/02) +!! (2 ) Now call READ_BPCH2 with QUIET=.TRUE. (bmy, 3/27/03) +!! (3 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +!! (4 ) Now read files from "sulfate_sim_200508/". Now read data for both +!! GCAP and GEOS grids (bmy, 8/16/05) +!! (5 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!!***************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE TRANSFER_MOD, ONLY : TRANSFER_2D +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: THISMONTH +! +! ! Local variables +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*8 :: XTAU +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================== +! ! READ_OCEAN_DMS begins here! +! !================================================================== +! +! ! File name +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/DMS_seawater.' // +! & GET_NAME_EXT_2D() // '.' // GET_RES_EXT() +! +! ! Echo output +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_OCEAN_DMS: Reading ', a ) +! +! ! TAU value (use generic year 1985) +! XTAU = GET_TAU0( THISMONTH, 1, 1985 ) +! +! ! Read ocean DMS [nmol/L] +! CALL READ_BPCH2( FILENAME, 'BIOGSRCE', 25, +! & XTAU, IGLOB, JGLOB, +! & 1, ARRAY(:,:,1), QUIET=.TRUE. ) +! +! ! Cast from REAL*4 to REAL*8 +! CALL TRANSFER_2D( ARRAY(:,:,1), DMSo ) +! +! ! Return to calling program +! END SUBROUTINE READ_OCEAN_DMS +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_SST( THISMONTH, THISYEAR ) +!! +!!***************************************************************************** +!! Subroutine READ_SST reads monthly mean sea surface temperatures. +!! (rjp, bdf, bmy, 9/18/02, 11/17/05) +!! +!! Arguments as input: +!! =========================================================================== +!! (1 ) THISMONTH (INTEGER) : Current month number (1-12) +!! (2 ) THISYEAR (INTEGER) : Current 4-digit year +!! +!! NOTES: +!! (1 ) Extracted from old module routine SULFATE_READMON (bmy, 9/18/02) +!! (2 ) Now call READ_BPCH2 with QUIET=.TRUE. (bmy, 3/27/03) +!! (3 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +!! (4 ) Now use interannual SST data from NOAA if present; otherwise use +!! climatological SST data. Now read data for both GCAP and GEOS +!! grids (bmy, 8/16/05) +!! (5 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (6 ) Now read int'annual SST data on the GEOS 1x1 grid (bmy, 11/17/05) +!!***************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR, DATA_DIR_1x1 +! USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1 +! USE TRANSFER_MOD, ONLY : TRANSFER_2D +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: THISMONTH, THISYEAR +! +! ! Local variables +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*4 :: ARRAY1(I1x1,J1x1,1) +! REAL*8 :: XTAU +! CHARACTER(LEN=4) :: SYEAR +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================== +! ! READ_SST begins here! +! !================================================================== +! +! IF ( THISYEAR >= 1985 .and. THISYEAR <= 2004 ) THEN +! +! !------------------------------------ +! ! Use interannual SST data from NOAA +! ! Data exists for 1985 - 2004, +! ! Add other years as necessary +! !------------------------------------ +! +! ! Make a string for THISYEAR +! WRITE( SYEAR, '(i4)' ) THISYEAR +! +! ! File name +! FILENAME = TRIM( DATA_DIR_1x1 ) // +! & 'SST_200508/SST.geos.1x1.' // SYEAR +! +! ! Echo output +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_SST: Reading ', a ) +! +! ! TAU value (use this year) +! XTAU = GET_TAU0( THISMONTH, 1, THISYEAR ) +! +! ! Read sea surface temperature [K] +! CALL READ_BPCH2( FILENAME, 'GMAO-2D', 69, +! & XTAU, I1x1, J1x1, +! & 1, ARRAY1(:,:,1), QUIET=.TRUE. ) +! +! ! Regrid from 1x1 and cast to REAL*8 +! CALL DO_REGRID_1x1( 'K', ARRAY1, SSTEMP ) +! +! ELSE +! +! !------------------------------- +! ! Use climatological SST data +! !------------------------------- +! +! ! File name +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/SST.' // GET_NAME_EXT_2D() // +! & '.' // GET_RES_EXT() +! +! ! Echo output +! WRITE( 6, 100 ) TRIM( FILENAME ) +! +! ! TAU value (use generic year 1985) +! XTAU = GET_TAU0( THISMONTH, 1, 1985 ) +! +! ! Read sea surface temperature [K] +! CALL READ_BPCH2( FILENAME, 'DAO-FLDS', 5, +! & XTAU, IGLOB, JGLOB, +! & 1, ARRAY(:,:,1), QUIET=.TRUE. ) +! +! ! Cast from REAL*4 to REAL*8 +! CALL TRANSFER_2D( ARRAY(:,:,1), SSTEMP ) +! +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE READ_SST +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_BIOFUEL_SO2( THISMONTH ) +!! +!!****************************************************************************** +!! Subroutine READ_BIOFUEL_SO2 reads monthly mean biomass burning +!! emissions for SO2. SOx is read in, and converted to SO2. +!! (rjp, bdf, bmy, phs, 1/16/03, 12/23/08) +!! +!! Arguments as input: +!! =========================================================================== +!! (1 ) THISMONTH (INTEGER) : Current month number (1-12) +!! +!! NOTES: +!! (1 ) Extracted from old module routine SULFATE_READMON (bmy, 9/18/02) +!! (2 ) Modified molar ratio of biomass burning SO2 per CO. Added SO2 +!! emission from biofuel burning. (rjp, bmy, 1/16/03) +!! (3 ) Now replace DXYP(J+J0)*1d4 with routine GET_AREA_CM2 of "grid_mod.f" +!! Now replace MONTH with the argument THISMONTH. Now call READ_BPCH2 +!! with QUIET=.TRUE. (bmy, 3/27/03) +!! (4 ) Now references DATA_DIR from "directory_mod.f". Also removed +!! references to CMN and CMN_SETUP. (bmy, 7/20/04) +!! (5 ) Now can read either seasonal or interannual biomass burning emissions. +!! Now references routines from both "logical_mod.f" and "time_mod.f". +!! Now reads SO2 biomass emissions directly rather than computing +!! it by mole fraction from CO. (rjp, bmy, 1/11/05) +!! (6 ) Now read data for both GCAP and GEOS grids (bmy, 8/16/05) +!! (7 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (8 ) Now computes future biomass emissions, if necessary (swu, bmy, 5/30/06) +!! (9 ) Now only read the biofuel, we have moved the biomass-reading code +!! to "gc_biomass_mod.f" for compatibility with GFED2 biomass emissions +!! (bmy, 9/27/06) +!! (10) Now prevent seg fault if BIOMASS emissions are turned off. +!! (bmy, 10/3/06) +!! (11) Renamed READ_BIOFUEL_SO2, and move all biomass code to GET_BIOMASS_SO2 +!! to account for several GFED2 products (yc, phs, 12/23/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BIOMASS_MOD, ONLY : BIOMASS, IDBSO2 +! USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_SO2bf +! USE GRID_MOD, ONLY : GET_AREA_CM2 +! USE LOGICAL_MOD, ONLY : LBIOMASS, LFUTURE +! USE TIME_MOD, ONLY : ITS_A_LEAPYEAR +! USE TRACER_MOD, ONLY : XNUMOL +! USE TRACERID_MOD, ONLY : IDTSO2 +! USE TRANSFER_MOD, ONLY : TRANSFER_2D +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: THISMONTH +! +! ! Local variables +! INTEGER :: I, J, THISYEAR +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*8 :: BIOCO(IIPAR,JJPAR) +!!-- prior 12/23/08 +!! REAL*8 :: CONV, XTAU +! REAL*8 :: XTAU +! CHARACTER(LEN=4 ) :: CYEAR +! CHARACTER(LEN=255) :: FILENAME +! +! ! Days per month +! REAL*8 :: NMDAY(12) = (/ 31d0, 28d0, 31d0, 30d0, 31d0, 30d0, +! & 31d0, 31d0, 30d0, 31d0, 30d0, 31d0/) +! +! !================================================================= +! ! READ_BIOFUEL_SO2 begins here! +! !================================================================= +! +! !================================================================= +! ! Compute biofuel SO2 from biofuel CO. Use a molar +! ! ratio of 0.0015 moles SO2/mole CO from biofuel burning. +! ! (Table 2, [Andreae and Merlet, 2001]) +! !================================================================= +! +! ! File name for biofuel burning file +! FILENAME = TRIM( DATA_DIR ) // +! & 'biofuel_200202/biofuel.' // GET_NAME_EXT_2D() // +! & '.' // GET_RES_EXT() +! +! ! Echo info +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_BIOFUEL_SO2: Reading ', a ) +! +! ! Get TAU0 value (use generic year 1985) +! XTAU = GET_TAU0( 1, 1, 1985 ) +! +! ! Read Biofuel burning of CO [kg/yr] +! CALL READ_BPCH2( FILENAME, 'BIOFSRCE', 4, +! & XTAU, IGLOB, JGLOB, +! & 1, ARRAY(:,:,1), QUIET=.TRUE. ) +! +! ! Cast from REAL*4 to REAL*8 +! CALL TRANSFER_2D( ARRAY(:,:,1), BIOCO ) +! +! !================================================================= +! ! Unit conversion to [kg SO2/s] +! !================================================================= +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!---------------------------------------------------------------------- +!! Prior to 1/28/09: +!! Need to remove CONV from the PRIVATE statement (bmy, 1/28/09) +!!!$OMP+PRIVATE( I, J, CONV ) +!!---------------------------------------------------------------------- +!!$OMP+PRIVATE( I, J ) +! ! Loop over longitudes +! DO J = 1, JJPAR +! +!!-- prior 12/23/08 +!! ! Conversion factor for [cm2 * kg/molec] +!! CONV = GET_AREA_CM2( J ) / XNUMOL(IDTSO2) +! +! ! Loop over latitudes +! DO I = 1, IIPAR +! +!!-- prior 12/23/08 +!! ! Convert biomass SO2 from [molec SO2/cm2/s] -> [kg SO2/s] +!! ! NOTE: Future scale has already been applied by this point +!! IF ( LBIOMASS ) THEN +!! ESO2_bb(I,J) = BIOMASS(I,J,IDBSO2) * CONV +!! ELSE +!! ESO2_bb(I,J) = 0d0 +!! ENDIF +! +! ! Convert biofuel SO2 from [kg CO/yr] to [kg SO2/s] +! ESO2_bf(I,J) = ( BIOCO(I,J) * 64d-3 * 0.0015d0 / +! & ( 28d-3 * 86400.d0 * 365.25d0 ) ) +! +! ! Apply future emissions to biofuel SO2, if necessary +! IF ( LFUTURE ) THEN +! ESO2_bf(I,J) = ESO2_bf(I,J) * +! & GET_FUTURE_SCALE_SO2bf( I, J ) +! ENDIF +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! Return to calling program +! END SUBROUTINE READ_BIOFUEL_SO2 +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE GET_BIOMASS_SO2 +!! +!!****************************************************************************** +!! Subroutine GET_BIOMASS_SO2 retrieve monthly/8-day/3hr biomass burning +!! emissions for SO2. (yc, phs, 12/23/08) +!! +!! Arguments as input: +!! =========================================================================== +!! (1 ) +!! +!! NOTES: +!! (1 ) Extracted from old module subroutine READ_BIOMASS_SO2 +!! (yc, phs, 12/23/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BIOMASS_MOD, ONLY : BIOMASS, IDBSO2 +! USE GRID_MOD, ONLY : GET_AREA_CM2 +! USE TRACER_MOD, ONLY : XNUMOL +! USE TRACERID_MOD, ONLY : IDTSO2 +! USE TRANSFER_MOD, ONLY : TRANSFER_2D +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Local variables +! INTEGER :: I, J +! REAL*8 :: CONV +! +! !================================================================= +! ! GET_BIOMASS_SO2 begins here! +! !================================================================= +! ! Unit conversion to [kg SO2/s] +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, CONV ) +! +! ! Loop over longitudes +! DO J = 1, JJPAR +! +! ! Conversion factor for [cm2 * kg/molec] +! CONV = GET_AREA_CM2( J ) / XNUMOL(IDTSO2) +! +! ! Loop over latitudes +! DO I = 1, IIPAR +! +! ! Convert biomass SO2 from [molec SO2/cm2/s] -> [kg SO2/s] +! ! NOTE: Future scale has already been applied by this point +! ESO2_bb(I,J) = BIOMASS(I,J,IDBSO2) * CONV +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! Return to calling program +! END SUBROUTINE GET_BIOMASS_SO2 +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_AIRCRAFT_SO2( THISMONTH ) +!! +!!****************************************************************************** +!! Subroutine READ_AIRCRAFT_SO2 reads monthly mean aircraft fuel emissions +!! and converts them to SO2 emissions. (rjp, bdf, bmy, 9/18/02, 10/3/05) +!! +!! Arguments as input: +!! =========================================================================== +!! (1 ) THISMONTH (INTEGER) : Current month number (1-12) +!! +!! NOTES: +!! (1 ) Extracted from old module routine SULFATE_READMON (bmy, 9/18/02) +!! (2 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +!! (3 ) Now read files from "sulfate_sim_200508/". Now read data for both +!! GCAP and GEOS grids (bmy, 8/16/05) +!! (4 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!!****************************************************************************** +!! +! ! Reference to F90 modules +! USE BPCH2_MOD, ONLY : GET_RES_EXT, GET_TAU0, READ_BPCH2 +! USE DAO_MOD, ONLY : BXHEIGHT +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE FILE_MOD, ONLY : IU_FILE, IOERROR +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: THISMONTH +! +! ! Local variables +! INTEGER :: I, IOS, J, K, L +! REAL*8 :: ACSO2(IGLOB,JGLOB,20) +! REAL*8 :: FAC, FUEL, DZ(LLPAR), ZH(0:LLPAR) +! CHARACTER(LEN=255) :: FILENAME +! +! ! Month names +! CHARACTER(LEN=3) :: CMONTH(12) = (/'jan', 'feb', 'mar', 'apr', +! & 'may', 'jun', 'jul', 'aug', +! & 'sep', 'oct', 'nov', 'dec'/) +! +! !================================================================= +! ! READ_AIRCRAFT_SO2 begins here! +! !================================================================= +! +! ! Zero arrays +! ESO2_ac = 0d0 +! ACSO2 = 0d0 +! +! ! File name +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/aircraft.' // GET_RES_EXT() // +! & '.1992.' // CMONTH(THISMONTH) +! +! ! Echo output +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_AIRCRAFT_SO2: Reading ', a ) +! +! !================================================================= +! ! Read aircraft emissions. These are fuel burned in [kg/box/day], +! ! from AEAP for 1992. SO2 emission is calculated by assuming +! ! an emission index EI of 1.0, i.e., 1g of SO2 emitted per kg +! ! of fuel burned. It is also assumed that there is no diurnal +! ! variation of emission rate. Convert to [kg SO2/box/s]. +! !================================================================= +! +! ! Open file +! OPEN( IU_FILE, FILE=FILENAME, STATUS='OLD', IOSTAT=IOS ) +! IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'read_aircraft_so2:1' ) +! +! ! Read header line +! READ( IU_FILE, '(/)', IOSTAT=IOS ) +! IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'read_aircraft_so2:2' ) +! +! ! Read data values until an EOF is found +! DO +! READ( IU_FILE, '(3i4,e11.3)', IOSTAT=IOS ) I, J, L, FUEL +! +! ! EOF encountered +! IF ( IOS < 0 ) EXIT +! +! ! I/O error condition +! IF ( IOS > 0 ) THEN +! CALL IOERROR( IOS, IU_FILE, 'read_aircraft_so2:3' ) +! ENDIF +! +! ! Unit conversion: [kg Fuel/box/day] -> [kg SO2/box/s] +! ! Assuming an emission index of 1.0, +! ! 1 g SO2 / kg fuel burned [Weisenstein et al., 1996] +! ACSO2(I,J,L+1) = 1.d-3 * FUEL / ( 24.d0 * 3600d0 ) +! ENDDO +! +! ! Close file +! CLOSE( IU_FILE ) +! +! !================================================================= +! ! Interpolate from the 1-km grid to the given GEOS-CHEM grid +! ! NOTE: we need to account for window grids (bmy, 9/20/02) +! !================================================================= +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! ACSO2 is the aircraft SO2 on the 1-km vertical grid +! FUEL = SUM( ACSO2(I,J,:) ) +! IF ( FUEL < 1d-20 ) CYCLE +! +! ! There are 20 1-km levels +! DO K = 1, 20 +! +! ! Initialize +! ZH(0) = 0.d0 +! +! ! Loop over levels +! DO L = 1, LLPAR +! +! ! Altitude of top edge of level L, from ground [km] +! ZH(L) = ZH(L-1) + ( BXHEIGHT(I,J,L) * 1d-3 ) +! +! IF ( ZH(L-1) > DBLE(K) ) EXIT +! IF ( ZH(L ) < DBLE(K-1) ) CYCLE +! +! IF ( ZH(L) < DBLE(K) ) THEN +! FAC = ZH(L) - MAX( ZH(L-1), DBLE(K-1) ) +! ESO2_ac(I,J,L) = ESO2_ac(I,J,L) + ACSO2(I,J,K) * FAC +! ELSE +! FAC = DBLE(K) - MAX( ZH(L-1), DBLE(K-1) ) +! ESO2_ac(I,J,L) = ESO2_ac(I,J,L) + ACSO2(I,J,K) * FAC +! EXIT +! ENDIF +! ENDDO +! ENDDO +! ENDDO +! ENDDO +! +! ! Return to calling program +! END SUBROUTINE READ_AIRCRAFT_SO2 +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_SHIP_SO2( THISMONTH ) +!! +!!****************************************************************************** +!! Subroutine READ_SHIP_SO2 reads in ship SO2 emissions, from either Corbett +!! et al or EDGAR inventories. (bec, qli, 10/01/03, 7/14/06) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) THISMONTH (INTEGER) : Current month (1-12) +!! +!! NOTES: +!! (1 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +!! (2 ) Now read files from "sulfate_sim_200508/". Now read data for both +!! GCAP and GEOS grids. (bmy, 8/16/05) +!! (3 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (4 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +!! (5 ) Now get EDGAR ship SO2 emissions if necessary. Also apply future +!! emissions scale factors to the default Corbett et al ship emissions. +!! (avd, bmy, 7/14/06) +!! (6 ) Now references GET_ARCTAS_HIP from 'arctas_ship_emiss_mod.f" and +!! GET_EMEP_ANTHRO to get ARCTAS and EMEP SO2 ship emissions (phs, 12/5/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE ARCTAS_SHIP_EMISS_MOD,ONLY : GET_ARCTAS_SHIP +! USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE EDGAR_MOD, ONLY : GET_EDGAR_SHIP_SO2 +! USE EMEP_MOD, ONLY : GET_EMEP_ANTHRO, GET_EUROPE_MASK +! USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_SO2ff +! USE GRID_MOD, ONLY : GET_AREA_CM2 +! USE LOGICAL_MOD, ONLY : LEDGARSHIP, LFUTURE, +! & LARCSHIP, LSHIPSO2, +! $ LEMEPSHIP +! USE TRACER_MOD, ONLY : XNUMOL +! USE TRACERID_MOD, ONLY : IDTSO2 +! USE TRANSFER_MOD, ONLY : TRANSFER_2D +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: THISMONTH +! +! ! Local variables +! INTEGER :: I, J +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*4 :: SHIPSO2(IIPAR,JJPAR) +! REAL*8 :: XTAU, AREA_CM2 +! CHARACTER (LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_SHIP_SO2 begins here! +! !================================================================= +! +! ! Reset +! ESO2_sh = 0D0 +! +! +! ! Test for EDAGR last, since this is default inventory by design. +! ! So we can still use EDGAR SHIP to get ship-NOX and CO, and +! ! overwrite ship-SO2 with ARCTAS or Colbert (phs, 12/5/08) +! +! !----------------------------------------------------------- +! ! Use ARCTAS SHIP emissions (EDGAR 2006 update) +! !----------------------------------------------------------- +! IF ( LARCSHIP ) THEN +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Read ARCTAS SO2 emissions in [kg SO2/BOX/s] +! ESO2_sh(I,J) = GET_ARCTAS_SHIP( I, J, IDTSO2, KG_S=.TRUE. ) +! +! IF ( LEMEPSHIP ) THEN +! IF ( GET_EUROPE_MASK(I,J) > 0d0 ) +! $ ESO2_sh(I,J) = GET_EMEP_ANTHRO(I, J, IDTSO2, +! & KG_S=.TRUE., +! $ SHIP=.TRUE.) +! ENDIF +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! !---------------------------------------- +! ! Or Corbett et al ship SO2 emissions +! !---------------------------------------- +! ELSE IF ( LSHIPSO2 ) THEN +! +! ! Filename +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/shipSOx.' // GET_NAME_EXT_2D() // +! & '.' // GET_RES_EXT() +! +! ! Echo some information to the standard output +! WRITE( 6, 110 ) TRIM( FILENAME ) +! 110 FORMAT( ' - READ_SHIP_SO2 ', a ) +! +! ! TAU value at the beginning of this month +! XTAU = GET_TAU0( THISMONTH, 1, 1985 ) +! +! ! Read in this month's ship SO2 emissions [molec SO2/cm2/s] +! CALL READ_BPCH2( FILENAME, 'SO2-SHIP', 26, +! & XTAU, IIPAR, JJPAR, +! & 1, ARRAY(:,:,1), QUIET=.TRUE. ) +! +! ! Cast from REAL*4 to REAL*8 +! CALL TRANSFER_2D( ARRAY(:,:,1), SHIPSO2 ) +! +! ! Loop over latitudes +! DO J = 1, JJPAR +! +! ! Grid box surface area [cm2] +! AREA_CM2 = GET_AREA_CM2( J ) +! +! ! Loop over longitudes +! DO I = 1, IIPAR +! +! ! Convert [molec SO2/cm2/s] to [kg SO2/box/s] +! ESO2_sh(I,J) = SHIPSO2(I,J) * AREA_CM2 / XNUMOL(IDTSO2) +! +! ! Apply future emissions (if necessary) +! IF ( LFUTURE ) THEN +! ESO2_sh(I,J) = ESO2_sh(I,J) * +! & GET_FUTURE_SCALE_SO2ff( I, J ) +! ENDIF +! +! IF ( LEMEPSHIP ) THEN +! IF ( GET_EUROPE_MASK(I,J) > 0d0 ) +! $ ESO2_sh(I,J) = GET_EMEP_ANTHRO(I, J, IDTSO2, +! $ KG_S=.TRUE., SHIP=.TRUE.) +! ENDIF +! +! ENDDO +! ENDDO +! +! !----------------------------------------------------------- +! ! Test for EDGAR ship emissions +! !----------------------------------------------------------- +! ELSE IF ( LEDGARSHIP ) THEN +! +! !---------------------------------------- +! ! Use EDGAR ship SO2 emissions +! !---------------------------------------- +! +! ! Get EDGAR ship SO2 [kg SO2/box/s] +! ! NOTE: Future emissions have already been applied! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ESO2_sh(I,J) = GET_EDGAR_SHIP_SO2( I, J, KG_S=.TRUE. ) +! +! IF ( LEMEPSHIP ) THEN +! IF ( GET_EUROPE_MASK(I,J) > 0d0 ) +! $ ESO2_sh(I,J) = GET_EMEP_ANTHRO(I, J, IDTSO2, +! & KG_S=.TRUE., +! $ SHIP=.TRUE.) +! ENDIF +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE READ_SHIP_SO2 +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_ANTHRO_NH3( THISMONTH ) +!! +!!****************************************************************************** +!! Subroutine READ_ANTHRO_NH3 reads the monthly mean anthropogenic +!! NH3 emissions from disk and converts to [kg NH3/box/s]. +!! (rjp, bdf, bmy, 9/20/02, 10/31/08) +!! +!! Arguments as input: +!! =========================================================================== +!! (1 ) THISMONTH (INTEGER) : Current month number (1-12) +!! +!! NOTES: +!! (1 ) Renamed from NH3_READ to READ_ANTHRO_NH3. Also updated comments, +!! made cosmetic changes. (bmy, 9/20/02) +!! (2 ) Changed filename to NH3_anthsrce.geos.*. Also now reads data under +!! category name "NH3-ANTH". (rjp, bmy, 3/23/03) +!! (3 ) Now reads from NH3emis.monthly.geos.* files. Now call READ_BPCH2 +!! with QUIET=.TRUE. (bmy, 3/27/03) +!! (4 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +!! (5 ) Now read files from "sulfate_sim_200508/". Now read data for both +!! GCAP and GEOS grids. (bmy, 8/16/05) +!! (5 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (6 ) Now compute future emissions, if necessary (swu, bmy, 5/30/06) +!! (7 ) Now overwrite w/ David Streets' NH3, if necessary (yxw, bmy, 8/17/06) +!! (8 ) Bug fix: Using tracer #30 in the call to GET_STREETS_ANTHRO can cause +!! problems when adding or removing species. Replace w/ IDTNH3. +!! (dkh, 10/31/08) +!! (9 ) Now check if NH3 Streets is available (phs, 12/10/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE EMEP_MOD, ONLY : GET_EMEP_ANTHRO +! USe EMEP_MOD, ONLY : GET_EUROPE_MASK +! USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NH3an +! USE LOGICAL_MOD, ONLY : LFUTURE, LSTREETS +! USE LOGICAL_MOD, ONLY : LEMEP +! USE STREETS_ANTHRO_MOD, ONLY : GET_SE_ASIA_MASK +! USE STREETS_ANTHRO_MOD, ONLY : GET_STREETS_ANTHRO +! USE TRACERID_MOD, ONLY : IDTNH3 +! USE TRANSFER_MOD, ONLY : TRANSFER_2D +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: THISMONTH +! +! ! Local variables +! LOGICAL :: WEEKDAY +! INTEGER :: I, J, DAY_NUM +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*8 :: AREA_CM2, EPA_NEI, XTAU +! REAL*8 :: NMDAY(12) = (/ 31d0, 28d0, 31d0, 30d0, +! & 31d0, 30d0, 31d0, 31d0, +! & 30d0, 31d0, 30d0, 31d0 /) +! CHARACTER(LEN=255) :: FILENAME +! REAL*8 :: STREETS +! +! !================================================================= +! ! READ_ANTHRO_NH3 begins here! +! !================================================================= +! +! ! File name +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/NH3_anthsrce.' // +! & GET_NAME_EXT_2D() // '.' // GET_RES_EXT() +! +! ! Echo output +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_ANTHRO_NH3: Reading ', a ) +! +! ! Get TAU value (use year 1990, the year of the data!) +! XTAU = GET_TAU0( THISMONTH, 1, 1990 ) +! +! ! Read 1990 NH3 emissions [kg N/box/mon] +! CALL READ_BPCH2( FILENAME, 'NH3-ANTH', 29, +! & XTAU, IGLOB, JGLOB, +! & 1, ARRAY(:,:,1), QUIET=.TRUE. ) +! +! ! Cast from REAL*4 to REAL*8 +! CALL TRANSFER_2D( ARRAY(:,:,1), ENH3_an ) +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Convert from [kg N/box/mon] to [kg NH3/box/s] +! ENH3_an(I,J) = ENH3_an(I,J) * ( 17.d0 / 14.d0 ) +! & / ( NMDAY(THISMONTH) * 86400.d0 ) +! +! ! Compute future NH3an emissions, if necessary +! ! Moved here since Streets and EMEP should have already +! ! applied FUTURE scale factors if needed +! IF ( LFUTURE ) THEN +! ENH3_an(I,J) = ENH3_an(I,J) * GET_FUTURE_SCALE_NH3an( I, J ) +! ENDIF +! +! ! If we are using David Streets' emissions ... +! IF ( LSTREETS ) THEN +! +! ! If we are over the SE Asia region ... +! IF ( GET_SE_ASIA_MASK( I, J ) > 0d0 ) THEN +! +! ! Overwrite with David Streets emissions [kg NH3/s] +!!------------------------------------------------------------------------------ +!! Prior to 12/10/08: +!! Now check first that NH3 is available (phs, 12/10/08) +!! ENH3_an(I,J) = GET_STREETS_ANTHRO( I, J, +!! & IDTNH3, KG_S=.TRUE.) +! STREETS = GET_STREETS_ANTHRO( I, J, +! & IDTNH3, KG_S=.TRUE.) +! +! IF ( .not. ( STREETS < 0d0 ) ) +! $ ENH3_an(I,J) = STREETS +! +! ENDIF +! ENDIF +! +! IF ( LEMEP ) THEN +! IF ( GET_EUROPE_MASK(I,J) > 0d0) THEN +! ENH3_an(I,J) = GET_EMEP_ANTHRO(I,J,IDTNH3,KG_S=.TRUE.) +! ENDIF +! ENDIF +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! Return to calling program +! END SUBROUTINE READ_ANTHRO_NH3 +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_NATURAL_NH3( THISMONTH ) +!! +!!****************************************************************************** +!! Subroutine READ_NATURAL_NH3 reads the monthly mean natural +!! NH3 emissions from disk and converts to [kg NH3/box/s]. +!! (rjp, bdf, bmy, 9/20/02, 10/3/05) +!! +!! Arguments as input: +!! =========================================================================== +!! (1 ) THISMONTH (INTEGER) : Current month number (1-12) +!! +!! NOTES: +!! (1 ) Updated FORMAT string. Now also call READ_BPCH2 with QUIET=.TRUE. +!! (bmy, 4/8/03) +!! (2 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +!! (3 ) Now read files from "sulfate_sim_200508/". Now read data for both +!! GCAP and GEOS grids. (bmy, 8/16/05) +!! (4 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE TRANSFER_MOD, ONLY : TRANSFER_2D +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: THISMONTH +! +! ! Local variables +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*8 :: XTAU +! REAL*8 :: NMDAY(12) = (/ 31d0, 28d0, 31d0, 30d0, +! & 31d0, 30d0, 31d0, 31d0, +! & 30d0, 31d0, 30d0, 31d0 /) +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_NATURAL_NH3 begins here! +! !================================================================= +! +! ! File name +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/NH3_natusrce.' // +! & GET_NAME_EXT_2D() // '.' // GET_RES_EXT() +! +! ! Echo output +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_NATURAL_NH3: Reading ', a ) +! +! ! Get TAU value (use year 1990, the year of the data!) +! XTAU = GET_TAU0( THISMONTH, 1, 1990 ) +! +! ! Read 1990 NH3 emissions [kg N/box/mon] +! CALL READ_BPCH2( FILENAME, 'NH3-NATU', 29, +! & XTAU, IGLOB, JGLOB, +! & 1, ARRAY(:,:,1), QUIET=.TRUE. ) +! +! ! Cast from REAL*4 to REAL*8 +! CALL TRANSFER_2D( ARRAY(:,:,1), ENH3_na ) +! +! ! Convert from [kg N/box/mon] to [kg NH3/box/s] +! ENH3_na = ENH3_na * ( 17.d0 / 14.d0 ) / +! & ( NMDAY(THISMONTH) * 86400.d0 ) +! +! ! Return to calling program +! END SUBROUTINE READ_NATURAL_NH3 +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_BIOFUEL_NH3( THISMONTH ) +!! +!!****************************************************************************** +!! Subroutine READ_BIOFUEL_NH3 reads the monthly mean biomass NH3 +!! and biofuel emissions from disk and converts to [kg NH3/box/s]. +!! (rjp, bdf, bmy, phs, 9/20/02, 12/23/08) +!! +!! Arguments as input: +!! =========================================================================== +!! (1 ) THISMONTH (INTEGER) : Current month number (1-12) +!! +!! NOTES: +!! (1 ) Renamed from NH3_READ to READ_BIOMASS_NH3. Also updated comments, +!! made cosmetic changes. Now reads in both biomass and biofuel +!! emissions. (rjp, bmy, 12/13/02) +!! (2 ) Now replace DXYP(J+J0) with routine GET_AREA_M2 of "grid_mod.f" +!! Now use function GET_YEAR from "time_mod.f". Replace MONTH with +!! THISMONTH when referencing the NMDAY variable. Now call READ_BPCH2 +!! with QUIET=.TRUE. (bmy, 3/27/03) +!! (3 ) If using interannual biomass emissions, substitute seasonal emissions +!! for years where internannual emissions do not exist. Now also +!! reference GET_TAU from "time_mod.f" (bmy, 5/15/03) +!! (4 ) Now use ENCODE statement for PGI/F90 on Linux (bmy, 9/29/03) +!! (5 ) Changed cpp switch name from LINUX to LINUX_PGI (bmy, 12/2/03) +!! (6 ) Now references DATA_DIR from "directory_mod.f". Now references LBBSEA +!! from "logical_mod.f". Removed references to CMN and CMN_SETUP. +!! (bmy, 7/20/04) +!! (7 ) Now can read either seasonal or interannual biomass burning emissions. +!! Now references routines from both and "time_mod.f". Now reads SO2 +!! biomass emissions directly rather than computing it by mole fraction +!! from CO. (rjp, bmy, 1/11/05) +!! (8 ) Now read files from "sulfate_sim_200508/". Now read data for both +!! GCAP and GEOS grids. (bmy, 8/16/05) +!! (9 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (10) Now only read the biofuel, we have moved the biomass-reading code to +!! "gc_biomass_mod.f" for compatibility with GFED2 biomass emissions +!! (bmy, 9/27/06) +!! (11) Prevent seg fault error when LBIOMASS=F (bmy, 11/3/06) +!! (12) Renamed READ_BIOFUEL_NH3, and move all biomass code to GET_BIOMASS_NH3 +!! to account for several GFED2 products (yc, phs, 12/23/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BIOMASS_MOD, ONLY : BIOMASS, IDBNH3 +! USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NH3bf +! USE LOGICAL_MOD, ONLY : LBIOMASS, LFUTURE +! USE GRID_MOD, ONLY : GET_AREA_CM2 +! USE TIME_MOD, ONLY : ITS_A_LEAPYEAR +! USE TRACER_MOD, ONLY : XNUMOL +! USE TRACERID_MOD, ONLY : IDTNH3 +! USE TRANSFER_MOD, ONLY : TRANSFER_2D +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: THISMONTH +! +! ! Local variables +! INTEGER :: I, J, THISYEAR +! REAL*4 :: ARRAY(IGLOB,JGLOB,1) +! REAL*8 :: XTAU, DMASS!, CONV +! REAL*8 :: NMDAY(12) = (/31d0, 28d0, 31d0, +! & 30d0, 31d0, 30d0, +! & 31d0, 31d0, 30d0, +! & 31d0, 30d0, 31d0/) +! CHARACTER(LEN=4 ) :: CYEAR +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_BIOFUEL_NH3 begins here! +! !================================================================= +! +! !================================================================= +! ! Read NH3 biofuel emissions +! !================================================================= +! +! ! File name +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/NH3_biofuel.' // +! & GET_NAME_EXT_2D() // '.' // GET_RES_EXT() +! +! ! Echo output +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_BIOFUEL_NH3: Reading ', a ) +! +! ! Get TAU0 value for 1998 +! XTAU = GET_TAU0( THISMONTH, 1, 1998 ) +! +! ! Read NH3 biofuel data [kg NH3/box/month] +! CALL READ_BPCH2( FILENAME, 'BIOFSRCE', 29, +! & XTAU, IGLOB, JGLOB, +! & 1, ARRAY(:,:,1), QUIET=.TRUE. ) +! +! ! Cast from REAL*4 to REAL*8 and resize if necesary +! CALL TRANSFER_2D( ARRAY(:,:,1), ENH3_bf ) +! +! ! Store NH3 in ENH3_bf array [kg NH3/box/s] +! ENH3_bf = ENH3_bf / ( NMDAY(THISMONTH) * 86400.d0 ) +! +! !================================================================= +! ! Convert units and apply IPCC future emissions (if necessary) +! !================================================================= +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!------------------------------------------------------------------ +!! Prior to 1/28/09: +!! Need to remove CONV from the PRIVATE statement (bmy, 1/28/09) +!!!$OMP+PRIVATE( I, J, CONV ) +!!------------------------------------------------------------------ +!!$OMP+PRIVATE( I, J ) +! +! ! Loop over latitudes +! DO J = 1, JJPAR +! +!!-- prior 12/23/08 +!! ! Conversion factor for [cm2 * kg/molec] +!! CONV = GET_AREA_CM2( J ) / XNUMOL(IDTNH3) +! +! ! Loop over longitudes +! DO I = 1, IIPAR +! +!!-- prior 12/23/08 +!! ! Convert biomass NH3 from [molec NH3/cm2/s] -> [kg NH3/s] +!! ! NOTE: Future scale is applied by this point (if necessary) +!! IF ( LBIOMASS ) THEN +!! ENH3_bb(I,J) = BIOMASS(I,J,IDBNH3) * CONV +!! ELSE +!! ENH3_bb(I,J) = 0d0 +!! ENDIF +! +! ! Scale biofuel NH3 to IPCC future scenario (if necessary) +! IF ( LFUTURE ) THEN +! ENH3_bf(I,J) = ENH3_bf(I,J) * +! & GET_FUTURE_SCALE_NH3bf( I, J ) +! ENDIF +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! Return to calling program +! END SUBROUTINE READ_BIOFUEL_NH3 +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE GET_BIOMASS_NH3 +!! +!!****************************************************************************** +!! Subroutine GET_BIOMASS_NH3 retrieve the monthly/8days/3hr mean biomass NH3 +!! (yc, phs, 12/23/08) +!! +!! Arguments as input: +!! =========================================================================== +!! (1 ) +!! +!! NOTES: +!! (1 ) Extracted from old module subroutine READ_BIOMASS_NH3 +!! (yc, phs, 12/23/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BIOMASS_MOD, ONLY : BIOMASS, IDBNH3 +! USE GRID_MOD, ONLY : GET_AREA_CM2 +! USE TRACER_MOD, ONLY : XNUMOL +! USE TRACERID_MOD, ONLY : IDTNH3 +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Local variables +! INTEGER :: I, J +! REAL*8 :: CONV +! +! !================================================================= +! ! READ_BIOMASSBURN_NH3 begins here! +! !================================================================= +! ! Convert units +! +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, CONV ) +! +! ! Loop over latitudes +! DO J = 1, JJPAR +! +! ! Conversion factor for [cm2 * kg/molec] +! CONV = GET_AREA_CM2( J ) / XNUMOL(IDTNH3) +! +! ! Loop over longitudes +! DO I = 1, IIPAR +! +! ! Convert biomass NH3 from [molec NH3/cm2/s] -> [kg NH3/s] +! ! NOTE: Future scale is applied by this point (if necessary) +! ENH3_bb(I,J) = BIOMASS(I,J,IDBNH3) * CONV +! +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! +! ! Return to calling program +! END SUBROUTINE GET_BIOMASS_NH3 +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE READ_OXIDANT( MONTH ) +!! +!!****************************************************************************** +!! Subroutine READ_OXIDANT reads in monthly mean H2O2 and O3 fields for the +!! offline sulfate + aerosol simulation. (rjp, bdf, bmy, 11/1/02, 10/3/05) +!! +!! Arguments as input: +!! ============================================================================ +!! (1 ) MONTH (INTEGER ) : Emission timestep in minutes +!! +!! NOTES: +!! (1 ) Now call READ_BPCH2 with QUIET=.TRUE. (bmy, 3/27/03) +!! (2 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +!! (3 ) Now read files from "sulfate_sim_200508/offline/". Now read data +!! for both GEOS and GCAP grids (bmy, 8/16/05) +!! (4 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT +! USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 +! USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE TRANSFER_MOD, ONLY : TRANSFER_3D_TROP +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: MONTH +! +! ! Local variables +! INTEGER :: I, J, L, K +! REAL*4 :: ARRAY(IGLOB,JGLOB,LLTROP) +! REAL*8 :: XTAU +! CHARACTER(LEN=255) :: FILENAME +! +! !================================================================= +! ! READ_OXIDANT begins here ! +! ! +! ! Oxidant fields were computed for 1998 using coupled aerosol +! ! and gas chemistry GEOS-CHEM by Brendan Field (bdf, 5/23/02). +! ! Bob Yantosca has regridded these fields to all GEOS-CHEM grids. +! ! Data is saved from the surface to the tropopause. +! !================================================================= +! +! ! Use generic year 1985 +! XTAU = GET_TAU0( MONTH, 1, 1985 ) +! +! !================================================================= +! ! Read monthly mean PH2O2 (from HO2 + HO2 = H2O2) [molec/cm3/s] +! !================================================================= +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/offline/PH2O2.' // +! & GET_NAME_EXT() // '.' // GET_RES_EXT() +! +! ! Echo filename +! WRITE( 6, 100 ) TRIM( FILENAME ) +! 100 FORMAT( ' - READ_OXIDANT: Reading ', a ) +! +! ! Read data +! CALL READ_BPCH2( FILENAME, 'PORL-L=$', 5, +! ! limit array 3d dimension to LLTROP_FIX, i.e, case of annual mean +! ! tropopause. This is backward compatibility with +! ! offline data set. +! & XTAU, IGLOB, JGLOB, +! & LLTROP_FIX, ARRAY(:,:,1:LLTROP_FIX), QUIET=.TRUE. ) +!! & XTAU, IGLOB, JGLOB, +!! & LLTROP, ARRAY, QUIET=.TRUE. ) +! +! ! Cast to REAL*8 and resize if necessary +! CALL TRANSFER_3D_TROP( ARRAY, PH2O2m ) +! +! !================================================================= +! ! Read monthly mean O3 [v/v] +! !================================================================= +! FILENAME = TRIM( DATA_DIR ) // +! & 'sulfate_sim_200508/offline/O3.' // +! & GET_NAME_EXT() // '.' // GET_RES_EXT() +! +! ! Echo filename +! WRITE( 6, 100 ) TRIM( FILENAME ) +! +! ! Read data +! ! limit array 3d dimension to LLTROP_FIX, i.e, case of annual mean +! ! tropopause. This is backward compatibility with +! ! offline data set. +! CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 51, +! & XTAU, IGLOB, JGLOB, +! & LLTROP_FIX, ARRAY(:,:,1:LLTROP_FIX), QUIET=.TRUE. ) +!! & XTAU, IGLOB, JGLOB, +!! & LLTROP, ARRAY, QUIET=.TRUE. ) +! +! ! Cast to REAL*8 and resize if necessary +! CALL TRANSFER_3D_TROP( ARRAY, O3m ) +! +! ! Return to calling program +! END SUBROUTINE READ_OXIDANT +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE OHNO3TIME +!! +!!****************************************************************************** +!! Subroutine OHNO3TIME computes the sum of cosine of the solar zenith +!! angle over a 24 hour day, as well as the total length of daylight. +!! This is needed to scale the offline OH and NO3 concentrations. +!! (rjp, bmy, 12/16/02, 3/30/04) +!! +!! NOTES: +!! (1 ) Copy code from COSSZA directly for now, so that we don't get NaN +!! values. Figure this out later (rjp, bmy, 1/10/03) +!! (2 ) Now replace XMID(I) with routine GET_XMID from "grid_mod.f". +!! Now replace RLAT(J) with routine GET_YMID_R from "grid_mod.f". +!! Removed NTIME, NHMSb from the arg list. Now use GET_NHMSb, +!! GET_ELAPSED_SEC, GET_TS_CHEM, GET_DAY_OF_YEAR, GET_GMT from +!! "time_mod.f". (bmy, 3/27/03) +!! (3 ) Now store the peak SUNCOS value for each surface grid box (I,J) in +!! the COSZM array. (rjp, bmy, 3/30/04) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE GRID_MOD, ONLY : GET_XMID, GET_YMID_R +! USE TIME_MOD, ONLY : GET_NHMSb, GET_ELAPSED_SEC +! USE TIME_MOD, ONLY : GET_TS_CHEM, GET_DAY_OF_YEAR, GET_GMT +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_GCTM" +! +! ! Local variables +! LOGICAL, SAVE :: FIRST = .TRUE. +! INTEGER :: I, IJLOOP, J, L, N, NT, NDYSTEP +! REAL*8 :: A0, A1, A2, A3, B1, B2, B3 +! REAL*8 :: LHR0, R, AHR, DEC, TIMLOC, YMID_R +! REAL*8 :: SUNTMP(MAXIJ) +! +! !================================================================= +! ! OHNO3TIME begins here! +! !================================================================= +! +! ! Solar declination angle (low precision formula, good enough for us): +! A0 = 0.006918 +! A1 = 0.399912 +! A2 = 0.006758 +! A3 = 0.002697 +! B1 = 0.070257 +! B2 = 0.000907 +! B3 = 0.000148 +! R = 2.* PI * float( GET_DAY_OF_YEAR() - 1 ) / 365. +! +! DEC = A0 - A1*cos( R) + B1*sin( R) +! & - A2*cos(2*R) + B2*sin(2*R) +! & - A3*cos(3*R) + B3*sin(3*R) +! +! LHR0 = int(float( GET_NHMSb() )/10000.) +! +! ! Only do the following at the start of a new day +! IF ( FIRST .or. GET_GMT() < 1e-5 ) THEN +! +! ! Zero arrays +! TTDAY(:,:) = 0d0 +! TCOSZ(:,:) = 0d0 +! COSZM(:,:) = 0d0 +! +! ! NDYSTEP is # of chemistry time steps in this day +! NDYSTEP = ( 24 - INT( GET_GMT() ) ) * 60 / GET_TS_CHEM() +! +! ! NT is the elapsed time [s] since the beginning of the run +! NT = GET_ELAPSED_SEC() +! +! ! Loop forward through NDYSTEP "fake" timesteps for this day +! DO N = 1, NDYSTEP +! +! ! Zero SUNTMP array +! SUNTMP(:) = 0d0 +! +! ! IJLOOP is the 1-D loop index for SUNCOS +! IJLOOP = 0 +! +! ! Loop over surface grid boxes +! DO J = 1, JJPAR +! +! ! Grid box latitude center [radians] +! YMID_R = GET_YMID_R( J ) +! +! DO I = 1, IIPAR +! +! ! Increment IJLOOP +! IJLOOP = IJLOOP + 1 +! TIMLOC = real(LHR0) + real(NT)/3600.0 + GET_XMID(I)/15.0 +! +! DO WHILE (TIMLOC .lt. 0) +! TIMLOC = TIMLOC + 24.0 +! ENDDO +! +! DO WHILE (TIMLOC .gt. 24.0) +! TIMLOC = TIMLOC - 24.0 +! ENDDO +! +! AHR = abs(TIMLOC - 12.) * 15.0 * PI_180 +! +! !=========================================================== +! ! The cosine of the solar zenith angle (SZA) is given by: +! ! +! ! cos(SZA) = sin(LAT)*sin(DEC) + cos(LAT)*cos(DEC)*cos(AHR) +! ! +! ! where LAT = the latitude angle, +! ! DEC = the solar declination angle, +! ! AHR = the hour angle, all in radians. +! ! +! ! If SUNCOS < 0, then the sun is below the horizon, and +! ! therefore does not contribute to any solar heating. +! !=========================================================== +! +! ! Compute Cos(SZA) +! SUNTMP(IJLOOP) = sin(YMID_R) * sin(DEC) + +! & cos(YMID_R) * cos(DEC) * cos(AHR) +! +! ! TCOSZ is the sum of SUNTMP at location (I,J) +! ! Do not include negative values of SUNTMP +! TCOSZ(I,J) = TCOSZ(I,J) + MAX( SUNTMP(IJLOOP), 0d0 ) +! +! ! COSZM is the peak value of SUMTMP during a day at (I,J) +! ! (rjp, bmy, 3/30/04) +! COSZM(I,J) = MAX( COSZM(I,J), SUNTMP(IJLOOP) ) +! +! ! TTDAY is the total daylight time at location (I,J) +! IF ( SUNTMP(IJLOOP) > 0d0 ) THEN +! TTDAY(I,J) = TTDAY(I,J) + DBLE( GET_TS_CHEM() ) +! ENDIF +! ENDDO +! ENDDO +! +! !### Debug +! !PRINT*, '### IN OHNO3TIME' +! !PRINT*, '### N : ', N +! !PRINT*, '### NDYSTEP : ', NDYSTEP +! !PRINT*, '### NT : ', NT +! !PRINT*, '### JDAY : ', JDAY +! !PRINT*, '### RLAT : ', RLAT +! !PRINT*, '### XMID : ', XMID +! !PRINT*, '### SUNTMP : ', SUNTMP +! !PRINT*, '### TCOSZ : ', MINVAL( TCOSZ ), MAXVAL( TCOSZ ) +! !PRINT*, '### TTDAY : ', MINVAL( TCOSZ ), MAXVAL( TCOSZ ) +! +! ! Increment elapsed time [sec] +! NT = NT + ( GET_TS_CHEM() * 60 ) +! ENDDO +! +! ! Reset first-time flag +! FIRST = .FALSE. +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE OHNO3TIME +! +!!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + + SUBROUTINE GET_O3_ADJ( ADO3, I, J, L ) +! +!****************************************************************************** +! Subroutine GET_O3_ADJ is the adjoint of GET_O3. +! (dkh, 10/12/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) (REAL*8) : Local adjoint of ozone conc +! (2-4) I, J, L (INTEGER) : Grid box indices for lon, lat, vertical level +! +! NOTES: +! (1 ) The only reason we can just add the new value of ADO3 to the pre-existing +! adjoint of ozone is that ADO3 is not involved in any equations in +! ADJ_CHEM_SO2 other than ado3 = ado3 + ... +! Otherwise we would have to initialize ado3 with ADCSPEC, then replace +! ADCSPEC directly here. (dkh, 10/24/05) +! (2 ) Updated to GCv8 adjoint (dkh, 09/28/09) +!****************************************************************************** +! + ! References to F90 modules + USE COMODE_MOD, ONLY : CSPEC, JLOP, VOLUME, CSPEC_ADJ + USE DAO_MOD, ONLY : AIRDEN + USE ERROR_MOD, ONLY : ERROR_STOP + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : XNUMOLAIR + USE TRACERID_MOD, ONLY : IDO3 + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L + REAL*8, INTENT(IN) :: ADO3 + + ! Local variables + INTEGER :: JLOOP + + !================================================================= + ! GET_O3_ADJ begins here! + !================================================================= + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + ! JLOOP = SMVGEAR 1-D grid box index + JLOOP = JLOP(I,J,L) + + ! Add additional sensitivity gleaned from sulfate + ! chemistry to previous adjoint ozone value. + IF ( JLOOP > 0 ) THEN + CSPEC_ADJ(JLOOP,IDO3) = CSPEC_ADJ(JLOOP,IDO3) + + & ( ADO3 * 1d6 ) / ( AIRDEN(L,I,J) * XNUMOLAIR ) + ENDIF + + ELSE IF ( ITS_AN_AEROSOL_SIM() ) THEN + + CALL ERROR_STOP( 'Invalid NSRCX!', + & 'GET_O3_ADJ (sulfate_adj_mod.f)') + + ENDIF + + + ! Return to calling program + END SUBROUTINE GET_O3_ADJ + +!------------------------------------------------------------------------------ + + + SUBROUTINE INIT_SULFATE_ADJ +! +!****************************************************************************** +! Subroutine INIT_ADJ_SULFATE initializes and zeros all allocatable arrays +! declared in "adj_sulfate_mod.f" (dkh, 10/12/05) +! +! NOTES: +! (1 ) Updated for GCv8 adjoint (dkh, 09/28/09) +! +!****************************************************************************** +! + + + ! Reference to f90 modules + USE DRYDEP_MOD, ONLY : DEPNAME, NUMDEP + USE ERROR_MOD, ONLY : ALLOC_ERR + USE LOGICAL_MOD, ONLY : LDRYD + + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: IS_INIT = .FALSE. + INTEGER :: AS, I, J, N, IJLOOP + + !================================================================= + ! INIT_SULFATE_ADJ begins here! + !================================================================= + + ! Return if we have already initialized + IF ( IS_INIT ) RETURN + + ALLOCATE( VCLDF( IIPAR, JJPAR, LLTROP ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'VCLDF' ) + VCLDF = 0d0 + + ALLOCATE( ADPSO4_SO2( IIPAR, JJPAR, LLTROP ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ADPSO4_SO2' ) + ADPSO4_SO2 = 0d0 + + + ! Initialize flags + DRYH2O2 = 0 + DRYSO2 = 0 + DRYSO4 = 0 + DRYSO4s = 0 + DRYMSA = 0 + DRYNH3 = 0 + DRYNH4 = 0 + DRYNIT = 0 + DRYSO4s = 0 + DRYAS = 0 + DRYAHS = 0 + DRYLET = 0 + DRYSO4aq = 0 + DRYNH4aq = 0 + + IF ( LDRYD ) THEN + + ! Locate position of each tracer in DEPSAV + DO N = 1, NUMDEP + SELECT CASE ( TRIM( DEPNAME(N) ) ) + CASE ( 'H2O2' ) + DRYH2O2 = N + CASE ( 'SO2' ) + DRYSO2 = N + CASE ( 'SO4' ) + DRYSO4 = N + CASE ( 'SO4S' ) + DRYSO4s = N + CASE ( 'MSA' ) + DRYMSA = N + CASE ( 'NH3' ) + DRYNH3 = N + CASE ( 'NH4' ) + DRYNH4 = N + CASE ( 'NIT' ) + DRYNIT = N + CASE ( 'NITS' ) + DRYNITs = N + CASE ( 'AS' ) + DRYAS = N + CASE ( 'AHS' ) + DRYAHS = N + CASE ( 'LET' ) + DRYLET = N + CASE ( 'SO4aq' ) + DRYSO4aq = N + CASE ( 'NH4aq' ) + DRYNH4aq = N + CASE DEFAULT + ! Nothing + END SELECT + ENDDO + + ENDIF + + ! Reset IS_INIT so we do not allocate arrays again + IS_INIT = .TRUE. + + ! Return to calling program + END SUBROUTINE INIT_SULFATE_ADJ + +!----------------------------------------------------------------------------- + + SUBROUTINE CLEANUP_SULFATE_ADJ +! +!****************************************************************************** +! Subroutine CLEANUP_SULFATE_ADJ deallocates all previously allocated arrays +! for sulfate emissions -- call at the end of the run (bmy, 6/1/00, 5/3/06) +! +! NOTES: +! (1 ) Updated for GCv8 adjoint (dkh, 09/28/09) +!****************************************************************************** +! + !================================================================= + ! CLEANUP_SULFATE_ADJ begins here! + !================================================================= + IF ( ALLOCATED( ADPSO4_SO2 ) ) DEALLOCATE( ADPSO4_SO2 ) + IF ( ALLOCATED( VCLDF ) ) DEALLOCATE( VCLDF ) + + ! Return to calling program + END SUBROUTINE CLEANUP_SULFATE_ADJ + +!------------------------------------------------------------------------------ + + END MODULE SULFATE_ADJ_MOD diff --git a/code/adjoint/tagged_co_adj_mod.f b/code/adjoint/tagged_co_adj_mod.f new file mode 100644 index 0000000..8a68457 --- /dev/null +++ b/code/adjoint/tagged_co_adj_mod.f @@ -0,0 +1,1744 @@ +!$Id: tagged_co_adj_mod.f,v 1.5 2012/03/01 22:00:26 daven Exp $ + MODULE TAGGED_CO_ADJ_MOD +! +!****************************************************************************** +! Module TAGGED_CO_ADJ_MOD contains variables and routines used for the +! adjoint tagged CO simulation, no tagging (adj_group, 6/08/09) +! +! Module Variables: +! ============================================================================ +! (3 ) SUMISOPCO : Array for production of CO from Isoprene +! (4 ) SUMMONOCO : Array for production of CO from Monoterpenes +! (5 ) SUMCH3OHCO : Array for production of CO from CH3OH (methanol) +! (6 ) SUMACETCO : Array for production of CO from Acetone +! (7 ) EMACET : Array for hold monthly mean acetone emissions +! (8 ) CO_PRODS : Array for P(CO) from CH4 in the stratosphere +! (9 ) CO_LOSSS : Array for L(CO) from CO + OH in the stratosphere +! (10) FMOL_CO : molecular weight of CO +! (11) XNUMOL_CO : molec CO / kg CO +! (12) FMOL_CO : molecular weight of ISOP +! (13) XNUMOL_CO : molec ISOP / kg ISOP +! (14) FMOL_MONO : molecular weight of MONOTERPENES +! (15) XNUMOL_MONO : molec MONOTERPENES / kg MONOTERPENES +! +! Module Routines: +! ============================================================================ +! (3 ) EMISS_TAGGED_CO_ADJ : Adjoint of CO emissions +! (4 ) CHEM__TAGGED_CO_ADJ : Does chemistry for "tagged" CO tracers +! (5 ) GET_ALPHA_ISOP : Returns CO yield from isoprene as f(NOx) +! (6 ) READ_PCO_LCO_STRAT : Reads data into CO_PRODS and CO_LOSSS +! (7 ) GET_PCO_LCO_STRAT : Extracts data from CO_PRODS and CO_LOSSS +! (8 ) READ_ACETONE : Reads biog acetone and acetone from grasslands +! (9 ) INIT_TAGGED_CO_ADJ : Allocates and initializes module arrays +! (10) CLEANUP_TAGGED_CO : Deallocates module arrays +! +! GEOS-CHEM modules referenced by tagged_co_mod.f +! ============================================================================ +! (1 ) biofuel_mod.f : Module w/ routines to read biofuel emissions +! (2 ) biomass_mod.f : Module w/ routines to read biomass emissions +! (3 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (4 ) dao_mod.f : Module w/ arrays for DAO met fields +! (5 ) diag_mod.f : Module w/ GEOS-CHEM diagnostic arrays +! (6 ) diag_pl_mod.f : Module w/ routines for prod & loss diag's +! (7 ) directory_mod.f : Module w/ GEOS-CHEM data & met field dirs +! (8 ) error_mod.f : Module w/ I/O error and NaN check routines +! (9 ) geia_mod : Module w/ routines to read anthro emissions +! (10) global_oh_mod.f : Module w/ routines to read 3-D OH field +! (11) global_nox_mod.f : Module w/ routines to read 3-D NOx field +! (12) grid_mod.f : Module w/ horizontal grid information +! (13) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (14) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (15) time_mod.f : Module w/ routines for computing time & date +! (16) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc. +! (17) tropopause_mod.f : Module w/ routines to read ann mean tropopause +! (18) logical_adj_mod.f: Module w/ adj logical flags +! +! Tagged CO Tracers (you can modify these as needs be!) +! ============================================================================ +! (1 ) Total CO +! (2 ) CO from North American fossil fuel +! (3 ) CO from European fossil fuel +! (4 ) CO from Asian fossil fuel +! (5 ) CO from fossil fuel from everywhere else +! (6 ) CO from South American biomass burning +! (7 ) CO from African biomass burning +! (8 ) CO from Southeast Asian biomass burning +! (9 ) CO from Oceania biomass burning +! (10) CO from European biomass burning +! (11) CO from North American biomass burning +! (12) CO chemically produced from Methane +! (13) CO from Biofuel burning (whole world) +! (14) CO chemically produced from Isoprene +! (15) CO chemically produced from Monoterpenes +! (16) CO chemically produced from Methanol (CH3OH) +! (17) CO chemically produced from Acetone +! +! NOTES: +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "tagged_co_mod.f" + !================================================================= + + ! PRIVATE module variables + PRIVATE BB_REGION, FF_REGION, SUMCH3OHCO + PRIVATE SUMISOPCO, SUMMONOCO, SUMACETCO + PRIVATE CO_PRODS, CO_LOSSS, FMOL_CO, XNUMOL_CO + PRIVATE FMOL_ISOP, XNUMOL_ISOP, FMOL_MONO, XNUMOL_MONO + + !================================================================= + ! MODULE VARIABLES + !================================================================= + INTEGER, ALLOCATABLE :: BB_REGION(:,:) + INTEGER, ALLOCATABLE :: FF_REGION(:,:) + REAL*8, ALLOCATABLE :: SUMCH3OHCO(:,:) + REAL*8, ALLOCATABLE :: SUMISOPCO(:,:) + REAL*8, ALLOCATABLE :: SUMMONOCO(:,:) + REAL*8, ALLOCATABLE :: SUMACETCO(:,:) + REAL*8, ALLOCATABLE :: EMACET(:,:) + REAL*8, ALLOCATABLE :: CO_PRODS(:,:) + REAL*8, ALLOCATABLE :: CO_LOSSS(:,:) + + ! FMOL_CO - kg CO / mole CO + ! XNUMOL_CO - molecules CO / kg CO + REAL*8, PARAMETER :: FMOL_CO = 28d-3 + REAL*8, PARAMETER :: XNUMOL_CO = 6.022d+23/FMOL_CO + + ! FMOL_ISOP - kg ISOP / mole ISOP + ! XNUMOL_ISOP - molecules CO / kg ISOP + REAL*8, PARAMETER :: FMOL_ISOP = 12d-3 + REAL*8, PARAMETER :: XNUMOL_ISOP = 6.022d+23/FMOL_ISOP + + ! FMOL_MONO - kg MONO / mole MONO + ! XNUMOL_MONO - molecules MONO / kg MONO + REAL*8, PARAMETER :: FMOL_MONO = 12d-3 + REAL*8, PARAMETER :: XNUMOL_MONO = 6.022d+23/FMOL_MONO + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE EMISS_TAGGED_CO_ADJ +! +!****************************************************************************** +! Subroutine EMISS_ADJ_TAGGED_CO does adjoint of CO emissions +! (adj_group, 6/08/09) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE BIOFUEL_MOD, ONLY : BIOFUEL + USE BIOMASS_MOD, ONLY : BIOMASS, IDBCO + USE DAO_MOD, ONLY : SUNCOS + USE DIAG_MOD, ONLY : AD29, AD46 + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET, GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LSPLIT, LANTHRO + USE LOGICAL_MOD, ONLY : LBIOMASS, LBIOFUEL + USE PBL_MIX_MOD, ONLY : GET_PBL_MAX_L, GET_FRAC_OF_PBL + USE TIME_MOD, ONLY : GET_MONTH, GET_TAU + USE TIME_MOD, ONLY : GET_YEAR, GET_TS_EMIS + USE TRACER_MOD, ONLY : STT + USE TRACERID_MOD, ONLY : IDBFCO, IDECO + USE ADJ_ARRAYS_MOD, ONLY : ADCOEMS, EMS_SF_ADJ, STT_ADJ + USE LOGICAL_ADJ_MOD, ONLY : LADJ + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + !USE TAGGED_CO_MOD, ONLY : COSF !(zhe 11/28/10) + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! FSCALYR, SCNR89, TODH, EMISTCO, EMISRR +# include "CMN_DIAG" ! Diagnostic arrays & switches + + ! Local variables + LOGICAL, SAVE :: FIRSTEMISS = .TRUE. + INTEGER :: I, J, L, N, I0, J0, M + INTEGER :: AS, IREF, JREF, IJLOOP, PBL_MAX + INTEGER, SAVE :: LASTMONTH = -999 + + ! For now these are defined in CMN_O3 + !REAL*4 :: EMISTCO(IGLOB,JGLOB) + !REAL*4 :: FLIQCO2(IGLOB,JGLOB) + + REAL*8 :: TMMP, EMXX, EMX, EMMO, F_OF_PBL + REAL*8 :: EMAC, E_CO, DTSRCE, AREA_CM2, ED_CO + + ! External functions + REAL*8, EXTERNAL :: XLTMMP, EMISOP, BOXVL + REAL*8, EXTERNAL :: EMMONOT, EMCH3OH + + !================================================================= + ! EMISS_ADJ_TAGGED_CO begins here! + ! + ! Do the following only on the first call to EMISS_ADJ_TAGGED_CO... + !================================================================= + IF ( FIRSTEMISS ) THEN + + ! move initialization to chemistry, since it gets executed + ! first and sometimes without adj emissions (mak, 6/20/09) + ! Allocate all module arrays + !CALL INIT_TAGGED_CO + + ! no tagging in adjoint, feel free to change it (mak, 6/20/09) + ! Define geographic regions for both fossil fuel & biomass burning + !CALL DEFINE_FF_CO_REGIONS( FF_REGION ) + !CALL DEFINE_BB_CO_REGIONS( BB_REGION ) + + ! Set first-time flag to false + FIRSTEMISS = .FALSE. + ENDIF + + ! Move this to chemistry, since it's executed first (mak, 8/28/09) +c$$$ !================================================================= +c$$$ ! Once a month, read acetone from disk. For GEOS-3, also read +c$$$ ! P(CO) from ISOPRENE, MONOTERPENES, and METHANOL from 1996 +c$$$ !================================================================= +c$$$ IF ( GET_MONTH() /= LASTMONTH ) THEN +c$$$ +c$$$ ! Read acetone for this month +c$$$ CALL READ_ACETONE( GET_MONTH() ) +c$$$ +c$$$ ! Save month for next iteration +c$$$ LASTMONTH = GET_MONTH() +c$$$ ENDIF + + ! Determine group (temporal) + M = GET_SCALE_GROUP() + ! Print out scaling info + WRITE(6,*) ' - READ / RESCALE CHEMISTRY: + & use SCALE_GROUP ', M + + ! DTSRCE is the number of seconds per emission timestep + DTSRCE = GET_TS_EMIS() * 60d0 + + ! Get nested-grid offsets + I0 = GET_XOFFSET() + J0 = GET_YOFFSET() + + LSPLIT = .FALSE. + print*, 'For an adjoint run, revert to emissions from v8-01-01' + + !================================================================= + ! Process Anthropogenic (Fossil Fuel) CO emissions + ! + ! Anthropogenic emissions are enhanced by 18.5% below. This + ! accounts for production of CO from oxidation of certain VOC's, + ! which are not explicitly carried by GEOS-CHEM as anthropogenic + ! species. This needs to be done here since a different scale + ! factor is used for the full chemistry run. Also update the + ! ND29 diagnostic below, in order to archive the correct + ! emissions. (bmy, 6/14/01) + ! + ! NOTES: + !================================================================= + ED_CO = 0 + + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + PBL_MAX = GET_PBL_MAX_L() + + IF ( LANTHRO ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, IREF, JREF ) +!!Cleanup code (zhej, dkh, 01/16/12, adj32_017) +!$OMP+PRIVATE( E_CO, F_OF_PBL, ED_CO ) + DO J = 1, JJPAR + JREF = J + J0 + + DO I = 1, IIPAR + IREF = I + I0 + + ! E_CO = Fossil Fuel CO emissions in [molec CO/s] + ! EMISRR is archived in "emissdr.f" (jaf, mak, bmy, 2/14/08) + !------------------------------------------------------------- + ! Prior to 6/30/08: + ! Now use IDECO to be consistent (bmy, 6/30/08) + !E_CO = EMISRR(IREF,JREF,1) + !------------------------------------------------------------- + E_CO = EMISRR(IREF,JREF,IDECO) + + ! Convert from [molec CO/s] to [kg CO] + ! (jaf, mak, bmy, 2/14/08) + E_CO = E_CO * ( DTSRCE / XNUMOL_CO ) + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + ! OLD CODE: + !E_CO = E_CO * COSF(I,J,1) !zhe + ! + !! Add adj FF CO to Tracer #1 -- total CO [kg CO] + !EMS_SF_ADJ(I,J,M,ADCOEMS) = EMS_SF_ADJ(I,J,M,ADCOEMS) + + ! STT_ADJ(I,J,1,1)* E_CO + ! NEW CODE: + DO L = 1, PBL_MAX + + F_OF_PBL = GET_FRAC_OF_PBL(I,J,L) + + EMS_SF_ADJ(I,J,M,ADCOEMS) = EMS_SF_ADJ(I,J,M,ADCOEMS) + & + STT_ADJ(I,J,L,1) * E_CO + & * F_OF_PBL + + ENDDO + + IF(I == IFD .AND. J == JFD .and. LPRINTFD) THEN + PRINT*, 'CO_FF=', E_CO + ED_CO = ED_CO +E_CO + ENDIF + + ! no tagging in adj, feel free to change (mak, 6/20/09) + ! Split FF CO into geographic regions -- Tracers #2 - #5 + !IF ( LSPLIT ) THEN + ! N = FF_REGION(I,J) + ! STT(I,J,1,N) = STT(I,J,1,N) + E_CO + !ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + !================================================================= + ! Process biomass burning CO emissions, stored in array + ! BIOMASS(:,:,IDBCO) which has units of [molec/cm2/s] + ! + ! The default Duncan et al 2001 biomass burning emissions are + ! enhanced by 16.4% within the routines of "gc_biomass_mod.f". + ! This accounts for production of CO from oxidation of certain + ! VOC's, which are not explicitly carried by GEOS-Chem as biomass + ! burning species. The scaling needs to be done in "biomass_mod.f" + ! so that the diagnostics will archive the correct emissions. + ! (bmy, 6/8/01, 9/27/06) + ! + ! GFED2 CO biomass burning emissions are not scaled any further. + ! + ! NOTES: + ! (1) Some forest fires generate strong convection columns. + ! However, we release biomass burning emissions only into + ! the surface layer. (bnd, bmy, 1/3/01) + ! (2) ND29 diagnostics are saved within routine BIOBURN. + ! (bmy, 1/3/01) + !================================================================= + + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + !PBL_MAX = GET_PBL_MAX_L() + + IF ( LBIOMASS ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +! Cleanup code (zhej, dkh, 01/16/12, adj32_017) +!$OMP+PRIVATE( E_CO, I, J, L, F_OF_PBL, N, AREA_CM2, ED_CO ) +!!$OMP+PRIVATE( E_CO, I, J, L, F_OF_PBL, N, AREA_CM2 ) + + + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Grid box surface area [cm2] + AREA_CM2 = GET_AREA_CM2( J ) + + ! Loop over longitudes + DO I = 1, IIPAR + + ! Convert [molec CO/cm2/s] to [kg CO] and store in E_CO + E_CO = ( BIOMASS(I,J,IDBCO) / XNUMOL_CO ) * + & ( AREA_CM2 * DTSRCE ) + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + !E_CO = E_CO * COSF(I,J,1) !zhe + +!--------------------------------------------------------------------------- +! OLD: +! ! Add adj BB CO to Tracer #1 -- total CO [kg CO] +! EMS_SF_ADJ(I,J,M,ADCOEMS) = EMS_SF_ADJ(I,J,M,ADCOEMS) + +! & STT_ADJ(I,J,1,1)* E_CO +! NEW: + DO L = 1, PBL_MAX + + F_OF_PBL = GET_FRAC_OF_PBL (I,J,L) + + ! fwd + !STT(I,J,L,1) = STT(I,J,L,1) + E_CO * F_OF_PBL + ! * EMS_SF(I,J,M,ADCOEMS) + + EMS_SF_ADJ(I,J,M,ADCOEMS) = EMS_SF_ADJ(I,J,M,ADCOEMS) + & + STT_ADJ(I,J,L,1) * E_CO + & * F_OF_PBL + + ENDDO +!--------------------------------------------------------------------------- + + + + IF(I == IFD .AND. J == JFD .and. LPRINTFD) THEN + PRINT*, 'CO_BB=', E_CO + ED_CO = ED_CO +E_CO + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + !================================================================= + ! Process biofuel (formerly wood burning) CO emissions + ! stored in BIOFUEL(IDBCO,IREF,JREF) in [molec/cm3/s] + ! + ! Biofuel burning emissions are enhanced by 18.9% within the + ! routines of "biofuel_mod.f". This accounts for production + ! of CO from oxidation of certain VOC's, which are not explicitly + ! carried by GEOS-CHEM as biofuel burning species. The scaling + ! needs to be done in "biofuel_mod.f" so that the diagnostics + ! will archive the correct emissions. (bmy, 6/8/01) + ! + ! NOTES: + ! (1 ) ND29 diagnostics are saved within routine BIOFUEL_BURN. + ! (bmy, 1/2/01) + ! (2 ) Now use IDBFCO to index the proper element of the + ! biofuel burning array (bmy, 6/8/01). + ! (3 ) Now add biofuel burning to tagged tracer #13 (bmy, 6/14/01) + !================================================================= + IF ( LBIOFUEL ) THEN +! add F_OF_PBL and ED_CO (zhej, dkh, 01/16/12, adj32_017) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( E_CO, I, J, N, ED_CO ) +!$OMP+PRIVATE( F_OF_PBL ) + + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Convert biofuel CO from [molec CO/cm3/s] to [kg CO] + E_CO = BIOFUEL(IDBFCO,I,J) / XNUMOL_CO * + & BOXVL(I,J,1) * DTSRCE + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + ! OLD CODE: + !E_CO = E_CO * COSF(I,J,1) + ! + !! Add adj biofuel CO burning to tracer #1 -- total CO [kg CO] + !EMS_SF_ADJ(I,J,M,ADCOEMS) = EMS_SF_ADJ(I,J,M,ADCOEMS) + + & ! STT_ADJ(I,J,1,1)* E_CO + ! NEW CODE: + DO L = 1, PBL_MAX + + F_OF_PBL = GET_FRAC_OF_PBL(I,J,L) + + EMS_SF_ADJ(I,J,M,ADCOEMS) = EMS_SF_ADJ(I,J,M,ADCOEMS) + & + STT_ADJ(I,J,L,1) * E_CO + & * F_OF_PBL + + ENDDO + + IF(I == IFD .AND. J == JFD .and. LPRINTFD) THEN + PRINT*, 'CO_BF=', E_CO + ED_CO = ED_CO +E_CO + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + IF ( LPRINTFD ) THEN + PRINT*, 'Total Direct CO:', ED_CO + PRINT*, 'EMS_SF_ADJ=', EMS_SF_ADJ(IFD,JFD,M,ADCOEMS) + PRINT*, 'STT_ADJ=', STT_ADJ(IFD,JFD,1,1) + ENDIF + +c$$$ !================================================================= +c$$$ ! Process emissions of ISOPRENE, MONOTERPENES, METHANOL +c$$$ ! and ACETONE -- save into summing arrays for later use +c$$$ !================================================================= +c$$$!$OMP PARALLEL DO +c$$$!$OMP+DEFAULT( SHARED ) +c$$$!$OMP+PRIVATE( I, J, AREA_CM2, IJLOOP, TMMP, EMXX, EMMO, EMAC ) +c$$$ DO J = 1, JJPAR +c$$$ +c$$$ ! Grid box surface area [cm2] +c$$$ AREA_CM2 = GET_AREA_CM2( J ) +c$$$ +c$$$ DO I = 1, IIPAR +c$$$ +c$$$ ! 1-D array index +c$$$ IJLOOP = ( (J-1) * IIPAR ) + I +c$$$ +c$$$ !=========================================================== +c$$$ ! The CO yields from ISOP, MONOTERPENES, and CH3OH will be +c$$$ ! computed in subroutine CHEM_TAGGED_CO. P(CO) from CH3OH +c$$$ ! will be scaled to isoprene emissions within subroutine +c$$$ ! CHEM_TAGGED_CO (bnd, bmy, 6/14/01) +c$$$ !=========================================================== +c$$$ +c$$$ ! Surface air temperature [K] +c$$$ TMMP = XLTMMP(I,J,IJLOOP) +c$$$ +c$$$ ! ISOP and MONOTERPENE emissions in [atoms C/box/time step] +c$$$ ! SUNCOS is COSINE( solar zenith angle ) +c$$$ EMXX = EMISOP( I, J, IJLOOP, SUNCOS, TMMP, XNUMOL_ISOP ) +c$$$ EMMO = EMMONOT( IJLOOP, TMMP, XNUMOL_MONO ) +c$$$ +c$$$ ! Store ISOP and MONOTERPENE emissions [atoms C/box/time step] +c$$$ ! for later use in the subroutine CHEM_TAGGED_CO +c$$$ SUMISOPCO(I,J) = SUMISOPCO(I,J) + EMXX +c$$$ SUMMONOCO(I,J) = SUMMONOCO(I,J) + EMMO +c$$$ +c$$$ ! ND46 -- save biogenic emissions [atoms C/cm2/s] here +c$$$ IF ( ND46 > 0 ) THEN +c$$$ +c$$$ ! Isoprene +c$$$ AD46(I,J,1) = AD46(I,J,1) + ( EMXX / AREA_CM2 / DTSRCE ) +c$$$ +c$$$ ! Monoterpenes +c$$$ AD46(I,J,4) = AD46(I,J,4) + ( EMMO / AREA_CM2 / DTSRCE ) +c$$$ +c$$$ ENDIF +c$$$ +c$$$ !=========================================================== +c$$$ ! For GEOS-1, GEOS-STRAT, GEOS-3, extract acetone emission +c$$$ ! fluxes the EMACET array for the current month +c$$$ !=========================================================== +c$$$ +c$$$ ! EMAC = [atoms C/box/s] from acetone +c$$$ EMAC = EMACET( I, J ) +c$$$ +c$$$ ! Sum acetone loss for use in chemco_decay +c$$$ ! Units = [atoms C/box/timestep] +c$$$ SUMACETCO(I,J) = SUMACETCO(I,J) + (EMAC * DTSRCE * AREA_CM2) +c$$$ +c$$$ ENDDO +c$$$ ENDDO +c$$$!$OMP END PARALLEL DO + + PRINT*, 'MIN/MAX OF EMS_SF_ADJ:', MINVAL(EMS_SF_ADJ), + & MAXVAL(EMS_SF_ADJ) + + ! Return to calling program + END SUBROUTINE EMISS_TAGGED_CO_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_TAGGED_CO_ADJ +! +!****************************************************************************** +! Subroutine CHEM_TAGGED_CO_ADJ performs adj CO chemistry, no tagged +! tracers. Loss is via reaction with OH. +! (adj_group, 6/08/09) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : AD, AIRVOL, T, DELP + USE DIAG_PL_MOD, ONLY : AD65 + USE ERROR_MOD, ONLY : CHECK_VALUE + USE GLOBAL_OH_MOD, ONLY : GET_GLOBAL_OH, OH + USE GLOBAL_NOX_MOD, ONLY : GET_GLOBAL_NOX, BNOX + USE GRID_MOD, ONLY : GET_YMID + USE LOGICAL_MOD, ONLY : LSPLIT + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE TIME_MOD, ONLY : GET_TS_CHEM,GET_MONTH, GET_YEAR + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH, ITS_A_NEW_YEAR + USE TRACER_MOD, ONLY : N_TRACERS + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ, ADCOVOX, STT_ADJ, NNEMS + USE ADJ_ARRAYS_MOD, ONLY : ADCOEMS, IFD, JFD + USE LOGICAL_ADJ_MOD,ONLY : LADJ_EMS, LPRINTFD, LDEVOC !(zhe 11/28/10) + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + !USE TIME_MOD, ONLY : CALC_RUN_DAYS + !USE TAGGED_CO_MOD, ONLY : COSF, GET_CO_CH4!(zhe 11/28/10) + + ! copied from emissions for the acetone parts + USE TIME_MOD, ONLY : GET_MONTH, GET_TS_EMIS + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE DIAG_MOD, ONLY : AD46 + USE DAO_MOD, ONLY : SUNCOS + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND65 + + ! Local variables + LOGICAL, SAVE :: FIRSTCHEM = .TRUE. + INTEGER :: I, J, L, N, MONTH, M + REAL*8 :: ALPHA_CH4, ALPHA_ISOP, ALPHA_MONO + REAL*8 :: DTCHEM, GCO_ADJ, PCO + REAL*8 :: STTCO, KRATE, CH4 + REAL*8 :: CO_CH4, CO_ISOP, CO_MONO + REAL*8 :: CO_CH3OH, CO_OH, CO_ACET, CO_VOC + REAL*8 :: CH4RATE, DENS, ALPHA_ACET + REAL*8 :: CORATE, YMID + + ! For saving CH4 latitudinal gradient + REAL*8, SAVE :: A3090S, A0030S, A0030N, A3090N + + ! External functions + REAL*8, EXTERNAL :: BOXVL + + ! WTAIR = molecular weight of air (g/mole) + REAL*8, PARAMETER :: WTAIR = 28.966d0 + + ! Switch to scale yield of isoprene from NOx concentration or not + LOGICAL, PARAMETER :: ALPHA_ISOP_FROM_NOX = .FALSE. + + ! copied from emissions for the acetone parts + REAL*8 :: AREA_CM2,TMMP, EMXX, EMMO, EMAC, DTSRCE + INTEGER :: IJLOOP + ! External functions + REAL*8, EXTERNAL :: XLTMMP, EMISOP + REAL*8, EXTERNAL :: EMMONOT + INTEGER, SAVE :: LASTMONTH = -999 + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + !INTEGER, SAVE :: TIME_STEPS + ! Avoid array temporaries in CHECK_VALUE + INTEGER :: ERR_LOC(4) + CHARACTER(LEN=255) :: ERR_VAR + CHARACTER(LEN=255) :: ERR_MSG + + !================================================================= + ! CHEM_TAGGED_CO_ADJ begins here! + ! + ! Do the following on the first call to CHEM_TAGGED_CO_ADJ... + !================================================================= + IF ( FIRSTCHEM ) THEN + + ! from emissions, need to allocate arrays here (mak, 6/20/09) + ! Allocate all module arrays + + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + !TIME_STEPS = CALC_RUN_DAYS()*24 + + CALL INIT_TAGGED_CO_ADJ + + FIRSTCHEM = .FALSE. + ENDIF + + !-------------------------------------------------------------------- + ! Reading acetone is now done in chemistry instead of emissions + ! (mak, 8/28/09) + !================================================================= + ! Once a month, read acetone from disk. For GEOS-3, also read + ! P(CO) from ISOPRENE, MONOTERPENES, and METHANOL from 1996 + !================================================================= + IF ( GET_MONTH() /= LASTMONTH ) THEN + + ! Read acetone for this month + CALL READ_ACETONE( GET_MONTH() ) + + ! Save month for next iteration + LASTMONTH = GET_MONTH() + ENDIF + + ! DTSRCE is the number of seconds per emission timestep + DTSRCE = GET_TS_EMIS() * 60d0 + !================================================================= + ! Process emissions of ISOPRENE, MONOTERPENES, METHANOL + ! and ACETONE -- save into summing arrays for later use + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, AREA_CM2, IJLOOP, TMMP, EMXX, EMMO, EMAC ) + DO J = 1, JJPAR + + ! Grid box surface area [cm2] + AREA_CM2 = GET_AREA_CM2( J ) + + DO I = 1, IIPAR + + ! 1-D array index + IJLOOP = ( (J-1) * IIPAR ) + I + + !=========================================================== + ! The CO yields from ISOP, MONOTERPENES, and CH3OH will be + ! computed in subroutine CHEM_TAGGED_CO. P(CO) from CH3OH + ! will be scaled to isoprene emissions within subroutine + ! CHEM_TAGGED_CO (bnd, bmy, 6/14/01) + !=========================================================== + + ! Surface air temperature [K] + TMMP = XLTMMP(I,J,IJLOOP) + + ! ISOP and MONOTERPENE emissions in [atoms C/box/time step] + ! SUNCOS is COSINE( solar zenith angle ) + EMXX = EMISOP( I, J, IJLOOP, SUNCOS, TMMP, XNUMOL_ISOP ) + EMMO = EMMONOT( IJLOOP, TMMP, XNUMOL_MONO ) + + ! Store ISOP and MONOTERPENE emissions [atoms C/box/time step] + ! for later use in the subroutine CHEM_TAGGED_CO + SUMISOPCO(I,J) = SUMISOPCO(I,J) + EMXX + SUMMONOCO(I,J) = SUMMONOCO(I,J) + EMMO + + ! ND46 -- save biogenic emissions [atoms C/cm2/s] here + IF ( ND46 > 0 ) THEN + + ! Isoprene + AD46(I,J,1) = AD46(I,J,1) + ( EMXX / AREA_CM2 / DTSRCE ) + + ! Monoterpenes + AD46(I,J,4) = AD46(I,J,4) + ( EMMO / AREA_CM2 / DTSRCE ) + + ENDIF + + !=========================================================== + ! For GEOS-1, GEOS-STRAT, GEOS-3, extract acetone emission + ! fluxes the EMACET array for the current month + !=========================================================== + + ! EMAC = [atoms C/box/s] from acetone + EMAC = EMACET( I, J ) + + ! Sum acetone loss for use in chemco_decay + ! Units = [atoms C/box/timestep] + SUMACETCO(I,J) = SUMACETCO(I,J) + (EMAC * DTSRCE * AREA_CM2) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! END ACETONE MOVE FROM EMISSIONS + !------------------------------------------------------------------------- + + ! DTCHEM is the chemistry timestep in seconds + DTCHEM = GET_TS_CHEM() * 60d0 + + !================================================================= + ! Read in OH, NOx, P(CO), and L(CO) fields for the current month + !================================================================= + IF ( ITS_A_NEW_MONTH() ) THEN + + ! Get current month + MONTH = GET_MONTH() + + ! Global OH + CALL GET_GLOBAL_OH( MONTH ) + + ! Global NOx -- need this to determine + ! ALPHA_ISOP which is a function of NOx + IF ( ALPHA_ISOP_FROM_NOX ) CALL GET_GLOBAL_NOX( MONTH ) + + ! Read in the loss/production of CO in the stratosphere. + CALL READ_PCO_LCO_STRAT( MONTH ) + ENDIF + + IF ( LADJ_EMS .AND. NNEMS .GT. 1) THEN + + ! Determine group (temporal) + M = GET_SCALE_GROUP() + ! Print out scaling info + WRITE(6,*) ' - READ / RESCALE CHEMISTRY: + & use SCALE_GROUP ', M + ELSE + M = NNEMS + ENDIF + + !================================================================= + ! Get the yearly and latitudinal gradients for CH4 + ! This only needs to be called once per year + ! + ! NOTE: If you are going to run w/ future emissions you must + ! pass the future emissions year to GET_GLOBAL_CH4. + ! See the modification that was made in "chemdr.f" + ! (bmy, 1/24/08) + !================================================================= + IF ( ITS_A_NEW_YEAR() ) THEN + CALL GET_GLOBAL_CH4( GET_YEAR(), .TRUE., + & A3090S, A0030S, A0030N, A3090N ) + ENDIF + + !================================================================= + ! Do tagged CO chemistry -- Put everything within a large + ! DO-loop over all grid boxes to facilitate parallelization + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, STTCO, GCO_ADJ, DENS, CH4RATE, CO_CH4, CH4 ) +!$OMP+PRIVATE( ALPHA_CH4, KRATE, CO_ISOP, CO_CH3OH, ALPHA_ISOP ) +!$OMP+PRIVATE( CO_MONO, ALPHA_MONO, CO_ACET, ALPHA_ACET, CORATE ) +!$OMP+PRIVATE( CO_OH, PCO, YMID, CO_VOC ) + DO J = 1, JJPAR + + ! Latitude of grid box + YMID = GET_YMID( J ) + + DO I = 1, IIPAR + DO L = 1, LLPAR + + !============================================================== + ! (0) Define useful quantities + !============================================================== + + ! STTCO [molec CO/cm3/kg CO] converts [kg CO] --> [molec CO/cm3] + ! kg CO/box * box/cm3 * mole/0.028 kg CO * Avog.#/mole + STTCO = 1d0 / AIRVOL(I,J,L) / 1d6 / FMOL_CO * 6.023d23 + + ! GCO is ADJ CO concentration in [molec CO/cm3]? + GCO_ADJ = STT_ADJ(I,J,L,1) * STTCO + + ! DENS is the number density of air [molec air/cm3] + DENS = AD(I,J,L) * 1000.d0 / BOXVL(I,J,L) * 6.023d23 / WTAIR + + !============================================================== + ! (1a) Production of CO by reaction with CH4 + !============================================================== + + ! Initialize + CO_CH4 = 0d0 + + ! Test level for stratosphere or troposphere + IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN + + !=========================================================== + ! (1a-1) Production of CO from CH4 in the stratosphere + !=========================================================== + + ! Call GET_PCO_LCO_STRAT to get the P(CO) rate from CH4 + CH4RATE = GET_PCO_LCO_STRAT( .TRUE., I, J, L ) + + ! Convert units of CH4RATE from [v/v/s] to [molec CO/cm3] + CO_CH4 = CH4RATE * DTCHEM * DENS + + ELSE + + !=========================================================== + ! (1a-2) Production of CO from CH4 in the troposphere + !=========================================================== + + ! CH4 concentration [ppbv] for the given latitude band + ! (bmy, 1/2/01) + CH4 = A3090S + IF ( YMID >= -30.0 .and. YMID < 0.0 ) CH4 = A0030S + IF ( YMID >= 0.0 .and. YMID < 30.0 ) CH4 = A0030N + IF ( YMID >= 30.0 ) CH4 = A3090N + + ! Convert CH4 from [ppbv] to [molec CH4/cm3] + CH4 = CH4 * 1d-9 * DENS + + ! Yield of CO from CH4: estimated to be 95-100% (acf) + ALPHA_CH4 = 1d0 + + ! Calculate updated rate constant [s-1] (bnd, bmy, 1/2/01) + KRATE = 2.45D-12 * EXP( -1775.d0 / T(I,J,L) ) + + ! Production of CO from CH4 = alpha * k * [CH4] * [OH] * dt + ! Units are [molec CO/cm3] + CO_CH4 = ALPHA_CH4 * KRATE * CH4 * OH(I,J,L) * DTCHEM + + ENDIF + + ! Check CO_CH4 for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'CO_CH4' + ERR_MSG = 'STOP at tagged_co_mod:1' + CALL CHECK_VALUE( CO_CH4, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + !============================================================== + ! (1b) Production of CO from ISOPRENE and METHANOL (CH3OH) + !============================================================== + + ! Initialize + CO_ISOP = 0d0 + CO_CH3OH = 0d0 + + ! Isoprene is emitted only into the surface layer + IF ( L == 1 ) THEN + + !=========================================================== + ! Yield of CO from ISOP: 30%, from Miyoshi et al., 1994. + ! They estimate globally 105 Tg C/yr of CO is produced + ! from isoprene oxidation. + !----------------------------------------------------------- + ! We need to scale the Isoprene flux to get the CH3OH + ! (methanol) flux. Currently, the annual isoprene flux in + ! GEOS-CHEM is ~ 397 Tg C. + ! + ! Daniel Jacob recommends a flux of 100 Tg/yr CO from CH3OH + ! oxidation based on Singh et al. 2000 [JGR 105, 3795-3805] + ! who estimate a global methanol source of 122 Tg yr-1, of + ! which most (75 Tg yr-1) is "primary biogenic". He also + ! recommends for now that the CO flux from CH3OH oxidation + ! be scaled to monthly mean isoprene flux. + ! + ! To get CO from METHANOL oxidation, we must therefore + ! multiply the ISOPRENE flux by the following scale factor: + ! ( 100 Tg CO / 397 Tg C ) * ( 12 g C/mole / 28 g CO/mole ) + !----------------------------------------------------------- + ! We now call GET_ALPHA_ISOP to get the yield factor of + ! CO produced from isoprene, as a function of NOx, or + ! as a constant. (bnd, bmy, 6/14/01) + !=========================================================== + + ! Get CO yield from isoprene + IF ( ALPHA_ISOP_FROM_NOX ) THEN + ALPHA_ISOP = GET_ALPHA_ISOP( .TRUE., BNOX(I,J,L) ) + ELSE + ALPHA_ISOP = GET_ALPHA_ISOP( .FALSE. ) + ENDIF + + ! P(CO) from Isoprene Flux = ALPHA_ISOP * Flux(ISOP) + ! Convert from [molec ISOP/box] to [molec CO/cm3] + ! + ! Units of SUMISOPCO are [atoms C/box/time step]. + ! Division by 5 is necessary to convert to + ! [molec ISOP/box/timestep]. + ! + ! Units of ALPHA_ISOP are [molec CO/molec ISOP] + ! Units of CO_ISOP are [molec CO/cm3] + CO_ISOP = SUMISOPCO(I,J) / BOXVL(I,J,L) / 5.d0 * ALPHA_ISOP + + ! P(CO) from CH3OH is scaled to Isoprene Flux (see above) + ! Units are [molec CO/cm3] + CO_CH3OH = ( SUMISOPCO(I,J) / BOXVL(I,J,L) ) * + & ( 100d0 / 397d0 ) * + & ( 12d0 / 28d0 ) + + ! Zero SUMISOPCO and SUMCH3OHCO for the next emission step + SUMISOPCO(I,J) = 0d0 + SUMCH3OHCO(I,J) = 0d0 + + ! Check CO_ISOP for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'CO_ISOP' + ERR_MSG = 'STOP at tagged_co_mod:2' + CALL CHECK_VALUE( CO_ISOP, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + ! Check CO_CH3OH for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'CO_CH3OH' + ERR_MSG = 'STOP at tagged_co_mod:3' + CALL CHECK_VALUE( CO_CH3OH, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + + ENDIF + + !============================================================== + ! (1c) Production of CO from MONOTERPENE oxidation + !============================================================== + + ! Initialize + CO_MONO = 0.d0 + + ! Monoterpenes are emitted only into the surface layer + IF ( L == 1 ) THEN + + !=========================================================== + ! Assume the production of CO from monoterpenes is + ! instantaneous even though the lifetime of intermediate + ! species may be on the order of hours or days. This + ! assumption will likely cause CO from monoterpene + ! oxidation to be too high in the box in which the + ! monoterpene is emitted. + !----------------------------------------------------------- + ! The CO yield here is taken from: + ! Hatakeyama et al. JGR, Vol. 96, p. 947-958 (1991) + ! Vinckier et al. Fresenius Env. Bull., Vol. 7, p.361-368 + ! (1998) + ! + ! Hatakeyama: "The ultimate yield of CO from the + ! tropospheric oxidation of terpenes (including both O3 + ! and OH reactions) was estimated to be 20% on the carbon + ! number basis." They studied ALPHA- & BETA-pinene. + ! + ! Vinckier : "R(CO)=1.8+/-0.3" : 1.8/10 is about 20%. + !----------------------------------------------------------- + ! Calculate source of CO per time step from monoterpene + ! flux (assume lifetime very short) using the C number basis: + ! + ! CO [molec CO/cm3] = Flux [atoms C from MONO/box] / + ! Grid Box Volume [cm^-3] * + ! ALPHA_MONO + ! + ! where ALPHA_MONO = 0.2 as explained above. + !=========================================================== + + ! Yield of CO from MONOTERPENES: 20% (see above) + ALPHA_MONO = 0.20d0 + + ! P(CO) from Monoterpene Flux = alpha * Flux(Mono) + ! Units are [molec CO/cm3] + CO_MONO = ( SUMMONOCO(I,J) / BOXVL(I,J,L) ) * ALPHA_MONO + + ! Zero SUMMONOCO for the next emission step + SUMMONOCO(I,J) = 0d0 + + ! Check CO_MONO for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'CO_MONO' + ERR_MSG = 'STOP at tagged_co_mod:4' + CALL CHECK_VALUE( CO_MONO, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + ENDIF + + !============================================================== + ! (1d) Production of CO from oxidation of ACETONE + ! + ! ALPHA_ACET = 2/3 to get a yield for CO. This accounts + ! for acetone loss from reaction with OH And photolysis. + ! The acetone sources taken into account are: + ! + ! (a) Primary emissions of acetone from biogenic sources + ! (b) Secondary production of acetone from monoterpene + ! oxidation + ! (c) Secondary production of acetone from ALK4 and + ! propane oxidation + ! (d) Direct emissions of acetone from biomass burning and + ! fossil fuels + ! (e) direct emissions from ocean + ! + ! Calculate source of CO per time step from biogenic acetone + ! # molec CO/cc = ALPHA * ACET Emission Rate * dt + !============================================================== + + ! Initialize + CO_ACET = 0.d0 + + ! Biogenic acetone sources are emitted only into the surface layer + IF ( L == 1 ) THEN + + ! Yield of CO from ACETONE: 2/3 (see above) + ALPHA_ACET = 2.D0 / 3.D0 + + ! Units are [molec CO/cc] + CO_ACET = SUMACETCO(I,J) / BOXVL(I,J,L) * ALPHA_ACET + + ! Zero SUMACETCO for the next emission step + SUMACETCO(I,J) = 0d0 + + ! Check CO_ACET for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'CO_ACET' + ERR_MSG = 'STOP at tagged_co_mod:5' + CALL CHECK_VALUE( CO_ACET, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + ENDIF + + !============================================================== + ! (1e) Add production of CO into the following tagged tracers: + ! + ! (a) Tracer #12: CO produced from CH4 + ! (b) Tracer #14: CO produced from ISOPRENE + ! (c) Tracer #15: CO produced from MONOTERPENES + ! (d) Tracer #16: CO produced from METHANOL (CH3OH) + ! (e) Tracer #17: CO produced from ACETONE + ! + ! %%% NOTE: If you are modifying the tagged CO simulation, + ! %%% and your simulation has less than 12 tracers, then + ! %%% then comment out this section. If you don't you can + ! %%% get an array-out-of-bounds error (bmy, 6/11/08) + !============================================================== + + ! no tagging in adj, feel free to change (mak, 6/20/09) + ! Split FF CO into geographic regions -- Tracers #2 - #5 + !IF ( LSPLIT ) THEN + ! STT(I,J,L,12) = STT(I,J,L,12) + CO_CH4 / STTCO + ! STT(I,J,L,14) = STT(I,J,L,14) + CO_ISOP / STTCO + ! STT(I,J,L,15) = STT(I,J,L,15) + CO_MONO / STTCO + ! STT(I,J,L,16) = STT(I,J,L,16) + CO_CH3OH / STTCO + ! STT(I,J,L,17) = STT(I,J,L,17) + CO_ACET / STTCO + !ENDIF + + !============================================================== + ! (2a) Loss of CO due to chemical reaction w/ OH + !============================================================== + + ! Select out tropospheric or stratospheric boxes + IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN + + !=========================================================== + ! (2a-1) Stratospheric loss of CO due to chemical rxn w/ OH + !=========================================================== + + ! Get the L(CO) rate in the stratosphere in [s-1] + CORATE = GET_PCO_LCO_STRAT( .FALSE., I, J, L ) + + ! CO_OH is the fraction of CO lost to OH [unitless] + CO_OH = CORATE * DTCHEM + + ! Check CO_OH for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'CO_OH' + ERR_MSG = 'STOP at tagged_co_mod:6' + CALL CHECK_VALUE( CO_OH, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + ! no tagging in adj, feel free to change (mak, 6/20/09) + ! Split FF CO into geographic regions -- Tracers #2 - #5 + ! Handle strat loss by OH for regional CO tracers +! IF ( LSPLIT ) THEN +! +! ! Loop over regional CO tracers +! DO N = 2, N_TRACERS +! +! ! Loss +! STT(I,J,L,N) = STT(I,J,L,N) * ( 1d0 - CO_OH ) +! +! ! STT shouldn't be less than zero +! IF ( STT(I,J,L,N) < 0d0 ) STT(I,J,L,N) = 0d0 +! +! ! Error check +! CALL CHECK_VALUE( STT(I,J,L,N), (/ I, J, L, N /), +! & 'STT','STOP at tagged_co_mod.f:7' ) +! +! ! ND65 diagnostic -- loss of CO by OH for "tagged" tracers +! IF ( ND65 > 0 .and. L <= LD65 ) THEN +! AD65(I,J,L,N) = AD65(I,J,L,N) + +! & ( CORATE * STT(I,J,L,N) * STTCO ) +! ENDIF +! ENDDO +! ENDIF + + ! CO_OH above is just the fraction of CO lost by OH. Here + ! we multiply it by GCO (the initial value of STT in molec/cm3) + ! to convert it to an amount of CO lost by OH [molec/cm3] + ! (bmy, 2/19/02) + CO_OH = GCO_ADJ * CO_OH + + ELSE + + !=========================================================== + ! (2a-2) Tropospheric loss of CO due to chemical rxn w/ OH + ! + ! DECAY RATE + ! The decay rate (KRATE) is calculated by: + ! + ! OH + CO -> products (JPL '97) + ! k = (1 + 0.6Patm) * 1.5E-13 + ! + ! KRATE has units of [ molec^2 CO / cm6 / s ]^-1, + ! since this is a 2-body reaction. + !=========================================================== + + ! Pressure at the center of sigma level L, + ! expressed as a fraction of surface pressure in [Pa] + PCO = GET_PCENTER(I,J,L) / 1.01325d3 + + ! Decay rate + KRATE = ( 1.d0 + ( 0.6d0 * PCO ) ) * 1.5d-13 + + ! CO_OH = Tropospheric loss of CO by OH [molec/cm3] + CO_OH = KRATE * GCO_ADJ * OH(I,J,L) * DTCHEM + ENDIF + + !============================================================== + ! Save the total chemical production from various sources + ! into the total CO tracer STT(I,J,L,1) + !============================================================== + + ! GCO is the total CO before chemistry was applied [molec CO/cm3] + ! Add to GCO the sources and sinks listed above + GCO_ADJ = GCO_ADJ - CO_OH + ! Convert ADJ CO from [molec CO/cm3] to [kg] and store in STT_ADJ + STT_ADJ(I,J,L,1) = GCO_ADJ / STTCO + + !Read CH4 from forward run + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + !CO_CH4 = GET_CO_CH4(I, J, L, TIME_STEPS) * STTCO + + CO_VOC = CO_MONO + CO_ACET + CO_CH3OH + CO_ISOP + + IF ( LADJ_EMS .AND. NNEMS .GT. 1) THEN + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + ! OLD: + !IF ( LDEVOC ) THEN !ZHE + !EMS_SF_ADJ(I,J,M,ADCOEMS) = EMS_SF_ADJ(I,J,M,ADCOEMS) + + ! STT_ADJ(I,J,L,1) * CO_VOC * COSF(I,J,1) / STTCO + ! + !EMS_SF_ADJ(I,J,M,ADCOVOX) = EMS_SF_ADJ(I,J,M,ADCOVOX) + + ! STT_ADJ(I,J,L,1) * CO_CH4 * COSF(I,J,2) / STTCO + ! + !ELSE + !EMS_SF_ADJ(I,J,M,ADCOVOX) = EMS_SF_ADJ(I,J,M,ADCOVOX) + + ! BUG FIX: variable N undefined (zj, dkh, 07/30/10) + !& STT_ADJ(I,J,L,N)*(CO_CH4 + CO_MONO + CO_ACET + + & ! STT_ADJ(I,J,L,1)*(CO_CH4 + CO_VOC) * COSF(I,J,2) /STTCO + !ENDIF + ! NEW: remove COSF + IF ( LDEVOC ) THEN !ZHE + EMS_SF_ADJ(I,J,M,ADCOEMS) = EMS_SF_ADJ(I,J,M,ADCOEMS) + + & STT_ADJ(I,J,L,1) * CO_VOC / STTCO + + EMS_SF_ADJ(I,J,M,ADCOVOX) = EMS_SF_ADJ(I,J,M,ADCOVOX) + + & STT_ADJ(I,J,L,1) * CO_CH4 / STTCO + + ELSE + EMS_SF_ADJ(I,J,M,ADCOVOX) = EMS_SF_ADJ(I,J,M,ADCOVOX) + + & STT_ADJ(I,J,L,1) * (CO_CH4 + CO_VOC) /STTCO + ENDIF + + ENDIF + + IF(I == IFD .AND. J == JFD .AND. L==1 .and. LPRINTFD) THEN + PRINT*, 'STTCO:', STTCO + PRINT*, 'CO_VOC:', CO_VOC / STTCO + PRINT*, 'CO_CH4:', CO_CH4 / STTCO + ENDIF + + !============================================================== + ! Archive ND65 diagnostics -- Production & Loss of CO + ! Also save P(CO) from CH3OH and MONOTERPENES (bmy, 1/2/01) + !============================================================== + ! DO NOT OVERWRITE FORWARD MODEL DIAGNOSTICS, probably should + ! be deleted (mak, 6/20/09) + ! IF ( ND65 > 0 .and. L <= LD65 ) THEN + +! ! Loss of CO by OH (global) [s-1] +! N = 1 +! AD65(I,J,L,N) = AD65(I,J,L,N) + ( CO_OH / DTCHEM ) + +! ! Production of CO from Isoprene [molec CO/cm3/s] +! N = N_TRACERS + 1 +! AD65(I,J,L,N) = AD65(I,J,L,N) + ( CO_ISOP / DTCHEM ) + +! ! Production of CO from CH4 [molec CO/cm3/s] +! N = N_TRACERS + 2 +! AD65(I,J,L,N) = AD65(I,J,L,N) + ( CO_CH4 / DTCHEM ) + +! ! Production of CO from CH3OH [molec CO/cm3/s] +! N = N_TRACERS + 3 +! AD65(I,J,L,N) = AD65(I,J,L,N) + ( CO_CH3OH / DTCHEM ) + +! ! Production of CO from MONO [molec CO/cm3/s] +! N = N_TRACERS + 4 +! AD65(I,J,L,N) = AD65(I,J,L,N) + ( CO_MONO / DTCHEM ) + +! ! Production of CO from ACET [molec CO/cm3/s] +! N = N_TRACERS + 5 +! AD65(I,J,L,N) = AD65(I,J,L,N) + ( CO_ACET / DTCHEM ) +! ENDIF + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + IF ( LPRINTFD ) THEN + PRINT*, 'STT_ADJ:', STT_ADJ(IFD,JFD,1,1) + IF ( LADJ_EMS ) THEN + PRINT*, 'EMS_SF_ADJ:', EMS_SF_ADJ(IFD,JFD,M,ADCOEMS) + ENDIF + ENDIF + + ! Cleanup code (zhej, dkh, 01/16/12, adj32_017) + !TIME_STEPS = TIME_STEPS -1 !zhe + + ! Return to calling program + END SUBROUTINE CHEM_TAGGED_CO_ADJ + +!------------------------------------------------------------------------------ + + FUNCTION GET_ALPHA_ISOP( FROM_NOX, NOX ) RESULT( ALPHA_ISOP ) +! +!****************************************************************************** +! Function GET_ALPHA_ISOP returns the CO yield from Isoprene (ALPHA_ISOP) +! either as a function of NOx or as a constant. (bnd, bmy, 6/13/01. 7/20/04) +! +! Arguments as Input: +! =========================================================================== +! (1 ) FROM_NOX (LOGICAL) : If =T, will take ALPHA_ISOP as f(NOx) +! If =F, will set ALPHA_ISOP to a constant +! (2 ) NOX (REAL*8 ) : NOx concentration in ppbv +! +! NOTES: +! (1 ) Now make NOx an optional argument (bmy, 8/28/01) +! (2 ) Now reference ERROR_STOP from "error_mod.f" (bmy, 10/15/02) +! (3 ) Updated comments (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + LOGICAL, INTENT(IN) :: FROM_NOX + REAL*8, INTENT(IN), OPTIONAL :: NOX + + ! Function Value + REAL*8 :: ALPHA_ISOP + + !================================================================= + ! GET_ALPHA_ISOP begins here! + ! + ! If FROM_NOX = T, then we are taking the CO yield from Isoprene + ! as a function of NOx. Otherwise, we set it to a constant. + !================================================================= + IF ( FROM_NOX ) THEN + + ! Make sure NOX is passed if FROM_NOX = TRUE + IF ( PRESENT( NOX ) ) THEN + + ! The CO yield here is taken from acf's calculation + ! (from group meeting (1-20-99). Assumming linearity, + ! ALPHA=0.8*[NOx]+0.6, with an upper and lower limit of 2.1 + ! and 0.8, respectively. [NOx] is concentration in ppbv !! + ALPHA_ISOP = ( 0.8d0 * NOX ) + 0.6D0 + + ! Force lower & upper limits + IF ( NOX < 0.5d0 ) ALPHA_ISOP = 0.8d0 + IF ( NOX > 1.8d0 ) ALPHA_ISOP = 2.1d0 + + ELSE + + ! Stop w/ error message + CALL ERROR_STOP( 'NOx argument not passed!', + & 'GET_ALPHA_ISOP (tagged_co_mod.f)' ) + + ENDIF + + ELSE + + ! Otherwise, use a 30% yield from Miyoshi et al., 1994. + ! They estimate globally 105 Tg C/yr of CO is produced + ! from isoprene oxidation. + ! ALPHA_ISOP = (0.3 molec CO/atoms C) x (5 atoms C/molec ISOP) + ALPHA_ISOP = 1.5d0 + + ENDIF + + ! Return to calling program + END FUNCTION GET_ALPHA_ISOP + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_PCO_LCO_STRAT( THISMONTH ) +! +!****************************************************************************** +! Subroutine READ_PCO_LCO_STRAT reads production and destruction +! rates for CO in the stratosphere. (bnd, bmy, 9/13/00, 10/3/05) +! +! NOTES: +! (1 ) Now use IOS /= 0 to trap both I/O errors and EOF. (bmy, 9/13/00) +! (2 ) Added to module "tagged_co_mod.f" (bmy, 6/13/01) +! (3 ) ARRAY needs to be of size (IGLOB,JGLOB). Use TRANSFER_ZONAL from +! "transfer_mod.f" to cast data from REAL*4 to REAL*8, and also to +! copy data to an array of size (JJPAR,LLPAR). Use 3 arguments (M/D/Y) +! in call to GET_TAU0. Use JGLOB,LGLOB in call to READ_BPCH2. +! (bmy, 9/28/01) +! (4 ) Removed obsolete code from 9/28/01 (bmy, 10/22/01) +! (5 ) Updated comments (bmy, 2/15/02) +! (6 ) Update FILENAME so that it looks in the "pco_lco_200203" subdirectory +! of DATA_DIR. (bnd, bmy, 6/30/03) +! (7 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +! (8 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE TRANSFER_MOD, ONLY : TRANSFER_ZONAL + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: THISMONTH + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + REAL*4 :: ARRAY(1,JGLOB,LGLOB) + REAL*8 :: XTAU + + !================================================================= + ! READ_PCO_LCO_STRAT begins here! + !================================================================= + + ! Initialize some variables + ARRAY = 0e0 + CO_PRODS = 0d0 + CO_LOSSS = 0d0 + + ! TAU value at the beginning of this month + ! Use "generic" year 1985 + XTAU = GET_TAU0( THISMONTH, 1, 1985 ) + + !================================================================= + ! Read in CO production rates [v/v/s] + !================================================================= + + ! Construct filename + FILENAME = TRIM( DATA_DIR ) // 'pco_lco_200203/COprod.' // + & GET_NAME_EXT() // '.' // GET_RES_EXT() + + ! Read P(CO) + CALL READ_BPCH2( FILENAME, 'PORL-L=$', 9, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR) + CALL TRANSFER_ZONAL( ARRAY(1,:,:), CO_PRODS ) + + !================================================================= + ! Read in CO loss rates [s^-1] + !================================================================= + + ! Construct filename + FILENAME = TRIM( DATA_DIR ) // 'pco_lco_200203/COloss.' // + & GET_NAME_EXT() // '.' // GET_RES_EXT() + + ! Read L(CO) + CALL READ_BPCH2( FILENAME, 'PORL-L=$', 10, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR) + CALL TRANSFER_ZONAL( ARRAY(1,:,:), CO_LOSSS ) + + ! Return to calling program + END SUBROUTINE READ_PCO_LCO_STRAT + +!------------------------------------------------------------------------------ + + FUNCTION GET_PCO_LCO_STRAT( IS_PROD, I, J, L ) RESULT( RATE ) +! +!****************************************************************************** +! Function GET_CO_STRAT_RATE uses production and loss rates for CO to +! calculate net production of CO in the stratosphere. The purpose of this +! SR is to prevent high CO concentrations from building up in the +! stratosphere; in these layers only transport is simulated (i.e., no +! chemistry). For a long simulation, a buildup of high concentrations +! could occur causing the stratosphere to become a significant source of CO. +! (bnd, bmy, 6/13/01, 7/20/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IS_PROD (LOGICAL) : If =T, then return CO production rate [v/v/s] +! If =F, then return CO loss rate [s^-1] +! (2-5) I, J, L (INTEGER) : Grid box indices (lon,lat,alt) +! +! Arguments as Output: +! ============================================================================ +! (6 ) RATE (REAL*8 ) : CO production [v/v/s] or loss rate [s-1] +! +! NOTES: +! (1 ) Production (mixing ratio/sec) and loss (1/sec) rates provided by +! Dylan Jones. Only production by CH4+OH and destruction by CO+OH +! are considered. +! (2 ) The annual mean tropopause is stored in the LPAUSE array +! (from header file "CMN"). LPAUSE is defined such that: +! Levels 1 <= L <= LPAUSE(I,J) - 1 are tropospheric +! LPAUSE(I,J) <= L <= LLPAR are stratospheric +! (3 ) LPAUSE_MIN = minimun tropopause height. Start L-loop from the +! lowest stratospheric level! +! (4 ) Added to module "tagged_co_mod.f" (bmy, 6/18/01) +! (5 ) Updated comments (bmy, 2/19/02) +! (6 ) Removed reference to CMN, it's not needed (bmy, 7/20/04) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + LOGICAL, INTENT(IN) :: IS_PROD + INTEGER, INTENT(IN) :: I, J, L + + ! Function return value + REAL*8 :: RATE + + !================================================================= + ! GET_PCO_LCO_STRAT begins here! + ! + ! Pick P(CO) or L(CO) depending on IS_PROD + !================================================================= + IF ( IS_PROD ) THEN + RATE = CO_PRODS(J,L) ! P(CO) from CH4 + OH in [v/v/s] + ELSE + RATE = CO_LOSSS(J,L) ! L(CO) from CO + OH in [s^-1] + ENDIF + + ! Return to calling program + END FUNCTION GET_PCO_LCO_STRAT + +!----------------------------------------------------------------------------- + + SUBROUTINE READ_ACETONE( THISMONTH ) +! +!****************************************************************************** +! Subroutine READ_ACETONE reads in biogenic acetone emissions from +! a binary punch file. (bdf, bnd, bmy, 6/19/01, 10/3/05) +! +! Arguments as Input +! =========================================================================== +! (1 ) THISMONTH (INTEGER) : Current month (1-12) +! +! NOTES: +! (1 ) Eliminate variables that aren't used anymore. Updated comments +! and made some cosmetic changes. (bnd, bmy, 6/14/01) +! (2 ) Added to "tagged_co_mod.f" (bmy, 6/14/01) +! (3 ) Now read acetone file from DATA_DIR/tagged_CO_200106 (bmy, 6/19/01) +! (4 ) ARRAY needs to be of size (IGLOB,JGLOB). Use TRANSFER_2D from +! "transfer_mod.f" to cast data from REAL*4 to REAL*8, and also to +! copy data to an array of size (IIPAR,JJPAR). Use 3 arguments (M/D/Y) +! in call to GET_TAU0. Use IGLOB,JGLOB in call to READ_BPCH2. +! Added array TEMP(IIPAR,JJPAR). Updated comments. (bmy, 9/28/01) +! (5 ) Removed obsolete code from 9/28/01 (bmy, 10/22/01) +! (6 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +! (7 ) Now reads data from both GEOS and GCAP grids (bmy, 8/16/05) +! (8 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE TRANSFER_MOD, ONLY : TRANSFER_2D + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: THISMONTH + + ! Local variables + INTEGER :: I, J + REAL*4 :: ARRAY(IGLOB,JGLOB,1) + REAL*8 :: TEMP(IIPAR,JJPAR) + REAL*8 :: XTAU + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_ACETONE begins here! + !================================================================= + + ! Name of file with acetone data + FILENAME = TRIM( DATA_DIR ) // + & 'tagged_CO_200106/acetone.' // GET_NAME_EXT_2D() // + & '.' // GET_RES_EXT() + + ! Echo to stdout + WRITE( 6, '(a)' ) 'READING ', TRIM( FILENAME ) + + ! Initialize some variables + EMACET = 0d0 + + ! TAU value at the beginning of this month for 1994 + XTAU = GET_TAU0( THISMONTH, 1, 1994 ) + + !================================================================= + ! Read direct biogenic acetone emissions [atoms C/cm2/s] + !================================================================= + + ! Initialize ARRAY + ARRAY = 0e0 + + ! Read data + CALL READ_BPCH2( FILENAME, 'EMISACET', 6, XTAU, + & IIPAR, JJPAR, 1, ARRAY ) + + ! Cast from REAL*4 to REAL*8 and resize to (IIPAR,JJPAR) + CALL TRANSFER_2D( ARRAY(:,:,1), EMACET ) + + !================================================================= + ! Read acetone from grasslands [atoms C/cm2/s] + !================================================================= + + ! Initialize ARRAY + ARRAY = 0e0 + + ! Read data + CALL READ_BPCH2( FILENAME, 'EMISACET', 7, XTAU, + & IIPAR, JJPAR, 1, ARRAY ) + + ! Cast from REAL*4 to REAL*8 and add + CALL TRANSFER_2D( ARRAY(:,:,1), TEMP ) + + ! Add acetone from grasslands to direct biogenic emissions + EMACET(:,:) = EMACET(:,:) + TEMP(:,:) + + ! Return to calling program + END SUBROUTINE READ_ACETONE + +!------------------------------------------------------------------------------ + + FUNCTION GET_SCALE_GROUP( ) RESULT( CURRENT_GROUP ) +! +!******************************************************************************** +! Subroutine GET_SCALE_GROUP determines which predifined scaling index corresponds +! to the current time and location (dkh, 12/02/04) +! +! NOTES +! (1 ) CURRENT_GROUP is currently only a function of TAU +! (2 ) Get rid of I,J as argument. (dkh, 03/28/05) +! +!******************************************************************************** + + ! Reference to f90 modules + USE TIME_MOD, ONLY : GET_TAU, GET_TAUe, GET_TAUb, GET_MONTH + USE ADJ_ARRAYS_MOD, ONLY: MMSCL + +# include "CMN_SIZE" ! Size stuff + + ! Arguments + INTEGER :: I, J + + ! Local Variables + REAL*8 :: TOTAL_HR, CURRENT_HR, GROUP_LENGTH + REAL*8 :: TAU, TAUe, TAUb + + ! Function variable + INTEGER :: CURRENT_GROUP + LOGICAL, SAVE :: MONTHLY = .TRUE. + INTEGER, SAVE :: MONTH_SAVE + INTEGER, SAVE :: GROUP_SAVE + LOGICAL, SAVE :: FIRST = .TRUE. + + !============================================================ + ! GET_SCALE_GROUP begins here! + !============================================================ + + ! Currently there is no spatial grouping + + ! Determine temporal grouping + IF ( MMSCL == 1 ) THEN + CURRENT_GROUP = 1 + RETURN + ENDIF + + IF ( MONTHLY ) THEN + IF (FIRST) THEN + MONTH_SAVE = GET_MONTH() + CURRENT_GROUP = MMSCL + GROUP_SAVE = MMSCL + FIRST = .FALSE. + ENDIF + IF ( MONTH_SAVE /= GET_MONTH() ) THEN + MONTH_SAVE = GET_MONTH() + GROUP_SAVE = GROUP_SAVE - 1 + CURRENT_GROUP = GROUP_SAVE + ELSE + CURRENT_GROUP = GROUP_SAVE + ENDIF + + ELSE + ! Retrieve time parameters + TAUe = GET_TAUe() + TAUb = GET_TAUb() + TAU = GET_TAU() + TOTAL_HR = TAUe - TAUb + CURRENT_HR = TAU - TAUb + + + ! The last time step always belongs to the last group + IF ( TAU == TAUe ) THEN + CURRENT_GROUP = MMSCL + RETURN + ELSE + + ! Determine the length of each group + GROUP_LENGTH = REAL( TOTAL_HR / MMSCL ) + + ! Index is the current time divided by the group length, plus one + CURRENT_GROUP = SNGL( CURRENT_HR / GROUP_LENGTH ) + 1 + + ENDIF + + ENDIF + + END FUNCTION GET_SCALE_GROUP + +!----------------------------------------------------------------------------------------- + + SUBROUTINE INIT_TAGGED_CO_ADJ +! +!****************************************************************************** +! Subroutine INIT_TAGGED_CO_ADJ allocates memory to module arrays. +! (bmy, 7/19/00, 9/18/07) +! +! NOTES: +! (1 ) Added ISOP96, MONO96, CH3OH96 for GEOS-3 (bnd, bmy, 6/14/01) +! (2 ) Removed ISOP96, MONO96, CH3OH96 for GEOS-3, since the new GEOS-3 +! fields make these no longer necessary (bmy, 8/21/09) +! (3 ) Now allocate BB_REGION, FF_REGION as (IIPAR,JJPAR) (bmy, 9/28/01) +! (4 ) Removed obsolete code from 9/28/01 (bmy, 10/22/01) +! (5 ) Now references ALLOC_ERR from "error_mod.f" (bmy, 10/15/02) +! (6 ) Now remove IJLOOP_CO (bmy, 7/20/04) +! (7 ) Now public. Now references ITS_A_H2HD_SIM from "tracer_mod.f". +! Allocate needed variables if H2/HD simulation (phs, 9/18/07) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRACER_MOD, ONLY : ITS_A_H2HD_SIM + +# include "CMN_SIZE" + + ! Local variables + INTEGER :: AS, I, J, IJLOOP + + !================================================================= + ! INIT_TAGGED_CO begins here! + !================================================================= + + ! Allocate SUMACETCO -- array for CO from isoprene + ALLOCATE( EMACET( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMACET' ) + EMACET = 0d0 + + ! Allocate and initialize IJLOOP_CO -- 1-D array index + ALLOCATE( CO_PRODS( JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CO_PRODS' ) + CO_PRODS = 0d0 + + ! Allocate and initialize IJLOOP_CO -- 1-D array index + ALLOCATE( CO_LOSSS( JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CO_LOSSS' ) + CO_LOSSS = 0d0 + + ! Allocate only what is needed + IF ( ITS_A_H2HD_SIM() ) RETURN + + ! Allocate SUMISOPCO -- array for CO from isoprene + ALLOCATE( SUMISOPCO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SUMISOPCO' ) + SUMISOPCO = 0d0 + + ! Allocate SUMISOPCO -- array for CO from isoprene + ALLOCATE( SUMMONOCO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SUMMONOCO' ) + SUMMONOCO = 0d0 + + ! Allocate SUMISOPCO -- array for CO from isoprene + ALLOCATE( SUMCH3OHCO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SUMCH3OHCO' ) + SUMCH3OHCO = 0d0 + + ! Allocate SUMACETCO -- array for CO from isoprene + ALLOCATE( SUMACETCO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SUMACETCO' ) + SUMACETCO = 0d0 + + ! Return to calling program + END SUBROUTINE INIT_TAGGED_CO_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_TAGGED_CO +! +!****************************************************************************** +! Subroutine CLEANUP_TAGGED_CO deallocates memory from previously +! allocated module arrays (bmy, 7/19/00, 7/20/04) +! +! NOTES: +! (1 ) Added ISOP96, MONO96, CH3OH96 for GEOS-3 (bnd, bmy, 6/14/01) +! (2 ) Removed ISOP96, MONO96, CH3OH96 for GEOS-3, since the new GEOS-3 +! fields make these no longer necessary (bmy, 8/21/09) +! (3 ) Now remove IJLOOP_CO (bmy, 7/20/04) +!****************************************************************************** +! + IF ( ALLOCATED( SUMISOPCO ) ) DEALLOCATE( SUMISOPCO ) + IF ( ALLOCATED( SUMMONOCO ) ) DEALLOCATE( SUMMONOCO ) + IF ( ALLOCATED( SUMCH3OHCO ) ) DEALLOCATE( SUMCH3OHCO ) + IF ( ALLOCATED( SUMACETCO ) ) DEALLOCATE( SUMACETCO ) + IF ( ALLOCATED( EMACET ) ) DEALLOCATE( EMACET ) + IF ( ALLOCATED( CO_PRODS ) ) DEALLOCATE( CO_PRODS ) + IF ( ALLOCATED( CO_LOSSS ) ) DEALLOCATE( CO_LOSSS ) + + ! Return to calling program + END SUBROUTINE CLEANUP_TAGGED_CO + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE TAGGED_CO_ADJ_MOD diff --git a/code/adjoint/tagged_ox_adj_mod.f b/code/adjoint/tagged_ox_adj_mod.f new file mode 100644 index 0000000..ee2bdf0 --- /dev/null +++ b/code/adjoint/tagged_ox_adj_mod.f @@ -0,0 +1,729 @@ +! $Id: tagged_ox_adj_mod.f,v 1.1 2010/03/09 15:03:47 daven Exp $ + MODULE TAGGED_OX_ADJ_MOD +! +!****************************************************************************** +! Module TAGGED_OX_ADJ_MOD contains variables and routines for the adjoint of +! the Ox simulation (lzh, dkh, 03/08/10) +! simulation. +! +! Based on forward model. (amf,rch,bmy, 8/20/03, 12/4/07) +! +! Module Variables: +! ============================================================================ +! (1 ) N_TAGGED (INTEGER) : Total number of tagged tracers +! (2 ) N_STRAT (INTEGER) : Denotes tracer # of stratospheric Ox +! (3 ) N_INIT (INTEGER) : Denotes tracer # of initial condition Ox +! (4 ) N_USA (INTEGER) : Denotes tracer # of USA produced Ox +! (5 ) P24H (REAL*8 ) : 24-hr avg P(Ox) saved from fullchem run [kg/cm3/s] +! (6 ) L24H (REAL*8 ) : 24-hr avg L(Ox) saved from fullchem run [ 1/cm3/s] +! +! Module Routines: +! ============================================================================ +! (1 ) ADD_STRAT_POX : Adds strat P(Ox) from UPBDFLX_O3 to tracer array +! (2 ) READ_POX_LOX : Reads previously archived P(Ox), L(Ox) from disk +! (3 ) GET_REGIONAL_POX : Flags tracers by geographic & vertical location +! (4 ) CHEM_TAGGED_OX : Performs Ox chem on geographically tagged tracers +! (5 ) INIT_TAGGED_OX : Allocates and zeroes all module arrays +! (6 ) CLEANUP_TAGGED_OX : Deallocates all module arrays +! +! GEOS-CHEM modules referenced by tagged_ox_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (2 ) dao_mod.f : Module w/ arrays for DAO met fields +! (3 ) diag_mod.f : Module w/ GEOS-CHEM diagnostic arrays +! (4 ) diag_pl_mod.f : Module w/ routines for ND65 & ND20 diagnostics +! (5 ) error_mod.f : Module w/ I/O error and NaN check routines +! (6 ) grid_mod.f : Module w/ horizontal grid information +! (7 ) pbl_mix_mod.f : Module w/ routines for PBL height & mixing +! (8 ) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (9 ) time_mod.f : Module w/ routines for computing time & date +! (10) transfer_mod.f : Module w/ routines to cast & resize arrays +! (11) tracerid_mod.f : Module w/ pointers to tracers & emissions +! +! NOTES: +! (1 ) Now accounts for GEOS-4 PBL being in meters (bmy, 1/15/04) +! (2 ) Bug fix: don't put function call in WRITE statement (bmy, 2/20/04) +! (3 ) Now bracket AD44 with an !$OMP CRITICAL block (bmy, 3/24/04) +! (4 ) Now define regions w/ levels in GET_REGIONAL_POX (amf,rch,bmy,5/27/04) +! (5 ) Bug fix-avoid seg fault if PBLFRAC isn't allocated (bdf, bmy, 10/12/04) +! (6 ) Now reference "pbl_mix_mod.f" (bmy, 2/17/05) +! (7 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (8 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +! (9 ) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +! (10) Modified for variable tropopause (phs, bmy, 1/19/07) +! (11) Now use LLTROP instead of LLTROP_FIX everywhere (bmy, 12/4/07) +! (12) Now use LD65 instead of LLTROP everywhere (phs, 11/17/08) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "tagged_ox_mod.f" + !================================================================= + + ! PRIVATE module routines + PRIVATE :: GET_REGIONAL_POX + PRIVATE :: INIT_TAGGED_OX_ADJ + PRIVATE :: READ_POX_LOX_ADJ + + ! PRIVATE module variables + PRIVATE :: N_TAGGED, N_INIT, N_STRAT + PRIVATE :: N_USA, P24H, L24H + + !================================================================= + ! MODULE VARIABLES + !================================================================= + !------------------------------------------------------ + !%%% Modification for quick Ox spinup (bmy, 5/31/07) + !%%%INTEGER, PARAMETER :: N_TAGGED = 13 + !%%%INTEGER, PARAMETER :: N_STRAT = 11 + !%%%INTEGER, PARAMETER :: N_INIT = 12 + !%%%INTEGER, PARAMETER :: N_USA = 13 + !------------------------------------------------------ + INTEGER, PARAMETER :: N_TAGGED = 3 + INTEGER, PARAMETER :: N_STRAT = 2 + INTEGER, PARAMETER :: N_INIT = 3 + INTEGER, PARAMETER :: N_USA = -1 + REAL*8, ALLOCATABLE :: P24H(:,:,:) + REAL*8, ALLOCATABLE :: L24H(:,:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ +! +! SUBROUTINE ADD_STRAT_POX( I, J, L, POx ) +! +!****************************************************************************** +! Subroutine ADD_STRAT_POX adds the stratospheric influx of Ox to the +! stratospheric Ox tracer. This is called from routine UPBDFLX_O3, +! which is applied when the tracer array has units of [v/v]. +! (bmy, 8/19/03, 7/20/04) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I,J,L (INTEGER) : GEOS-CHEM grid box indices for lon, lat, alt +! (4 ) POx (REAL*8 ) : P(Ox) in the stratosphere [v/v] +! +! NOTES: +! (1 ) Now references STT from "tracer_mod.f" (bmy, 7/20/04) +!****************************************************************************** +! +! ! References to F90 modules +! USE TRACER_MOD, ONLY : STT +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: I, J, L +! REAL*8, INTENT(IN) :: POx +! +! !================================================================= +! ! GET_STRAT_POX begins here! +! !================================================================= +! STT(I,J,L,N_STRAT) = STT(I,J,L,N_STRAT) + POx +! +! ! Return to calling program +! END SUBROUTINE ADD_STRAT_POX +! +!------------------------------------------------------------------------------ + + SUBROUTINE READ_POX_LOX_ADJ +! +!****************************************************************************** +! Subroutine READ_POX_LOX reads previously-archived Ox production & loss +! rates from binary punch file format. (bmy, 8/20/03, 12/4/07) +! +! NOTES: +! (1 ) Updated from the old routine "chemo3_split.f" (rch, bmy, 8/20/03) +! (2 ) Now references O3PL_DIR from "directory_mod.f" (bmy, 7/20/04) +! (3 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (4 ) Use LLTROP_FIX to limit array size to case of non-variable tropopause. +! Also zero ARRAY to avoid numerical problems (phs, 1/19/07) +! (5 ) Now use LLTROP instead of LLTROP_FIX (phs, bmy, 12/4/07) +! (6 ) Now use LD65, since this is the number of levels use to +! save diag20 (phs, 11/17/08) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE DIRECTORY_MOD, ONLY : O3PL_DIR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_NYMD, GET_TAU + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRANSFER_MOD, ONLY : TRANSFER_3D_TROP + + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! LD65 + + ! Local variables + REAL*4 :: ARRAY(IGLOB,JGLOB,LD65) + REAL*8 :: XTAU + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_POX_LOX begins here! + !================================================================= + + ! Filename string + FILENAME = 'rate.YYYYMMDD' + CALL EXPAND_DATE( FILENAME, GET_NYMD(), 000000 ) + + ! Prefix FILENAME w/ the proper directory + FILENAME = TRIM( O3PL_DIR ) // FILENAME + + ! Echo information + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_POX_LOX_ADJ: Reading ', a ) + + ! Get the TAU0 value for today + ! lzh 04/03/2008 - now backwards + XTAU = GET_TAU()- ( 24-GET_TS_CHEM()/60d0 ) + !23 for 60 min; 23.5 for 30 min + print*, 'TAU0: ', XTAU + print*, ' WARNING: NHMSe must be 000000 for the XTAU ' + print*, ' to be correct ' + + + !================================================================= + ! Read P(O3) [kg/cm3/s] + !================================================================= + + ! Initialize + ARRAY = 0e0 + + ! Limit array 3d dimension to LLTROP_FIX, i.e, case of annual mean + ! tropopause. This is backward compatibility with offline data set. + CALL READ_BPCH2( FILENAME, 'PORL-L=$', 1, + & XTAU, IGLOB, JGLOB, + & LLTROP, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 + CALL TRANSFER_3D_TROP( ARRAY, P24H ) + + !================================================================= + ! Read L(O3) [1/cm3/s] + !================================================================= + + ! Initialize + ARRAY = 0e0 + + ! read data + CALL READ_BPCH2( FILENAME, 'PORL-L=$', 2, + & XTAU, IGLOB, JGLOB, + & LLTROP, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 + CALL TRANSFER_3D_TROP( ARRAY, L24H ) + + ! Return to calling program + END SUBROUTINE READ_POX_LOX_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE GET_REGIONAL_POX( I, J, L, PP ) +! +!****************************************************************************** +! Subroutine GET_REGIONAL_POX returns the P(Ox) for each of the tagged Ox +! tracers. Tagged Ox tracers are defined by both geographic location and +! altitude. (amf, rch, bmy, 8/19/03, 12/4/07) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I,J,L (INTEGER) : GEOS-CHEM grid box indices for lon, lat, alt +! +! Return Value +! ============================================================================ +! (4 ) PP (REAL*8) : Array containing P(Ox) for each tagged tracer +! +! NOTES: +! (1 ) Updated from the old routine "chemo3_split.f" (rch, bmy, 8/20/03) +! (2 ) For GEOS-4, convert PBL from [m] to [hPa] w/ the hydrostatic law. +! Now references SCALE_HEIGHT from "CMN_GCTM". (bmy, 1/15/04) +! (3 ) Now uses model levels instead of pressure in order to delineate +! between PBL, MT, and UT regions (amf, rch, bmy, 5/27/04) +! (4 ) Now references ITS_IN_THE_TROP from "tropopause_mod.f". Now remove +! reference to "CMN", it's obsolete. (bmy, 8/22/05) +! (5 ) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +! (6 ) Resize the PP array from LLTROP to LLTROP_FIX (phs, 1/19/07) +! (7 ) Now use LLTROP instead of LLTROP_FIX (bmy, 12/4/07) +! (8 ) Now use LD65 instead of LLTROP (phs, 11/17/08) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : PBL + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! SCALE_HEIGHT +# include "CMN_DIAG" ! ND44, ND65, LD65 + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L + REAL*8, INTENT(OUT) :: PP(IIPAR,JJPAR,LD65,N_TAGGED) + + ! Local variables + LOGICAL :: ITS_IN_TROP, ITS_IN_PBL, ITS_IN_MT + LOGICAL :: ITS_IN_UT, ITS_IN_NH, ITS_IN_ATL + LOGICAL :: ITS_IN_PAC, ITS_IN_AS, ITS_IN_EUR + LOGICAL :: ITS_IN_NAM, ITS_IN_NAF, ITS_IN_USA + INTEGER :: PBLTOP, MTTOP + REAL*8 :: PPROD, X, Y + + ! External functions + REAL*8, EXTERNAL :: BOXVL + + !================================================================= + ! GET_REGIONAL_POX begins here! + !================================================================= + + ! Initialize + PP(I,J,L,:) = 0d0 + + ! IS TROP is TRUE if we are in the troposphere + ITS_IN_TROP = ITS_IN_THE_TROP( I, J, L ) + + ! Skip stratospheric boxes + IF ( .not. ITS_IN_TROP ) RETURN + + !================================================================= + ! Get lon, lat, alt coordinates; test for specific regions + ! NOTE: You can update the lat/lon & alt boundaries as needed! + !================================================================= + + ! Longitude [degrees] + X = GET_XMID( I ) + Y = GET_YMID( J ) + + ! PBLTOP is the model level at ~ 750 hPa + ! MTTOP is the model level at ~ 350 hPa +#if defined( GEOS_3 ) + PBLTOP = 10 + MTTOP = 16 +#elif defined( GEOS_4 ) + PBLTOP = 5 + MTTOP = 10 +#elif defined( GEOS_5 ) || defined( GEOS_FP ) + PBLTOP = 5 + MTTOP = 10 +#endif + +! ! Define flags for various geographic & altitude regions +! ITS_IN_PBL = ( L <= PBLTOP ) +! ITS_IN_MT = ( L > PBLTOP .and. L <= MTTOP ) +! ITS_IN_UT = ( L > MTTOP .and. ITS_IN_TROP ) +! +! ITS_IN_NH = ( Y >= 0.0 ) +! ITS_IN_EUR = ( Y >= 36.0 .and. ( X > -15.0 .and. X >= 55.0 ) ) +! ITS_IN_NAM = ( Y >= 15.0 .and. ( X > -127.5 .and. X <= -65.0 ) ) +! ITS_IN_AS = ( Y >= -10.0 .and. ( X > 55.0 .and. X <= 145.0 ) ) +! ITS_IN_ATL = ( ITS_IN_NH .and. ( X > -65.0 .and. X <= -15.0 ) ) +! ITS_IN_PAC = ( ITS_IN_NH .and. ( X > 145.0 .or. X <= -127.5 ) ) +! +! ITS_IN_NAF = ( ( X >= -15.0 .and. X <= 55.0 ) .and. +! & ( Y >= 0.0 .and. Y < 36.0 ) ) +! +! ITS_IN_USA = ( ( X > -127.5 .and. X <= -65.0 ) .and. +! & ( Y > 22.0 .and. Y <= 50.0 ) ) + + !================================================================= + ! Assign P(Ox) to tagged tracers by geographic/altitude regions + !================================================================= + + ! P(Ox) [kg] + PPROD = P24H(I,J,L) * BOXVL(I,J,L) * ( GET_TS_CHEM() * 60d0 ) + + !----------------------- + ! #1: Total P(Ox) + !----------------------- + PP(I,J,L,1) = PPROD + +! !----------------------- +! ! #2: P(Ox) in UT +! !----------------------- +! IF ( ITS_IN_UT ) THEN +! PP(I,J,L,2) = PPROD +! +! !----------------------- +! ! #3: P(Ox) in MT +! !----------------------- +! ELSE IF ( ITS_IN_MT ) THEN +! PP(I,J,L,3) = PPROD +! +! !----------------------- +! ! #5: P(Ox) in Pac BL +! !----------------------- +! ELSE IF ( ITS_IN_PAC .and. ITS_IN_PBL ) THEN +! PP(I,J,L,5) = PPROD +! +! !----------------------- +! ! #6: P(Ox) in NAm BL +! !----------------------- +! ELSE IF ( ITS_IN_NAM .and. ITS_IN_PBL ) THEN +! PP(I,J,L,6) = PPROD +! +! !----------------------- +! ! #7: P(Ox) in Atl BL +! !----------------------- +! ELSE IF ( ITS_IN_ATL .and. ITS_IN_PBL ) THEN +! PP(I,J,L,7) = PPROD +! +! !----------------------- +! ! #8: P(Ox) in Eur BL +! !----------------------- +! ELSE IF ( ITS_IN_EUR .and. ITS_IN_PBL ) THEN +! PP(I,J,L,8) = PPROD +! +! !----------------------- +! ! #9: P(Ox) in NAfr BL +! !----------------------- +! ELSE IF ( ITS_IN_NAF .and. ITS_IN_PBL ) THEN +! PP(I,J,L,9) = PPROD +! +! !----------------------- +! ! #10: P(Ox) in Asia BL +! !----------------------- +! ELSE IF ( ITS_IN_AS .and. ITS_IN_PBL ) THEN +! PP(I,J,L,10) = PPROD +! +! !----------------------- +! ! #4: P(Ox) in R.O.W +! !----------------------- +! ELSE +! PP(I,J,L,4) = PPROD +! +! ENDIF +! +! !------------------------- +! ! #13: P(Ox) in USA +! !------------------------- +! IF ( ITS_IN_USA ) THEN +! PP(I,J,L,N_USA) = PPROD +! ENDIF + + ! Return to calling program + END SUBROUTINE GET_REGIONAL_POX + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_TAGGED_OX_ADJ +! +!****************************************************************************** +! Subroutine CHEM_TAGGED_OX performs chemistry for several Ox tracers which +! are tagged by geographic and altitude regions. (rch, bmy, 8/20/03, 12/4/07) +! +! NOTES: +! (1 ) Updated from the old routine "chemo3_split.f" (rch, bmy, 8/20/03) +! (2 ) Bug fix: don't put function call in WRITE statement (bmy, 2/20/04) +! (3 ) Now use ND44_TMP array to store vertical levels of drydep flux, then +! sum into AD44 array. This prevents numerical differences when using +! multiple processors. (bmy, 3/24/04) +! (4 ) Now references LDRYD from "logical_mod.f". Now references STT +! and N_TRACERS from "tracer_mod.f". Now references AD65 from +! "diag_pl_mod.f". Now uses ITS_A_NEW_DAY from "time_mod.f". +! (bmy, 7/20/04) +! (5 ) Bug fix: Now avoid a SEG FAULT error if PBLFRAC isn't allocated. +! (bdf, bmy, 10/12/04) +! (6 ) Replace PBLFRAC from "drydep_mod.f" with GET_FRAC_UNDER_PBLTOP +! from "pbl_mix_mod.f". Now only sum ND44 diagnostic up to the +! maximum tropopsheric level. (bmy, 2/17/05) +! (7 ) Resize PP, N D44_TMP arrays from LLTROP to LLTROP_FIX. Now only loop +! up to LLTROP_FIX (phs, 1/19/07) +! (8 ) Now use LLTROP instead of LLTROP_FIX (bmy, 12/4/07) +! (9 ) Now use LD65 instead of LLTROP (phs, 11/17/08) +!****************************************************************************** +! + ! References to F90 modules + USE DIAG_MOD, ONLY : AD44 + USE DIAG_PL_MOD, ONLY : AD65 + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE DRYDEP_MOD, ONLY : DEPSAV + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LDRYD + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP, GET_PBL_MAX_L + USE TIME_MOD, ONLY : GET_TS_CHEM, ITS_A_NEW_DAY + USE TIME_MOD, ONLY : TIMESTAMP_STRING + USE TIME_MOD, ONLY : GET_DAY + USE TRACER_MOD, ONLY : N_TRACERS, XNUMOL + USE TRACERID_MOD, ONLY : IDTOX + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + + ! lzh, 12/12/2009, add tagged ox adjoint + USE ADJ_ARRAYS_MOD, ONLY : EMS_SF_ADJ + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IDADJ_POx + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND44, ND65, LD65 + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER, SAVE :: LASTDAY = -1 + INTEGER :: I, J, L, N + REAL*8 :: PP(IIPAR,JJPAR,LD65,N_TAGGED) + REAL*8 :: ND44_TMP(IIPAR,JJPAR,LD65) + REAL*8 :: DTCHEM, FREQ, FLUX + REAL*8 :: LL, PL, Ox_0 + REAL*8 :: Ox_LOST, PBL_MAX, F_UNDER_TOP + CHARACTER(LEN=16) :: STAMP + + ! External routines + REAL*8, EXTERNAL :: BOXVL + + !================================================================= + ! CHEM_TAGGED_OX begins here! + !================================================================= + + ! Chemistry timestep [s] + DTCHEM = GET_TS_CHEM() * 60d0 + + ! First-time initialization only + IF ( FIRST ) THEN + CALL INIT_TAGGED_OX_ADJ + FIRST = .FALSE. + ENDIF + + ! Read P(Ox) and L(Ox) if it's a new day + IF ( GET_DAY() /= LASTDAY ) THEN + CALL READ_POX_LOX_ADJ + LASTDAY = GET_DAY() + ENDIF + + ! Maximum extent of the PBL [model layers] + PBL_MAX = GET_PBL_MAX_L() + + !================================================================= + ! Tagged Ox chemistry contains the following terms: + ! + ! New Ox = Old Ox - Drydep(Ox) + ( P(Ox,region) - L(Ox) ) + ! + ! P(Ox) and L(Ox) are archived from a previous fullchem run using + ! the ND20 diagnostic. P(Ox,region) is the P(Ox) for a specific + ! tagged Ox tracer, as computed by routine GET_REGIONAL_POX. + ! + ! Tagged Ox tracers are defined by both geographic location and + ! altitude, as listed below: + ! + !%%% Modification for quicker spinup + !%%% (1 ) Total Ox + !%%% (2 ) Ox produced in Upper Trop (350 hPa - tropopause) + !%%% (3 ) Ox produced in Middle Trop (PBL top - 350 hPa ) + !%%% (4 ) Ox produced in Rest of World (surface - PBL top ) + !%%% (5 ) Ox produced in Pacific BL (surface - PBL top ) + !%%% (6 ) Ox produced in N. American BL (surface - PBL top ) + !%%% (7 ) Ox produced in Atlantic BL (surface - PBL top ) + !%%% (8 ) Ox produced in European BL (surface - PBL top ) + !%%% (9 ) Ox produced in N. African BL (surface - PBL top ) + !%%% (10) Ox produced in Asian (surface - PBL top ) + !%%% (11) Ox from the Stratosphere (tropopause - atm top ) + !%%% (12) Ox initial conditions (all levels ) + !%%% (13) Ox produced over the USA (all levels ) + ! + ! NOTE: MODIFIED FOR QUICKER SPINUP: + ! (1 ) Total Ox + ! (2 ) Ox from the Stratosphere (tropopause - atm top ) + ! (3 ) Ox initial conditions (all levels ) + !================================================================= + DO N = 1, N_TRACERS + + ! Zero ND44_TMP array + IF ( ND44 > 0 ) ND44_TMP = 0d0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, LL, PL, FREQ, Ox_0, Ox_LOST, FLUX, F_UNDER_TOP ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, LD65 ! LLTROP !_FIX + DO J = 1, JJPAR + DO I = 1, IIPAR + + !=========================================================== + ! Get P(Ox) and L(Ox) for each tagged tracer in [kg] + !=========================================================== + + ! P(Ox) is a function of geographic & altitude location + ! NOTE: We call this only when N==1 for optimal looping + IF ( N == 1 ) CALL GET_REGIONAL_POX( I, J, L, PP ) + + ! L(Ox) is originally in [1/cm3/s]; convert to [kg] + LL = STT_ADJ(I,J,L,N) * L24H(I,J,L) * BOXVL(I,J,L) * DTCHEM + +! !=========================================================== +! ! ND65 diagnostic: Chemical prod/loss [kg/s] +! !=========================================================== +! IF ( ND65 > 0 ) THEN +! +! ! Only archive chemical production if this +! ! region has production to begin with [kg/s] +! IF ( PP(I,J,L,N) > 0d0 ) THEN +! PL = P24H(I,J,L) * BOXVL(I,J,L) +! AD65(I,J,L,N) = AD65(I,J,L,N) + PL +! ENDIF +! +! ! Archive loss for all tracers [kg/s] +! PL = STT(I,J,L,N) * L24H(I,J,L) * BOXVL(I,J,L) +! AD65(I,J,L,N_TRACERS+N) = AD65(I,J,L,N_TRACERS+N) + PL +! ENDIF + + !=========================================================== + ! Apply drydep of Ox to each tagged tracer. We need + ! to do this using before P(Ox) - L(Ox) is applied. + !=========================================================== + IF ( LDRYD ) THEN + + ! Fraction of box underneath the PBL top [unitless] + F_UNDER_TOP = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + IF ( F_UNDER_TOP > 0d0 ) THEN + + ! Ox Drydep frequency [1/s] + FREQ = DEPSAV(I,J,1) * F_UNDER_TOP + + ! Only proceed if drydep frequency is nonzero + IF ( FREQ > 0d0 ) THEN + + ! Initial Ox [kg] + Ox_0 = STT_ADJ(I,J,L,N) + + ! Amount of Ox LOST to drydep [kg] + Ox_LOST = Ox_0 * ( 1d0 - EXP( -FREQ * DTCHEM ) ) + + ! Don't need to do this for adjoint (dkh, 03/08/10) + !! Prevent underflow condition + !IF ( Ox_LOST < 1d-20 ) Ox_LOST = 0d0 + + ! Subtract Ox lost [kg] + STT_ADJ(I,J,L,N) = Ox_0 - Ox_LOST + +! !================================================== +! ! ND44 diagnostic: Ox lost to drydep [molec/cm2/s] +! !================================================== +! IF ( ND44 > 0 .and. Ox_LOST > 0d0 ) THEN +! +! ! Convert from [kg] to [molec/cm2/s] +! FLUX = Ox_LOST * XNUMOL(IDTOX) / +! & GET_AREA_CM2(J) / DTCHEM +! +! ! Store dryd flx in ND44_TMP as a placeholder +! ND44_TMP(I,J,L) = ND44_TMP(I,J,L) + FLUX +! ENDIF + ENDIF + ENDIF + ENDIF + + !=========================================================== + ! After removing Ox lost to dry deposition, apply + ! chemical P(Ox) - L(Ox) to each tagged tracer + !=========================================================== + !lzh, 12/12/2009, adjoint chemistry for tagged ox + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) - LL + EMS_SF_ADJ(I,J,L,N) = EMS_SF_ADJ(I,J,L,IDADJ_POx) + + & STT_ADJ(I,J,L,N) * PP(I,J,L,N) + + ! dkh debug + !IF ( I == IFD .and. J == JFD .and. L == LFD ) THEN + ! print*, ' PP SUM adj = ', SUM(PP(I,J,L,:)), N + !ENDIF + + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + +! !============================================================== +! ! ND44: Sum drydep fluxes by level into the AD44 array in +! ! order to ensure that we get the same results w/ sp or mp +! !============================================================== +! IF ( ND44 > 0 ) THEN +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! DO L = 1, PBL_MAX +! AD44(I,J,N,1) = AD44(I,J,N,1) + ND44_TMP(I,J,L) +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO +! ENDIF + ENDDO + + ! Return to calling program + END SUBROUTINE CHEM_TAGGED_OX_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_TAGGED_OX_ADJ +! +!****************************************************************************** +! Subroutine INIT_TAGGED_OX allocates and zeroes all module arrays. +! (bmy, 8/20/03, 11/18/08) +! +! NOTES: +! (1 ) Now reference N_TRACERS from "tracer_mod.f" (bmy, 7/20/04) +! (2 ) Now use LD65 instead of LLTROP to dimension P24H, L24H (phs, 11/18/08) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND44, ND65, LD65 + + ! Local variables + INTEGER :: AS + + !================================================================= + ! INIT_TAGGED_OX begins here + !================================================================= + + ! Safety valve + IF ( N_TRACERS > N_TAGGED ) THEN + CALL ERROR_STOP( 'NTRACE is too large for Tagged Ox!', + & 'INIT_TAGGED_OX (tagged_ox_mod.f)' ) + ENDIF + + ! Allocate P24H + ALLOCATE( P24H( IIPAR, JJPAR, LD65 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'P24H' ) + P24H = 0d0 + + ! Allocate L24H + ALLOCATE( L24H( IIPAR, JJPAR, LD65 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'L24H' ) + L24H = 0d0 + + ! Return to calling program + END SUBROUTINE INIT_TAGGED_OX_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_TAGGED_OX_ADJ +! +!****************************************************************************** +! Subroutine CLEANUP_TAGGED_OX deallocates all module arrays (bmy, 8/20/03) +! +! NOTES: +!****************************************************************************** +! + ! Deallocate module arrays + IF ( ALLOCATED( P24H ) ) DEALLOCATE( P24H ) + IF ( ALLOCATED( L24H ) ) DEALLOCATE( L24H ) + + ! Return to calling program + END SUBROUTINE CLEANUP_TAGGED_OX_ADJ + +!------------------------------------------------------------------------------ + + END MODULE TAGGED_OX_ADJ_MOD diff --git a/code/adjoint/upbdflx_adj_mod.f b/code/adjoint/upbdflx_adj_mod.f new file mode 100644 index 0000000..b261301 --- /dev/null +++ b/code/adjoint/upbdflx_adj_mod.f @@ -0,0 +1,451 @@ +! $Id: upbdflx_adj_mod.f,v 1.3 2012/03/01 22:00:26 daven Exp $ + MODULE UPBDFLX_ADJ_MOD +! +!****************************************************************************** +! Module UPBDFLX_MOD contains subroutines which impose stratospheric boundary +! conditions on O3 and NOy (qli, bdf, mje, bmy, 6/28/01, 12/1/04) +! +! Module Variables: +! =========================================================================== +! (1 ) IORD (INTEGER) : TPCORE E/W transport option flag +! (2 ) JORD (INTEGER) : TPCORE N/S transport option flag +! (3 ) KORD (INTEGER) : TPCORE vertical transport option flag +! +! Module Routines: +! ============================================================================ +! (1 ) DO_UPBDFLX : Driver for stratospheric flux boundary conditions +! (2 ) UPBDFLX_O3 : Computes flux of O3 from stratosphere, using Synoz +! (3 ) UPBDFLX_NOY : Computes flux of NOy from stratosphere +! (4 ) INIT_UPBDFLX : Gets IORD, JORD, KORD values from "input_mod.f" +! +! GEOS-CHEM modules referenced by upbdflx_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module containing routines for binary punch file I/O +! (2 ) error_mod.f : Module containing NaN and other error check routines +! (3 ) logical_mod.f : Module containing GEOS-CHEM logical switches +! (4 ) tracer_mod.f : Module containing GEOS-CHEM tracer array STT etc. +! (5 ) tracerid_mod.f : Module containing pointers to tracers & emissions +! (6 ) pressure_mod.f : Module containing routines to compute P(I,J,L) +! +! NOTES: +! (1 ) Routine "upbdflx_noy" now correctly reprocessed P(NOy) files from +! /data/ctm/GEOS_4x5/pnoy_200106 or /data/ctm/GEOS_2x2.5/pnoy_200106. +! (mje, bmy, 6/28/01) +! (2 ) Updated comments (bmy, 9/4/01) +! (3 ) Fixes for reading binary punch files of global size (bmy, 9/27/01) +! (4 ) Removed obsolete commented out code from 9/01 (bmy, 10/24/01) +! (5 ) Removed obsolete commented out code from 7/01 (bmy, 11/26/01) +! (6 ) Updated comments (bmy, 5/28/02) +! (7 ) Replaced all instances of IM with IIPAR and JM with JJPAR, in ordr +! to prevent namespace confusion for the new TPCORE (bmy, 6/25/02) +! (8 ) Now references "pressure_mod.f" (dsa, bdf, bmy, 8/21/02) +! (9 ) Now references BXHEIGHT from "dao_mod.f". Also deleted obsolete +! code from 8/02. Now references IDTNOx, IDTOX, from "tracerid_mod.f" +! instead of from "comtrid.h". (bmy, 11/6/02) +! (10) Added driver routine DO_UPBDFLX. Also added lat limits for 1x1 in +! UPBDFLX_O3. (bmy, 3/14/03) +! (11) Now references AD from "dao_mod.f" in UPBDFLX_NOY (bnd, bmy, 4/14/03) +! (12) Added printout of O3 in Tg/yr in UPBDFLX_O3 (mje, bmy, 8/15/03) +! (13) Change O3 flux for GEOS-3 to 500 Tg/yr in UPBDFLX_O3 (bmy, 9/15/03) +! (14) Now references "tagged_ox_mod.f" (bmy, 8/19/03) +! (15) Now activated parallel DO loops (bmy, 4/15/04) +! (16) Now made IORD, JORD, KORD module variables. Now added routine +! SET_UPBDFLX. Now added routine SET_TRANSPORT (bmy, 7/20/04) +! (17) Bug fix for COMPAQ compiler. Now supports 1x125 grid. (bmy, 12/1/04) +!****************************************************************************** +! + IMPLICIT NONE + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "upbdflx_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: DO_UPBDFLX_ADJ + PUBLIC :: UPBDFLX_NOY_ADJ + + !================================================================= + ! MODULE VARIABLES + !================================================================= + INTEGER :: IORD, JORD, KORD + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_UPBDFLX_ADJ +! +!****************************************************************************** +! Subroutine DO_UPBDFLX is the driver routine for the stratospheric (upper- +! boundary) routines for Ox and NOy. (bmy, 3/11/03, 7/20/04) +! +! NOTES: +! (1 ) Removed IORD, JORD, KORD from the arg list. Now references LPRT +! from "logical_mod.f". Now references ITS_A_FULLCHEM_SIM and +! ITS_A_TAGOX_SIM from "tracer_mod.f" (bmy, 7/20/04) +! (2 ) Add UPBDFLX_NOY_ADJ (dkh, 02/22/10) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : DEBUG_MSG + USE LOGICAL_MOD, ONLY : LPRT + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_A_TAGOX_SIM + USE LINOZ_ADJ_MOD + +# include "CMN_SIZE" ! Size parameters + + !================================================================= + ! DO_UPBDFLX begins here! + !================================================================= + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + !--------------- + ! Fullchem run + !--------------- + + ! NOy from strat + CALL UPBDFLX_NOY_ADJ( 1 ) + + + ! Ox from strat +! CALL UPBDFLX_O3 + !dbj changed for linoz + CALL DO_LINOZ_ADJ + + ELSE IF ( ITS_A_TAGOX_SIM() ) THEN + + !--------------- + ! Tagged Ox run + !--------------- + + ! Ox from strat +! CALL UPBDFLX_O3 + !dbj changed for linoz + CALL DO_LINOZ_ADJ + + ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### DO_UPBDFLX: after strat fluxes' ) + + ! Return to calling program + END SUBROUTINE DO_UPBDFLX_ADJ +!------------------------------------------------------------------------------ + + SUBROUTINE UPBDFLX_NOY_ADJ( IFLAG ) +! +!****************************************************************************** +! Subroutine UPBDFLX_NOY_ADJ is the adjoint of UPBDFLX_NOY. (dkh, 02/22/10) +! +! Based on forward model routine by (qli, rvm, mje, bmy, 12/22/99, 8/4/06) +! +! Arguments as input: +! =========================================================================== +! (1) IFLAG : IFLAG=1 will partition [NOy] before transport +! IFLAG=2 will re-partition [NOy] after transport +! +! NOTES: +! (1 ) See forward model. +! +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DAO_MOD, ONLY : AD + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE ERROR_MOD, ONLY : ERROR_STOP + USE TRACERID_MOD, ONLY : IDTNOX, IDTHNO3 + USE TIME_MOD, ONLY : GET_TS_DYN, GET_MONTH + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH + USE TIME_MOD, ONLY : GET_NYMD + USE TIME_MOD, ONLY : GET_NYMDb + USE TRACER_MOD, ONLY : STT, XNUMOLAIR + USE TRANSFER_MOD, ONLY : TRANSFER_ZONAL + USE TROPOPAUSE_MOD, ONLY : GET_MIN_TPAUSE_LEVEL + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: IFLAG + + ! Local variables + INTEGER :: I, J, L, LMIN + INTEGER, SAVE :: LASTMONTH = -99 + + REAL*4 :: DTDYN, AIRDENS, PNOY + REAL*4 :: ARRAY(1,JGLOB,LGLOB) + + REAL*4 :: PNOY_ADJ + INTEGER :: MONTH_PRIOR + + ! Ratio of ( [NO] + [NO2] ) / [NOy] + REAL*4, SAVE :: XRATIO(JJPAR,LLPAR) + + ! Arrays for P(NOY), NO, NO2, and HNO3 concentrations + REAL*4, SAVE :: STRATPNOY(JJPAR,LLPAR) + REAL*4, SAVE :: STRATNO(JJPAR,LLPAR) + REAL*4, SAVE :: STRATNO2(JJPAR,LLPAR) + REAL*4, SAVE :: STRATHNO3(JJPAR,LLPAR) + + ! For P(NOy) above 10 mb + REAL*4, SAVE :: SPNOY10mb(JJPAR) + + ! TAU values for indexing the punch file + REAL*8 :: XTAU + + ! File Names + CHARACTER (LEN=255) :: FILENAME + CHARACTER (LEN=255) :: FILENAME2 + + ! External functions + REAL*8, EXTERNAL :: BOXVL + + !================================================================= + ! UPBDFLX_NOY_ADJ begins here! + !================================================================= + + ! Dynamic timestep [s] + DTDYN = GET_TS_DYN() * 60d0 + + !================================================================= + ! IFLAG = 1: Before transport + ! + ! If we have entered into a new month, read P(NOy), HNO3, + ! NO, and NO2 from disk (binary punch file format). + !================================================================= + IF ( IFLAG == 1 ) THEN + + ! fwd: + !IF ( ITS_A_NEW_MONTH() ) THEN + ! adj: + IF ( ITS_A_NEW_MONTH() .and. GET_NYMD() .ne. GET_NYMDb() ) THEN + + ! adj: calculate month prior + MONTH_PRIOR = GET_MONTH() - 1 + IF ( MONTH_PRIOR == 0 ) MONTH_PRIOR = 12 + + ! fwd: + ! TAU value corresponding to the beginning of this month + !XTAU = GET_TAU0( GET_MONTH(), 1, 1985 ) + ! adj: + ! TAU value corresponding to the beginning of previous month + XTAU = GET_TAU0( MONTH_PRIOR, 1, 1985 ) + + ! File containing P(NOy), NOx, HNO3 concentrations + ! Now read corrected file from pnoy_200106/ subdir (bmy, 6/28/01) + FILENAME = TRIM( DATA_DIR ) // + & 'pnoy_200106/pnoy_nox_hno3.' // + & GET_NAME_EXT() // '.' // GET_RES_EXT() + + ! Echo filename to stdout + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - UPBDFLX_NOY: Reading ', a ) + + ! P(NOy) in [v/v/s] is stored as tracer #1 + CALL READ_BPCH2( FILENAME, 'PNOY-L=$', 1, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR) + CALL TRANSFER_ZONAL( ARRAY(1,:,:), STRATPNOY ) + + ! [HNO3] in [v/v] is stored as tracer #2 + CALL READ_BPCH2( FILENAME, 'PNOY-L=$', 2, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR) + CALL TRANSFER_ZONAL( ARRAY(1,:,:), STRATHNO3 ) + + ! [NO] in [v/v] is stored as tracer #4 + CALL READ_BPCH2( FILENAME, 'PNOY-L=$', 4, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR) + CALL TRANSFER_ZONAL( ARRAY(1,:,:), STRATNO ) + + ! [NO2] in [v/v] is stored as tracer #5 + CALL READ_BPCH2( FILENAME, 'PNOY-L=$', 5, + & XTAU, 1, JGLOB, + & LGLOB, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR) + CALL TRANSFER_ZONAL( ARRAY(1,:,:), STRATNO2 ) + + !=========================================================== + ! XRATIO is the ratio ( [NO] + [NO2] ) / [NOy], + ! which is needed for the partitioning. + ! XRATIO will be the same for a given month + !=========================================================== + DO L = 1, LLPAR + DO J = 1, JJPAR + XRATIO(J,L) = ( STRATNO(J,L) + STRATNO2(J,L) ) / + & ( STRATNO(J,L) + STRATNO2(J,L) + + & STRATHNO3(J,L) ) + ENDDO + ENDDO + ENDIF + + !============================================================== + ! Initial partitioning of [NOy] to [NOx] and [HNO3], before + ! transport + ! + ! We use zonal mean values for stratospheric P(NOy), [NO], + ! [NO2], and [HNO3] taken from Dylan Jones' & Hans Schneider's + ! 2-D model. + ! + ! Since P(NOy) above 10mb accounts for almost 50% of the total + ! stratospheric production, we also dump P(NOy) above 10 mb + ! into the top layer of the model. These values are also + ! supplied to us by Dylan Jones. + ! + ! We make the following assumptions: + ! + ! (1) [NOx] = [NO] + [NO2] + ! (2) [NOy] = [NO] + [NO2] + [HNO3] = [NOx] + [HNO3] + ! + ! Therefore, in order to obtain [NOx] and [HNO3] from [NOy], + ! we must do the partitioning as follows: + ! + ! (1) [NOy] = P(NOy) + [NOx] + [HNO3] + ! = Production of NOy plus current + ! concentrations of NOx and HNO3 in the + ! given grid box + ! + ! (2) XRATIO = ( [NO] + [NO2] ) / [NOy] + ! + ! (3) P(NOx) = P(NOy) * XRATIO + ! + ! (4) P(HNO3) = P(NOy) * ( 1 - XRATIO ) + ! + ! XRATIO = ( [NO] + [NO2] ) / [NOy] approximates the true + ! ratio of [NOx] / [NOy], but is itself not the true ratio, + ! since our formulation of [NOy] neglects some additional + ! species (e.g. PAN, HNO4, N2O5, R4N2, PPN, PMN). + ! + ! At some future point we may take the additional constituents + ! of [NOy] into account. For now we proceed as outlined above. + !============================================================== + + ! Minimum value of LPAUSE + LMIN = GET_MIN_TPAUSE_LEVEL() + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, PNOY ) +!$OMP+PRIVATE( PNOY_ADJ ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = LMIN, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Skip over tropospheric boxes + IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN + + ! fwd code: + !STT(I,J,L,IDTHNO3) = PNOY * + ! MAX( ( 1d0 - XRATIO(J,L) ), 1d-20 ) + ! adj code: + PNOY_ADJ = STT_ADJ(I,J,L,IDTHNO3) * + & MAX( ( 1d0 - XRATIO(J,L) ), 1d-20 ) + + + ! fwd code: + !STT(I,J,L,IDTNOX) = PNOY * XRATIO(J,L) + ! adj code: + PNOY_ADJ = PNOY_ADJ + XRATIO(J,L) * STT_ADJ(I,J,L,IDTNOX) + + ! fwd code: + !PNOY = PNOY + STT(I,J,L,IDTNOX) + STT(I,J,L,IDTHNO3) + ! adj code: note that STT gets overwritten in fwd code + ! so STT_ADJ is not additive here. + STT_ADJ(I,J,L,IDTNOX) = PNOY_ADJ + STT_ADJ(I,J,L,IDTHNO3) = PNOY_ADJ + + + + ENDIF + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! IFLAG = 2: After transport + ! + ! Repartition [NOy] after transport into [NOx] + [HNO3] + ! + ! This repartitioning is necessary to avoid performing chemistry + ! between the [NO2] and [HNO3] species. + ! + ! The concentrations [NOx] and [HNO3] will have changed due to + ! transport, but the ratio used to partition them will be the + ! same. + !================================================================= + ELSE IF ( IFLAG == 2 ) THEN + + ! Minimum value of LPAUSE + LMIN = GET_MIN_TPAUSE_LEVEL() + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, PNOY ) +!$OMP+PRIVATE( PNOY_ADJ ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = LMIN, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Skip over tropospheric boxes + IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN + + ! Partition total [NOy] to [HNO3], units are [v/v] + !STT(I,J,L,IDTHNO3) = PNOY * + ! MAX( ( 1d0 - XRATIO(J,L) ), 1d-20 ) + PNOY_ADJ = STT_ADJ(I,J,L,IDTHNO3) * + & MAX( ( 1d0 - XRATIO(J,L) ), 1d-20 ) + + ! fwd code: + !STT(I,J,L,IDTNOX) = PNOY * XRATIO(J,L) + ! adj code: + PNOY_ADJ = PNOY_ADJ + XRATIO(J,L) * STT_ADJ(I,J,L,IDTNOX) + + ! fwd code: + !PNOY = STT(I,J,L,IDTNOX) + STT(I,J,L,IDTHNO3) + ! adj code: + STT_ADJ(I,J,L,IDTNOX) = PNOY_ADJ + STT_ADJ(I,J,L,IDTHNO3) = PNOY_ADJ + + + ENDIF + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ELSE + + ! If IFLAG /= 1 or IFLAG /= 2, print an error message and stop + CALL ERROR_STOP( 'IFLAG must be 1 or 2!', + & 'UPBDFLX_NOY_ADJ (upbdflx_adj_mod.f)' ) + + ENDIF + + ! Return to calling program + END SUBROUTINE UPBDFLX_NOY_ADJ + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE UPBDFLX_ADJ_MOD diff --git a/code/adjoint/weak_constraint_mod.f90 b/code/adjoint/weak_constraint_mod.f90 new file mode 100644 index 0000000..c56ddc6 --- /dev/null +++ b/code/adjoint/weak_constraint_mod.f90 @@ -0,0 +1,1029 @@ +MODULE WEAK_CONSTRAINT_MOD + + !! + !! ******************************************************************************** + !! + !! Module WEAK_CONSTRAINT_MOD contains subroutines and arrays needed for weak-constraint + !! 4D-VAR. mkeller. + !! + !! Module Variables: + !! ******************************************************************************** + !! + !! ( 1) FORCE_U_FULLGRID (REAL*8): values of estimated forcing on full model grid + !! ( 2) FORCE_U_SUBGRID (REAL*8): values of forcing on subgrid + !! ( 3) GRADNT_U (REAL*8): gradient of cost function with respect to forcing terms + !! ( 4) STT_ADJ_SUBGRID (REAL*8): values of adjoint variables on forcing subgrid + !! ( 5) X_U (REAL*8): values of forcing vector for optimization routine + !! ( 6) X_GRADNT_U (REAL*8): gradient of cost function for optimization routine + !! ( 7) MIN_LON_U (REAL*8): minimal longitude of forcing subgrid + !! ( 8) MAX_LON_U (REAL*8): maximal longitude of forcing subgrid + !! ( 9) MIN_LAT_U (REAL*8): minimal latitude of forcing subgrid + !! (10) MAX_LAT_U (REAL*8): maximal latitude of forcing subgrid + !! (11) SIGMA_U (REAL*8): standard deviation of forcing covariance matrix + !! (12) MIN_LON_U_INDEX (INTEGER): index of smallest subgrid longitude on full grid + !! (13) MAX_LON_U_INDEX (INTEGER): index of largest subgrid longitude on full grid + !! (14) MIN_LAT_U_INDEX (INTEGER): index of smallest subgrid latitude on full grid + !! (15) MAX_LAT_U_INDEX (INTEGER): index of largest subgrid latitude on full grid + !! (16) MIN_LEV_U_INDEX (INTEGER): index of smallest subgrid vertical level on full grid + !! (17) MAX_LEV_U_INDEX (INTEGER): index of largest subgrid vertical level on full grid + !! (18) LEN_LON_U (INTEGER): number of longitudes on subgrid + !! (19) LEN_LAT_U (INTEGER): number of latitudes on subgrid + !! (20) LEN_LEV_U (INTEGER): number of vertical levels on subgrid + !! (21) N_TIMESTEPS_U (INTEGER): number of forcing timesteps + !! (22) LEN_SUBWINDOW_U (INTEGER): number of subwindow timesteps (i.e. timesteps with the same forcing) + !! (23) CT_SUB_U (INTEGER): timestep in subwindow + !! (24) CT_MAIN_U (INTEGER): main forcing timestep + !! + !! Module Routines: + !! ******************************************************************************** + !! + !! ( 1 ) INITIALIZE_GRID_INDICES_U : initializes grid indices + !! ( 2 ) INIT_SETULB_U: allocates & zeroes arrays for optimization + !! ( 3 ) CLEAN_SETULB_U: deallocates arrays for optimization + !! ( 4 ) INIT_WEAK_CONSTRAINT: allocates & zeroes module arrays + !! ( 5 ) CLEAN_WEAK_CONSTRAINT: deallocates module arrays + !! ( 6 ) FORCE_SUBGRID_TO_FULLGRID_U: maps the estimated forcing from the subgrid to the full grid + !! ( 7 ) STT_ADJ_FULLGRID_TO_SUBGRID: maps adjoint concentrations from the full grid to the subgrid + !! ( 8 ) SET_CT_U: increments subwindow timestep + !! ( 9 ) SET_CT_MAIN_U: increments main forcing window timestep + !! (10 ) ITS_TIME_FOR_U: checks whether its time to update the forcing estimate + !! (11 ) CALC_GRADNT_U: update gradient of cost function with respect to forcing terms + !! (12 ) GET_X_U_FROM_FORCE_U: get X_U from FORCE_U_SUBGRID + !! (12 ) GET_FORCE_U_FROM_X_U: get FORCE_U_SUBGRID from X_U + !! (13 ) MAKE_FORCE_U_FILE: write forcing values to disk + !! (14 ) READ_FORCE_U_FILE: read forcing values from disk + !! + + IMPLICIT NONE +#include "CMN_SIZE" + + !! Define arrays needed for the computation of model forcing terms + + PUBLIC + + REAL*8, ALLOCATABLE :: FORCE_U_FULLGRID(:,:,:) !! Model forcing on full grid + REAL*8, ALLOCATABLE :: X_U(:,:) !! forcing array for optimization routines + REAL*8, ALLOCATABLE :: X_U_TEMP(:,:) !! temporary array needed during the computation of the gradient of the cost function + REAL*8, ALLOCATABLE :: X_GRADNT_U(:,:) !! forcing gradient array for optimization routines + + REAL*8 :: MIN_LON_U + REAL*8 :: MAX_LON_U + REAL*8 :: MIN_LAT_U + REAL*8 :: MAX_LAT_U + REAL*8 :: SCALE_FACTOR_U + REAL*8 :: SIGMA_U + + INTEGER :: N_TRACER_U + INTEGER :: MIN_LON_U_INDEX + INTEGER :: MAX_LON_U_INDEX + INTEGER :: MIN_LAT_U_INDEX + INTEGER :: MAX_LAT_U_INDEX + INTEGER :: MIN_LEV_U_INDEX + INTEGER :: MAX_LEV_U_INDEX + INTEGER :: LEN_LON_U + INTEGER :: LEN_LAT_U + INTEGER :: LEN_LEV_U + INTEGER :: N_TIMESTEPS_U + INTEGER :: LEN_SUBWINDOW_U + INTEGER :: CT_SUB_U + INTEGER :: CT_MAIN_U + LOGICAL :: DO_WEAK_CONSTRAINT + LOGICAL :: PERTURB_STT_U + INTEGER :: NOPT_U !! total number of gridpoints where forcing terms are estimated + + REAL*8 :: MOP_COST, FORCE_COST, BG_COST + REAL*8 :: WC_STD_DEV(IIPAR,JJPAR,38,1) + REAL*8 :: WC_SIGMA(IIPAR,JJPAR,LLPAR) + + +CONTAINS + + SUBROUTINE INITIALIZE_GRID_INDICES_U + !! + !! ********************************************************** + !! Subroutine INITIALIZE_GRID_INDICES_U initializes and zeroes all module arrays. + !! mkeller (15/09/2011) + !! ********************************************************** + + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + + ! local variables + INTEGER :: I + INTEGER :: J +# include "CMN_SIZE" ! Size parameters + + !! Calculate longitude array indices for forcing subgrid + + IF ( GET_XMID(1) >= MIN_LON_U ) MIN_LON_U_INDEX = 1 + + DO I = 2, IIPAR + + IF ( ( GET_XMID(I-1) < MIN_LON_U) .AND. ( GET_XMID(I) >= MIN_LON_U ) ) MIN_LON_U_INDEX = I + + IF ( ( GET_XMID(I-1) <= MAX_LON_U) .AND. ( GET_XMID(I) > MAX_LON_U ) ) MAX_LON_U_INDEX = I-1 + + ENDDO + + IF ( GET_XMID(IIPAR) <= MAX_LON_U ) MAX_LON_U_INDEX = IIPAR + + LEN_LON_U = MAX_LON_U_INDEX - MIN_LON_U_INDEX + 1 + + !! Calculate latitude array indices for forcing subgrid + + IF ( GET_YMID(1) >= MIN_LAT_U ) MIN_LAT_U_INDEX = 1 + + DO J = 2, JJPAR + + IF ( ( GET_YMID(J-1) < MIN_LAT_U ) .AND. ( GET_YMID(J) >= MIN_LAT_U ) ) MIN_LAT_U_INDEX = J + IF ( ( GET_YMID(J-1) <= MAX_LAT_U ) .AND. ( GET_YMID(J) > MAX_LAT_U ) ) MAX_LAT_U_INDEX = J-1 + + ENDDO + + IF ( GET_YMID(JJPAR) <= MAX_LAT_U ) MAX_LAT_U_INDEX = JJPAR + + LEN_LAT_U = MAX_LAT_U_INDEX - MIN_LAT_U_INDEX + 1 + LEN_LEV_U = MAX_LEV_U_INDEX - MIN_LEV_U_INDEX + 1 + + !! Calculate total number of forcing gridpoints to be optimized + + NOPT_U = LEN_LON_U * LEN_LAT_U * LEN_LEV_U + + !PRINT *,'WEAK_CONSTRAINT: MIN_LON_U' , MIN_LON_U, GET_XMID(MIN_LON_U_INDEX) + !PRINT *,'WEAK_CONSTRAINT: MIN_LAT_U' , GET_YMID(MIN_LAT_U_INDEX) + !PRINT *,'WEAK_CONSTRAINT: MAX_LON_U' , MAX_LON_U, GET_XMID(MAX_LON_U_INDEX) + !PRINT *,'WEAK_CONSTRAINT: MAX_LAT_U' , GET_YMID(MAX_LAT_U_INDEX) + + END SUBROUTINE INITIALIZE_GRID_INDICES_U + + SUBROUTINE INIT_WEAK_CONSTRAINT + !! + !! ********************************************************** + !! Subroutine INIT_WEAK_CONSTRAINT initializes and zeroes all module arrays. + !! mkeller (15/09/2011) + !! ********************************************************** + !! + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : CALC_RUN_DAYS + USE TIME_MOD, ONLY : GET_TS_DYN + USE TRACER_MOD, ONLY : N_TRACERS + +#include "CMN_SIZE" ! Size parameters + + INTEGER :: AS, DAYS, TS_DYN + + SCALE_FACTOR_U = 30 * 1E-10 + SIGMA_U = 3 * 1E-9 + + !! Compute grid indices + CALL INITIALIZE_GRID_INDICES_U + + DAYS = CALC_RUN_DAYS() + TS_DYN = GET_TS_DYN() + + !! Allow for forcing terms to be estimated at a subset of timesteps + N_TIMESTEPS_U = (DAYS * 24 * 60 / TS_DYN) / (LEN_SUBWINDOW_U) + 1 + + !! Initialize time counters. Note that in the adjoint calculation, time runs backwards + CT_SUB_U = -1 + CT_MAIN_U = 1 + + !! Allocate all required arrays + ALLOCATE( FORCE_U_FULLGRID(IIPAR,JJPAR,LLPAR), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'FORCE_U_FULLGRID' ) + FORCE_U_FULLGRID = 0d0 + + ALLOCATE( X_U ( NOPT_U, N_TIMESTEPS_U ) ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'X_U' ) + X_U = 0d0 + + ALLOCATE( X_U_TEMP ( NOPT_U, N_TIMESTEPS_U ) ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'X_U_TEMP' ) + X_U_TEMP = 0d0 + + ALLOCATE( X_GRADNT_U ( NOPT_U, N_TIMESTEPS_U ) ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'X_GRADNT_U' ) + X_GRADNT_U = 0d0 + + !PRINT *,'WEAK_CONSTRAINT: NOPT_U: ',NOPT_U + + FORCE_COST = 0d0 + + !CALL READ_STANDARD_DEVIATIONS + + END SUBROUTINE INIT_WEAK_CONSTRAINT + + SUBROUTINE CLEAN_WEAK_CONSTRAINT + + !! + !! ********************************************************** + !! Subroutine CLEAN_WEAK_CONSTRAINT deallocates the arrays needed for weak-constraint 4D-VAR + !! mkeller (15/09/2011) + !! ********************************************************** + !! + + IF ( ALLOCATED ( FORCE_U_FULLGRID ) )DEALLOCATE (FORCE_U_FULLGRID) + IF ( ALLOCATED ( X_U ) )DEALLOCATE ( X_U ) + IF ( ALLOCATED ( X_U_TEMP ) )DEALLOCATE ( X_U_TEMP ) + IF ( ALLOCATED ( X_GRADNT_U ) )DEALLOCATE ( X_GRADNT_U ) + + END SUBROUTINE CLEAN_WEAK_CONSTRAINT + + SUBROUTINE READ_STANDARD_DEVIATIONS + + USE NETCDF + + INTEGER :: FILE_ID, CO_ID, RESULT + INTEGER :: I,J,L + + !! read in standard deviations from netcdf file + + RESULT = NF90_OPEN( "wc_std/CO_monthly_STDEV_const.20060331.nc", NF90_NOWRITE, FILE_ID ) + + CALL HANDLE_ERR( RESULT ) + + RESULT = NF90_INQ_VARID( FILE_ID, "IJ_AVG_S__CO", CO_ID ) + + CALL HANDLE_ERR( RESULT ) + + RESULT = NF90_GET_VAR ( FILE_ID, CO_ID, WC_STD_DEV, START=(/1,1,1,1/), COUNT = (/IIPAR,JJPAR,38,1/) ) + + CALL HANDLE_ERR( RESULT ) + + RESULT = NF90_CLOSE( FILE_ID ) + + CALL HANDLE_ERR( RESULT ) + + !! only use standard deviation values between model level 20 and 31 + !! (hardcoded for GEOS-5 grid) + + DO L=1,LLPAR + DO J=1,JJPAR + DO I=1,IIPAR + + IF( L<20 ) THEN + WC_SIGMA(I,J,L) = WC_STD_DEV(I,J,20,1) + ELSE IF ( L>31 ) THEN + WC_SIGMA(I,J,L) = WC_STD_DEV(I,J,31,1) + ELSE + WC_SIGMA(I,J,L) = WC_STD_DEV(I,J,L,1) + END IF + + END DO + END DO + END DO + + # convert from ppbv to v/v + + WC_SIGMA = WC_SIGMA * 1E-9 * 1.0 + + !PRINT *,"Standard deviations: " + !PRINT *,WC_SIGMA + + END SUBROUTINE READ_STANDARD_DEVIATIONS + + SUBROUTINE HANDLE_ERR( RESULT ) + + USE NETCDF + INTEGER, INTENT(IN) :: RESULT + + IF( RESULT .NE. NF90_NOERR ) THEN + + PRINT *,NF90_STRERROR(RESULT) + + ENDIF + + END SUBROUTINE HANDLE_ERR + + SUBROUTINE SET_CT_U ( INCREASE, RESET , FLIP ) + + !! + !! ********************************************************** + !! Subroutine SET_CT_U increments the time counter for the forcing subwindow. + !! ********************************************************** + !! + + LOGICAL, INTENT(IN), OPTIONAL :: INCREASE + LOGICAL, INTENT(IN), OPTIONAL :: RESET + LOGICAL, INTENT(IN), OPTIONAL :: FLIP + + IF ( PRESENT ( RESET ) ) THEN + CT_SUB_U = 0 + ENDIF + + IF( PRESENT ( FLIP ) ) THEN + + !! this option is implemented because subwindow timers are always counted + !! upwards, i.e. the subwindow timer always increases up to LEN_SUBWINDOW_U + + !PRINT *,'WEAK_CONSTRAINT: BEFORE',CT_SUB_U + IF(CT_SUB_U == 0) THEN + CT_SUB_U=0 + ELSE + CT_SUB_U = LEN_SUBWINDOW_U - CT_SUB_U + ENDIF + !PRINT *,'WEAK_CONSTRAINT: AFTER',CT_SUB_U + + ENDIF + + IF( PRESENT ( INCREASE ) ) THEN + + !! right now, only the INCREASE==TRUE option is used. + !! leave code for INCREASE==FALSE option in, just in case. + + IF ( INCREASE) THEN + CT_SUB_U = CT_SUB_U + 1 + ELSE + CT_SUB_U = CT_SUB_U - 1 + ENDIF + + ENDIF + !! return to calling program + + END SUBROUTINE SET_CT_U + + SUBROUTINE SET_CT_MAIN_U( INCREASE, RESET ) + + !! + !! ********************************************************** + !! Subroutine SET_CT_MAIN_U increases/decreases the time counter for the main forcing time window. + !! ********************************************************** + !! + + LOGICAL, INTENT(IN), OPTIONAL :: INCREASE + LOGICAL, INTENT(IN), OPTIONAL :: RESET + + IF ( PRESENT ( RESET ) ) THEN + CT_MAIN_U = 1 + RETURN + END IF + + IF ( PRESENT ( INCREASE ) ) THEN + IF ( INCREASE ) THEN + CT_MAIN_U = CT_MAIN_U + 1 + ELSE + CT_MAIN_U = CT_MAIN_U - 1 + END IF + ELSE + CT_MAIN_U = CT_MAIN_U + 1 + END IF + + END SUBROUTINE SET_CT_MAIN_U + + FUNCTION ITS_TIME_FOR_U () RESULT ( FLAG ) + + !! + !! ********************************************************** + !! Subroutine ITS_TIME_FOR_U returns true if it's time to estimate the new forcing terms + !! ********************************************************** + !! + + LOGICAL :: FLAG + + FLAG = .FALSE. + + IF (CT_SUB_U == LEN_SUBWINDOW_U) FLAG = .TRUE. + + !! return to calling program + + END FUNCTION ITS_TIME_FOR_U + + SUBROUTINE CALC_GRADNT_U(YYYYMMDD,HHMMSS) + + !! + !! ********************************************************** + !! Subroutine CALC_GRADNT_U updates the gradient of the cost function with respect to u + !! and calculates the new estimates once all the required data have been gathered + !! ********************************************************** + !! + + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + X_GRADNT_U(:,CT_MAIN_U) = X_GRADNT_U(:,CT_MAIN_U) + GET_STT_X_U() + + !PRINT *,'WEAK_CONSTRAINT: IN CALC_GRADNT_U' + !PRINT *,'WEAK_CONSTARAINT:',YYYYMMDD,HHMMSS + !PRINT *,'WEAK_CONSTRAINT:',CT_SUB_U,CT_MAIN_U + + IF ( ITS_TIME_FOR_U() ) THEN + + CALL GET_FORCE_U_FROM_X_U + + CALL COMPUTE_APRIORI_U + + X_GRADNT_U(:,CT_MAIN_U) = X_GRADNT_U(:,CT_MAIN_U) + X_U_TEMP(:,CT_MAIN_U) + + ! ensure that gradient of J with respect to forcing terms is consistent with other gradients + X_GRADNT_U(:,CT_MAIN_U) = X_GRADNT_U(:,CT_MAIN_U) * 2.0 + + CALL SET_CT_U ( RESET = .TRUE. ) + + CALL SET_CT_MAIN_U ( INCREASE = .FALSE. ) + + ENDIF + + END SUBROUTINE CALC_GRADNT_U + + SUBROUTINE GET_X_U_FROM_FORCE_U + + !! + !! *************************************************************************************** + !! SUBROUTINE GET_FORCE_U FROM_X_U obtains the array X_U from the current forcing estimate + !! *************************************************************************************** + !! + + USE TRACER_MOD, ONLY : N_TRACERS + + ! Local variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + + !DO N = 1, N_TRACERS + DO L = MIN_LEV_U_INDEX, MAX_LEV_U_INDEX + DO J = MIN_LAT_U_INDEX, MAX_LAT_U_INDEX + DO I = MIN_LON_U_INDEX, MAX_LON_U_INDEX + + I_DUM = (I - MIN_LON_U_INDEX + 1) + & + (LEN_LON_U * ( J - MIN_LAT_U_INDEX ) ) + & + ( LEN_LON_U * LEN_LAT_U * ( L - MIN_LEV_U_INDEX )) + !&+( LEN_LON_U * LEN_LAT_U * LEN_LEV_U * ( N - 1 ) ) + + X_U( I_DUM , CT_MAIN_U) = FORCE_U_FULLGRID( I, J, L)!, N ) + + ENDDO + ENDDO + ENDDO + + END SUBROUTINE GET_X_U_FROM_FORCE_U + + SUBROUTINE COMPUTE_APRIORI_U + + !! + !!**************************************************************************** + !! SUBROUTINE COMPUTE_APRIORI_U computes the apriori-term (i.e. the Q-matrix term) + !!**************************************************************************** + !! + + USE TRACER_MOD, ONLY : N_TRACERS + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + + ! Local variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + REAL*8 :: COST_TEMP + + !PRINT *,"MKDB: COST BEFORE FORCE: ",COST_FUNC + COST_TEMP = COST_FUNC + + !PRINT *,"MKDB: MAX FORCE", MAXVAL(FORCE_U_FULLGRID) + + ! DO N = 1, N_TRACERS + DO L = MIN_LEV_U_INDEX, MAX_LEV_U_INDEX + DO J = MIN_LAT_U_INDEX, MAX_LAT_U_INDEX + DO I = MIN_LON_U_INDEX, MAX_LON_U_INDEX + + I_DUM = ( I - MIN_LON_U_INDEX + 1) + & + ( LEN_LON_U * ( J - MIN_LAT_U_INDEX ) ) + & + ( LEN_LON_U * LEN_LAT_U * ( L - MIN_LEV_U_INDEX )) + ! &+( LEN_LON_U * LEN_LAT_U * LEN_LEV_U * ( N - 1 ) ) + + IF ( L< ( MIN_LEV_U_INDEX + 3 ) ) THEN + + X_U_TEMP( I_DUM , CT_MAIN_U) = FORCE_U_FULLGRID( I, J, L )/( ( SIGMA_U *1/(1+MIN_LEV_U_INDEX + 3-L) )**2) + COST_FUNC = COST_FUNC + FORCE_U_FULLGRID( I, J, L)**2 /( ( SIGMA_U *1/(1+MAX_LEV_U_INDEX + 3 - L) )**2) + + ELSE IF ( L > ( MAX_LEV_U_INDEX - 3 ) ) THEN + + X_U_TEMP( I_DUM , CT_MAIN_U) = FORCE_U_FULLGRID( I, J, L ) /( ( SIGMA_U *1/(1+MAX_LEV_U_INDEX - 3 + L) )**2) + COST_FUNC = COST_FUNC + FORCE_U_FULLGRID( I, J, L )**2 /( ( SIGMA_U *1/(1+MAX_LEV_U_INDEX - 3 + L) )**2) + + ELSE + + X_U_TEMP( I_DUM , CT_MAIN_U) = FORCE_U_FULLGRID( I, J, L ) /( SIGMA_U **2) + COST_FUNC = COST_FUNC + FORCE_U_FULLGRID( I, J, L )**2 /( SIGMA_U **2) + + ENDIF + + ENDDO + ENDDO + ENDDO + ! ENDDO + + FORCE_COST = COST_FUNC - COST_TEMP + FORCE_COST + + !PRINT *,"FORCE_COST: ", FORCE_COST + + END SUBROUTINE COMPUTE_APRIORI_U + + FUNCTION GET_STT_X_U() RESULT ( STT_X_U ) + + !! + !! ********************************************************** + !! FUNCTION GET_STT_X_U reads the value of STT_ADJ into a 1D-array + !! ********************************************************** + !! + + USE TRACER_MOD, ONLY : N_TRACERS + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + + ! Local variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + REAL*8 :: STT_X_U ( NOPT_U ) + + !PRINT *,'WEAK_CONSTRAINT: MAX_STT_ADJ',MAXVAL(STT_ADJ) + + ! DO N = 1, N_TRACERS + DO L = MIN_LEV_U_INDEX, MAX_LEV_U_INDEX + DO J = MIN_LAT_U_INDEX, MAX_LAT_U_INDEX + DO I = MIN_LON_U_INDEX, MAX_LON_U_INDEX + + I_DUM = (I - MIN_LON_U_INDEX + 1) + & + (LEN_LON_U * ( J - MIN_LAT_U_INDEX ) ) + & + (LEN_LON_U * LEN_LAT_U * ( L - MIN_LEV_U_INDEX )) + ! &+( LEN_LON_U * LEN_LAT_U * LEN_LEV_U * ( N - 1 ) ) + + ! I_DUM = (I - MIN_LON_U_INDEX + 1) + ( LEN_LON_U * ( J - MIN_LAT_U_INDEX ) ) & + ! + ( LEN_LON_U * LEN_LAT_U * ( L - MIN_LEV_U_INDEX ) ) & + ! + ( LEN_LON_U * LEN_LAT_U * LEN_LEV_U * ( N - 1 ) ) + + STT_X_U( I_DUM ) = STT_ADJ( I, J, L, N_TRACER_U ) + + ENDDO + ENDDO + ENDDO + ! ENDDO + + END FUNCTION GET_STT_X_U + + SUBROUTINE MAKE_GDT_U_FILE( ) +! + !****************************************************************************** + ! Subroutine MAKE_GDT_FILE creates a binary file of forcing gradients + ! mkeller + !****************************************************************************** + ! + ! References to F90 modules + + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + + ! Local Variables + + CHARACTER(LEN=255) :: FILENAME + + INTEGER :: I, J + + CHARACTER(LEN=20) :: OUTPUT_GDT_FILE + CHARACTER(LEN=40) :: UNIT + + ! Hardwire output file for now + OUTPUT_GDT_FILE = 'gctm.gdt.forcing.NN' + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_GDT_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the OPTDATA_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + OPEN( UNIT = IU_RST, FILE = FILENAME, FORM = 'UNFORMATTED' ) + + DO I=1,NOPT_U + DO J=1,N_TIMESTEPS_U + + WRITE( IU_RST ) X_GRADNT_U(I,J) + + ENDDO + ENDDO + + CLOSE ( IU_RST ) + + END SUBROUTINE MAKE_GDT_U_FILE + + SUBROUTINE READ_GDT_U_FILE( ) + + ! + !****************************************************************************** + ! Subroutine MAKE_GDT_FILE creates a binary file of forcing gradients + ! mkeller + !****************************************************************************** + ! + ! References to F90 modules + + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + + ! Local Variables + + CHARACTER(LEN=255) :: FILENAME + + INTEGER :: I, J + + CHARACTER(LEN=20) :: OUTPUT_GDT_FILE + CHARACTER(LEN=40) :: UNIT + + + ! Hardwire output file for now + OUTPUT_GDT_FILE = 'gctm.gdt.forcing.NN' + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_GDT_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the OPTDATA_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + OPEN( UNIT = IU_RST, FILE = FILENAME, FORM = 'UNFORMATTED' ) + + DO I=1,NOPT_U + DO J=1,N_TIMESTEPS_U + + READ( IU_RST ) X_GRADNT_U(I,J) + + ENDDO + ENDDO + + CLOSE ( IU_RST ) + + ! Return to calling program + END SUBROUTINE READ_GDT_U_FILE + + SUBROUTINE GET_FORCE_U_FROM_X_U + + !! + !! ********************************************************** + !! SUBROUTINE GET_FORCE_U FROM_X_U obtains the current forcing estimate from the X_U array + !! ********************************************************** + !! + + USE TRACER_MOD, ONLY : N_TRACERS +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + + I_DUM = 0 + ! DO N = 1, N_TRACERS + DO L = MIN_LEV_U_INDEX, MAX_LEV_U_INDEX + DO J = MIN_LAT_U_INDEX, MAX_LAT_U_INDEX + DO I = MIN_LON_U_INDEX, MAX_LON_U_INDEX + + I_DUM = (I - MIN_LON_U_INDEX + 1) + & + (LEN_LON_U * ( J - MIN_LAT_U_INDEX ) ) + & + (LEN_LON_U * LEN_LAT_U * ( L - MIN_LEV_U_INDEX )) + ! &+( LEN_LON_U * LEN_LAT_U * LEN_LEV_U * ( N - 1 ) ) + + FORCE_U_FULLGRID( I, J, L ) = X_U( I_DUM, CT_MAIN_U ) + + ENDDO + ENDDO + ENDDO + ! ENDDO + + END SUBROUTINE GET_FORCE_U_FROM_X_U + + SUBROUTINE MAKE_FORCE_U_FILE( YYYYMMDD, HHMMSS ) + + ! + !****************************************************************************** + ! Subroutine MAKE_ADJ_FILE creates a binary file of STT_ADJ + ! (dkh, 10/03/04)exit + + ! + ! Arguments as Input: + ! ============================================================================ + ! (1 ) YYYYMMDD : Year-Month-Date + ! (2 ) HHMMSS : and Hour-Min-Sec for which to create an adjoint file + ! + + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LTRAJ_SCALE + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : STT + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=40) :: OUTPUT_FORCE_U_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + ! Should make these user defined in input.gcadj + !! Parameter + INTEGER, PARAMETER :: LLADJKEEP = LLPAR + !INTEGER, PARAMETER :: NNADJKEEP = N_TRACERS + ! Now specify this input.gcadj + !LOGICAL, PARAMETER :: LTRAJ_SCALE = .TRUE. + + !================================================================= + ! MAKE_FORCE_U_FILE begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_FORCE_U_FILE = 'gctm.forcing.YYYYMMDD.hhmm' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM Forcing File: Instantaneous Forcing Values' + CATEGORY = 'IJ-ADJ-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the force file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_FORCE_U_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add the ADJ_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + !WRITE( 6, 100 ) TRIM( FILENAME ) + !FORMAT( ' - MAKE_ADJ_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write forcing for each observed quantity to the forcing file + !================================================================= + !DO N = 1, N_TRACERS + + UNIT = 'J' + + !Temporarily store quantities in the TRACER array + + + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + TRACER(I,J,L) = FORCE_U_FULLGRID(I,J,L) + + ENDDO + ENDDO + ENDDO + + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, & + HALFPOLAR, CENTER180, CATEGORY, 1, & + UNIT, GET_TAU(), GET_TAU(), RESERVED, & + IIPAR, JJPAR, LLPAR, I0+1, & + J0+1, 1, TRACER ) + +! ENDDO + + ! TRACER = STT(:,:,:,1) + +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N_TRACERS+1, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, TRACER ) + + ! Close file + CLOSE( IU_RST ) + + END SUBROUTINE MAKE_FORCE_U_FILE + + SUBROUTINE READ_FORCE_U_FILE( YYYYMMDD, HHMMSS ) + + ! + !****************************************************************************** + ! Subroutine READ_FORCE_U_FILE reads forcing values + ! from a checkpoint file (binary punch file format) + ! (dkh, 8/30/04) + ! + ! Arguments as input: + ! ============================================================================ + ! (1 ) YYYYMMDD : Year-Month-Day + ! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file + ! + ! Passed via CMN: + ! ============================================================================ + ! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval + ! + + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE COMODE_MOD, ONLY : CHK_CSPEC, JLOP + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GCKPP_ADJ_GLOBAL, ONLY : NTT + USE LOGICAL_MOD, ONLY : LCHEM , LSULF + USE LOGICAL_MOD, ONLY : LSOILNOX, LLIGHTNOX + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LAERO_THERM + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : N_TRACERS + USE UNIX_CMDS_MOD, ONLY : REMOVE_CMD + +# include "CMN_SIZE" ! Size parameters +!# include "comode.h" ! ITLOOP, IGAS +# include "CMN_VEL" ! XYLAI + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N, JLOOP, NN, NTL + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + ! Remove these since we always recompute instead + ! of checkpointing (dkh, 06/11/09) + ! REAL*4 :: CHECK1(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK2(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK3(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK4(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK5(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK6(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK7(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK8(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK9(IIPAR,JJPAR,LLPAR) + !REAL*4 :: SMVGARRAY(ITLOOP,IGAS) + + !>>> + ! Now include adjoint of F (dkh, 10/03/08) + INTEGER :: NS + !<<< + + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: UNZIP_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL, NV + INTEGER :: IJLOOP + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + ! added by Martin Keller + + CHARACTER(LEN=255) :: INPUT_FILE + LOGICAL :: EX + + !================================================================= + ! READ_FORCE_U_FILE begins here! + !================================================================= + + ! Hardwire output file for now + INPUT_FILE = 'gctm.forcing.YYYYMMDD.hhmm' + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open checkpoint file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'F O R C I N G F I L E I N P U T' + + !WRITE( 6, 100 ) TRIM( FILENAME ) + !FORMAT( ' - READ_FORCE_U_FILE: Reading ', a ) + + ! MAKE SURE FILE EXISTS + + INQUIRE( FILE = FILENAME, EXIST=EX) + + IF( .NOT. EX ) THEN + CALL MAKE_FORCE_U_FILE(YYYYMMDD,HHMMSS) + RETURN + ENDIF + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + ! DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + ! IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:7' ) + + READ( IU_RST, IOSTAT=IOS ) & + CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, & + NI, NJ, NL, IFIRST, JFIRST, LFIRST, & + NSKIP + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_RST,'read_checkpt_file:8' ) + + READ( IU_RST, IOSTAT=IOS ) ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + PRINT *,'WEAK_CONSTRAINT: TRACER ',MINVAL(TRACER),MAXVAL(TRACER) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:9') + + !============================================================== + ! Assign data from the TRACER array to the FORCE_U_FULLGRID array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + !IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + ! CALL CHECK_DIMENSIONS( NI, NJ, NL ) + + + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + FORCE_U_FULLGRID(I,J,L) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO + + !ENDIF + ! ENDDO + + ! Close file + + CLOSE( IU_RST ) + + END SUBROUTINE READ_FORCE_U_FILE + +END MODULE WEAK_CONSTRAINT_MOD diff --git a/code/adjoint/weak_constraint_mod.f90~ b/code/adjoint/weak_constraint_mod.f90~ new file mode 100644 index 0000000..c56ddc6 --- /dev/null +++ b/code/adjoint/weak_constraint_mod.f90~ @@ -0,0 +1,1029 @@ +MODULE WEAK_CONSTRAINT_MOD + + !! + !! ******************************************************************************** + !! + !! Module WEAK_CONSTRAINT_MOD contains subroutines and arrays needed for weak-constraint + !! 4D-VAR. mkeller. + !! + !! Module Variables: + !! ******************************************************************************** + !! + !! ( 1) FORCE_U_FULLGRID (REAL*8): values of estimated forcing on full model grid + !! ( 2) FORCE_U_SUBGRID (REAL*8): values of forcing on subgrid + !! ( 3) GRADNT_U (REAL*8): gradient of cost function with respect to forcing terms + !! ( 4) STT_ADJ_SUBGRID (REAL*8): values of adjoint variables on forcing subgrid + !! ( 5) X_U (REAL*8): values of forcing vector for optimization routine + !! ( 6) X_GRADNT_U (REAL*8): gradient of cost function for optimization routine + !! ( 7) MIN_LON_U (REAL*8): minimal longitude of forcing subgrid + !! ( 8) MAX_LON_U (REAL*8): maximal longitude of forcing subgrid + !! ( 9) MIN_LAT_U (REAL*8): minimal latitude of forcing subgrid + !! (10) MAX_LAT_U (REAL*8): maximal latitude of forcing subgrid + !! (11) SIGMA_U (REAL*8): standard deviation of forcing covariance matrix + !! (12) MIN_LON_U_INDEX (INTEGER): index of smallest subgrid longitude on full grid + !! (13) MAX_LON_U_INDEX (INTEGER): index of largest subgrid longitude on full grid + !! (14) MIN_LAT_U_INDEX (INTEGER): index of smallest subgrid latitude on full grid + !! (15) MAX_LAT_U_INDEX (INTEGER): index of largest subgrid latitude on full grid + !! (16) MIN_LEV_U_INDEX (INTEGER): index of smallest subgrid vertical level on full grid + !! (17) MAX_LEV_U_INDEX (INTEGER): index of largest subgrid vertical level on full grid + !! (18) LEN_LON_U (INTEGER): number of longitudes on subgrid + !! (19) LEN_LAT_U (INTEGER): number of latitudes on subgrid + !! (20) LEN_LEV_U (INTEGER): number of vertical levels on subgrid + !! (21) N_TIMESTEPS_U (INTEGER): number of forcing timesteps + !! (22) LEN_SUBWINDOW_U (INTEGER): number of subwindow timesteps (i.e. timesteps with the same forcing) + !! (23) CT_SUB_U (INTEGER): timestep in subwindow + !! (24) CT_MAIN_U (INTEGER): main forcing timestep + !! + !! Module Routines: + !! ******************************************************************************** + !! + !! ( 1 ) INITIALIZE_GRID_INDICES_U : initializes grid indices + !! ( 2 ) INIT_SETULB_U: allocates & zeroes arrays for optimization + !! ( 3 ) CLEAN_SETULB_U: deallocates arrays for optimization + !! ( 4 ) INIT_WEAK_CONSTRAINT: allocates & zeroes module arrays + !! ( 5 ) CLEAN_WEAK_CONSTRAINT: deallocates module arrays + !! ( 6 ) FORCE_SUBGRID_TO_FULLGRID_U: maps the estimated forcing from the subgrid to the full grid + !! ( 7 ) STT_ADJ_FULLGRID_TO_SUBGRID: maps adjoint concentrations from the full grid to the subgrid + !! ( 8 ) SET_CT_U: increments subwindow timestep + !! ( 9 ) SET_CT_MAIN_U: increments main forcing window timestep + !! (10 ) ITS_TIME_FOR_U: checks whether its time to update the forcing estimate + !! (11 ) CALC_GRADNT_U: update gradient of cost function with respect to forcing terms + !! (12 ) GET_X_U_FROM_FORCE_U: get X_U from FORCE_U_SUBGRID + !! (12 ) GET_FORCE_U_FROM_X_U: get FORCE_U_SUBGRID from X_U + !! (13 ) MAKE_FORCE_U_FILE: write forcing values to disk + !! (14 ) READ_FORCE_U_FILE: read forcing values from disk + !! + + IMPLICIT NONE +#include "CMN_SIZE" + + !! Define arrays needed for the computation of model forcing terms + + PUBLIC + + REAL*8, ALLOCATABLE :: FORCE_U_FULLGRID(:,:,:) !! Model forcing on full grid + REAL*8, ALLOCATABLE :: X_U(:,:) !! forcing array for optimization routines + REAL*8, ALLOCATABLE :: X_U_TEMP(:,:) !! temporary array needed during the computation of the gradient of the cost function + REAL*8, ALLOCATABLE :: X_GRADNT_U(:,:) !! forcing gradient array for optimization routines + + REAL*8 :: MIN_LON_U + REAL*8 :: MAX_LON_U + REAL*8 :: MIN_LAT_U + REAL*8 :: MAX_LAT_U + REAL*8 :: SCALE_FACTOR_U + REAL*8 :: SIGMA_U + + INTEGER :: N_TRACER_U + INTEGER :: MIN_LON_U_INDEX + INTEGER :: MAX_LON_U_INDEX + INTEGER :: MIN_LAT_U_INDEX + INTEGER :: MAX_LAT_U_INDEX + INTEGER :: MIN_LEV_U_INDEX + INTEGER :: MAX_LEV_U_INDEX + INTEGER :: LEN_LON_U + INTEGER :: LEN_LAT_U + INTEGER :: LEN_LEV_U + INTEGER :: N_TIMESTEPS_U + INTEGER :: LEN_SUBWINDOW_U + INTEGER :: CT_SUB_U + INTEGER :: CT_MAIN_U + LOGICAL :: DO_WEAK_CONSTRAINT + LOGICAL :: PERTURB_STT_U + INTEGER :: NOPT_U !! total number of gridpoints where forcing terms are estimated + + REAL*8 :: MOP_COST, FORCE_COST, BG_COST + REAL*8 :: WC_STD_DEV(IIPAR,JJPAR,38,1) + REAL*8 :: WC_SIGMA(IIPAR,JJPAR,LLPAR) + + +CONTAINS + + SUBROUTINE INITIALIZE_GRID_INDICES_U + !! + !! ********************************************************** + !! Subroutine INITIALIZE_GRID_INDICES_U initializes and zeroes all module arrays. + !! mkeller (15/09/2011) + !! ********************************************************** + + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + + ! local variables + INTEGER :: I + INTEGER :: J +# include "CMN_SIZE" ! Size parameters + + !! Calculate longitude array indices for forcing subgrid + + IF ( GET_XMID(1) >= MIN_LON_U ) MIN_LON_U_INDEX = 1 + + DO I = 2, IIPAR + + IF ( ( GET_XMID(I-1) < MIN_LON_U) .AND. ( GET_XMID(I) >= MIN_LON_U ) ) MIN_LON_U_INDEX = I + + IF ( ( GET_XMID(I-1) <= MAX_LON_U) .AND. ( GET_XMID(I) > MAX_LON_U ) ) MAX_LON_U_INDEX = I-1 + + ENDDO + + IF ( GET_XMID(IIPAR) <= MAX_LON_U ) MAX_LON_U_INDEX = IIPAR + + LEN_LON_U = MAX_LON_U_INDEX - MIN_LON_U_INDEX + 1 + + !! Calculate latitude array indices for forcing subgrid + + IF ( GET_YMID(1) >= MIN_LAT_U ) MIN_LAT_U_INDEX = 1 + + DO J = 2, JJPAR + + IF ( ( GET_YMID(J-1) < MIN_LAT_U ) .AND. ( GET_YMID(J) >= MIN_LAT_U ) ) MIN_LAT_U_INDEX = J + IF ( ( GET_YMID(J-1) <= MAX_LAT_U ) .AND. ( GET_YMID(J) > MAX_LAT_U ) ) MAX_LAT_U_INDEX = J-1 + + ENDDO + + IF ( GET_YMID(JJPAR) <= MAX_LAT_U ) MAX_LAT_U_INDEX = JJPAR + + LEN_LAT_U = MAX_LAT_U_INDEX - MIN_LAT_U_INDEX + 1 + LEN_LEV_U = MAX_LEV_U_INDEX - MIN_LEV_U_INDEX + 1 + + !! Calculate total number of forcing gridpoints to be optimized + + NOPT_U = LEN_LON_U * LEN_LAT_U * LEN_LEV_U + + !PRINT *,'WEAK_CONSTRAINT: MIN_LON_U' , MIN_LON_U, GET_XMID(MIN_LON_U_INDEX) + !PRINT *,'WEAK_CONSTRAINT: MIN_LAT_U' , GET_YMID(MIN_LAT_U_INDEX) + !PRINT *,'WEAK_CONSTRAINT: MAX_LON_U' , MAX_LON_U, GET_XMID(MAX_LON_U_INDEX) + !PRINT *,'WEAK_CONSTRAINT: MAX_LAT_U' , GET_YMID(MAX_LAT_U_INDEX) + + END SUBROUTINE INITIALIZE_GRID_INDICES_U + + SUBROUTINE INIT_WEAK_CONSTRAINT + !! + !! ********************************************************** + !! Subroutine INIT_WEAK_CONSTRAINT initializes and zeroes all module arrays. + !! mkeller (15/09/2011) + !! ********************************************************** + !! + + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TIME_MOD, ONLY : CALC_RUN_DAYS + USE TIME_MOD, ONLY : GET_TS_DYN + USE TRACER_MOD, ONLY : N_TRACERS + +#include "CMN_SIZE" ! Size parameters + + INTEGER :: AS, DAYS, TS_DYN + + SCALE_FACTOR_U = 30 * 1E-10 + SIGMA_U = 3 * 1E-9 + + !! Compute grid indices + CALL INITIALIZE_GRID_INDICES_U + + DAYS = CALC_RUN_DAYS() + TS_DYN = GET_TS_DYN() + + !! Allow for forcing terms to be estimated at a subset of timesteps + N_TIMESTEPS_U = (DAYS * 24 * 60 / TS_DYN) / (LEN_SUBWINDOW_U) + 1 + + !! Initialize time counters. Note that in the adjoint calculation, time runs backwards + CT_SUB_U = -1 + CT_MAIN_U = 1 + + !! Allocate all required arrays + ALLOCATE( FORCE_U_FULLGRID(IIPAR,JJPAR,LLPAR), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'FORCE_U_FULLGRID' ) + FORCE_U_FULLGRID = 0d0 + + ALLOCATE( X_U ( NOPT_U, N_TIMESTEPS_U ) ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'X_U' ) + X_U = 0d0 + + ALLOCATE( X_U_TEMP ( NOPT_U, N_TIMESTEPS_U ) ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'X_U_TEMP' ) + X_U_TEMP = 0d0 + + ALLOCATE( X_GRADNT_U ( NOPT_U, N_TIMESTEPS_U ) ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'X_GRADNT_U' ) + X_GRADNT_U = 0d0 + + !PRINT *,'WEAK_CONSTRAINT: NOPT_U: ',NOPT_U + + FORCE_COST = 0d0 + + !CALL READ_STANDARD_DEVIATIONS + + END SUBROUTINE INIT_WEAK_CONSTRAINT + + SUBROUTINE CLEAN_WEAK_CONSTRAINT + + !! + !! ********************************************************** + !! Subroutine CLEAN_WEAK_CONSTRAINT deallocates the arrays needed for weak-constraint 4D-VAR + !! mkeller (15/09/2011) + !! ********************************************************** + !! + + IF ( ALLOCATED ( FORCE_U_FULLGRID ) )DEALLOCATE (FORCE_U_FULLGRID) + IF ( ALLOCATED ( X_U ) )DEALLOCATE ( X_U ) + IF ( ALLOCATED ( X_U_TEMP ) )DEALLOCATE ( X_U_TEMP ) + IF ( ALLOCATED ( X_GRADNT_U ) )DEALLOCATE ( X_GRADNT_U ) + + END SUBROUTINE CLEAN_WEAK_CONSTRAINT + + SUBROUTINE READ_STANDARD_DEVIATIONS + + USE NETCDF + + INTEGER :: FILE_ID, CO_ID, RESULT + INTEGER :: I,J,L + + !! read in standard deviations from netcdf file + + RESULT = NF90_OPEN( "wc_std/CO_monthly_STDEV_const.20060331.nc", NF90_NOWRITE, FILE_ID ) + + CALL HANDLE_ERR( RESULT ) + + RESULT = NF90_INQ_VARID( FILE_ID, "IJ_AVG_S__CO", CO_ID ) + + CALL HANDLE_ERR( RESULT ) + + RESULT = NF90_GET_VAR ( FILE_ID, CO_ID, WC_STD_DEV, START=(/1,1,1,1/), COUNT = (/IIPAR,JJPAR,38,1/) ) + + CALL HANDLE_ERR( RESULT ) + + RESULT = NF90_CLOSE( FILE_ID ) + + CALL HANDLE_ERR( RESULT ) + + !! only use standard deviation values between model level 20 and 31 + !! (hardcoded for GEOS-5 grid) + + DO L=1,LLPAR + DO J=1,JJPAR + DO I=1,IIPAR + + IF( L<20 ) THEN + WC_SIGMA(I,J,L) = WC_STD_DEV(I,J,20,1) + ELSE IF ( L>31 ) THEN + WC_SIGMA(I,J,L) = WC_STD_DEV(I,J,31,1) + ELSE + WC_SIGMA(I,J,L) = WC_STD_DEV(I,J,L,1) + END IF + + END DO + END DO + END DO + + # convert from ppbv to v/v + + WC_SIGMA = WC_SIGMA * 1E-9 * 1.0 + + !PRINT *,"Standard deviations: " + !PRINT *,WC_SIGMA + + END SUBROUTINE READ_STANDARD_DEVIATIONS + + SUBROUTINE HANDLE_ERR( RESULT ) + + USE NETCDF + INTEGER, INTENT(IN) :: RESULT + + IF( RESULT .NE. NF90_NOERR ) THEN + + PRINT *,NF90_STRERROR(RESULT) + + ENDIF + + END SUBROUTINE HANDLE_ERR + + SUBROUTINE SET_CT_U ( INCREASE, RESET , FLIP ) + + !! + !! ********************************************************** + !! Subroutine SET_CT_U increments the time counter for the forcing subwindow. + !! ********************************************************** + !! + + LOGICAL, INTENT(IN), OPTIONAL :: INCREASE + LOGICAL, INTENT(IN), OPTIONAL :: RESET + LOGICAL, INTENT(IN), OPTIONAL :: FLIP + + IF ( PRESENT ( RESET ) ) THEN + CT_SUB_U = 0 + ENDIF + + IF( PRESENT ( FLIP ) ) THEN + + !! this option is implemented because subwindow timers are always counted + !! upwards, i.e. the subwindow timer always increases up to LEN_SUBWINDOW_U + + !PRINT *,'WEAK_CONSTRAINT: BEFORE',CT_SUB_U + IF(CT_SUB_U == 0) THEN + CT_SUB_U=0 + ELSE + CT_SUB_U = LEN_SUBWINDOW_U - CT_SUB_U + ENDIF + !PRINT *,'WEAK_CONSTRAINT: AFTER',CT_SUB_U + + ENDIF + + IF( PRESENT ( INCREASE ) ) THEN + + !! right now, only the INCREASE==TRUE option is used. + !! leave code for INCREASE==FALSE option in, just in case. + + IF ( INCREASE) THEN + CT_SUB_U = CT_SUB_U + 1 + ELSE + CT_SUB_U = CT_SUB_U - 1 + ENDIF + + ENDIF + !! return to calling program + + END SUBROUTINE SET_CT_U + + SUBROUTINE SET_CT_MAIN_U( INCREASE, RESET ) + + !! + !! ********************************************************** + !! Subroutine SET_CT_MAIN_U increases/decreases the time counter for the main forcing time window. + !! ********************************************************** + !! + + LOGICAL, INTENT(IN), OPTIONAL :: INCREASE + LOGICAL, INTENT(IN), OPTIONAL :: RESET + + IF ( PRESENT ( RESET ) ) THEN + CT_MAIN_U = 1 + RETURN + END IF + + IF ( PRESENT ( INCREASE ) ) THEN + IF ( INCREASE ) THEN + CT_MAIN_U = CT_MAIN_U + 1 + ELSE + CT_MAIN_U = CT_MAIN_U - 1 + END IF + ELSE + CT_MAIN_U = CT_MAIN_U + 1 + END IF + + END SUBROUTINE SET_CT_MAIN_U + + FUNCTION ITS_TIME_FOR_U () RESULT ( FLAG ) + + !! + !! ********************************************************** + !! Subroutine ITS_TIME_FOR_U returns true if it's time to estimate the new forcing terms + !! ********************************************************** + !! + + LOGICAL :: FLAG + + FLAG = .FALSE. + + IF (CT_SUB_U == LEN_SUBWINDOW_U) FLAG = .TRUE. + + !! return to calling program + + END FUNCTION ITS_TIME_FOR_U + + SUBROUTINE CALC_GRADNT_U(YYYYMMDD,HHMMSS) + + !! + !! ********************************************************** + !! Subroutine CALC_GRADNT_U updates the gradient of the cost function with respect to u + !! and calculates the new estimates once all the required data have been gathered + !! ********************************************************** + !! + + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + X_GRADNT_U(:,CT_MAIN_U) = X_GRADNT_U(:,CT_MAIN_U) + GET_STT_X_U() + + !PRINT *,'WEAK_CONSTRAINT: IN CALC_GRADNT_U' + !PRINT *,'WEAK_CONSTARAINT:',YYYYMMDD,HHMMSS + !PRINT *,'WEAK_CONSTRAINT:',CT_SUB_U,CT_MAIN_U + + IF ( ITS_TIME_FOR_U() ) THEN + + CALL GET_FORCE_U_FROM_X_U + + CALL COMPUTE_APRIORI_U + + X_GRADNT_U(:,CT_MAIN_U) = X_GRADNT_U(:,CT_MAIN_U) + X_U_TEMP(:,CT_MAIN_U) + + ! ensure that gradient of J with respect to forcing terms is consistent with other gradients + X_GRADNT_U(:,CT_MAIN_U) = X_GRADNT_U(:,CT_MAIN_U) * 2.0 + + CALL SET_CT_U ( RESET = .TRUE. ) + + CALL SET_CT_MAIN_U ( INCREASE = .FALSE. ) + + ENDIF + + END SUBROUTINE CALC_GRADNT_U + + SUBROUTINE GET_X_U_FROM_FORCE_U + + !! + !! *************************************************************************************** + !! SUBROUTINE GET_FORCE_U FROM_X_U obtains the array X_U from the current forcing estimate + !! *************************************************************************************** + !! + + USE TRACER_MOD, ONLY : N_TRACERS + + ! Local variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + + !DO N = 1, N_TRACERS + DO L = MIN_LEV_U_INDEX, MAX_LEV_U_INDEX + DO J = MIN_LAT_U_INDEX, MAX_LAT_U_INDEX + DO I = MIN_LON_U_INDEX, MAX_LON_U_INDEX + + I_DUM = (I - MIN_LON_U_INDEX + 1) + & + (LEN_LON_U * ( J - MIN_LAT_U_INDEX ) ) + & + ( LEN_LON_U * LEN_LAT_U * ( L - MIN_LEV_U_INDEX )) + !&+( LEN_LON_U * LEN_LAT_U * LEN_LEV_U * ( N - 1 ) ) + + X_U( I_DUM , CT_MAIN_U) = FORCE_U_FULLGRID( I, J, L)!, N ) + + ENDDO + ENDDO + ENDDO + + END SUBROUTINE GET_X_U_FROM_FORCE_U + + SUBROUTINE COMPUTE_APRIORI_U + + !! + !!**************************************************************************** + !! SUBROUTINE COMPUTE_APRIORI_U computes the apriori-term (i.e. the Q-matrix term) + !!**************************************************************************** + !! + + USE TRACER_MOD, ONLY : N_TRACERS + USE ADJ_ARRAYS_MOD, ONLY : N_CALC, COST_FUNC + + ! Local variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + REAL*8 :: COST_TEMP + + !PRINT *,"MKDB: COST BEFORE FORCE: ",COST_FUNC + COST_TEMP = COST_FUNC + + !PRINT *,"MKDB: MAX FORCE", MAXVAL(FORCE_U_FULLGRID) + + ! DO N = 1, N_TRACERS + DO L = MIN_LEV_U_INDEX, MAX_LEV_U_INDEX + DO J = MIN_LAT_U_INDEX, MAX_LAT_U_INDEX + DO I = MIN_LON_U_INDEX, MAX_LON_U_INDEX + + I_DUM = ( I - MIN_LON_U_INDEX + 1) + & + ( LEN_LON_U * ( J - MIN_LAT_U_INDEX ) ) + & + ( LEN_LON_U * LEN_LAT_U * ( L - MIN_LEV_U_INDEX )) + ! &+( LEN_LON_U * LEN_LAT_U * LEN_LEV_U * ( N - 1 ) ) + + IF ( L< ( MIN_LEV_U_INDEX + 3 ) ) THEN + + X_U_TEMP( I_DUM , CT_MAIN_U) = FORCE_U_FULLGRID( I, J, L )/( ( SIGMA_U *1/(1+MIN_LEV_U_INDEX + 3-L) )**2) + COST_FUNC = COST_FUNC + FORCE_U_FULLGRID( I, J, L)**2 /( ( SIGMA_U *1/(1+MAX_LEV_U_INDEX + 3 - L) )**2) + + ELSE IF ( L > ( MAX_LEV_U_INDEX - 3 ) ) THEN + + X_U_TEMP( I_DUM , CT_MAIN_U) = FORCE_U_FULLGRID( I, J, L ) /( ( SIGMA_U *1/(1+MAX_LEV_U_INDEX - 3 + L) )**2) + COST_FUNC = COST_FUNC + FORCE_U_FULLGRID( I, J, L )**2 /( ( SIGMA_U *1/(1+MAX_LEV_U_INDEX - 3 + L) )**2) + + ELSE + + X_U_TEMP( I_DUM , CT_MAIN_U) = FORCE_U_FULLGRID( I, J, L ) /( SIGMA_U **2) + COST_FUNC = COST_FUNC + FORCE_U_FULLGRID( I, J, L )**2 /( SIGMA_U **2) + + ENDIF + + ENDDO + ENDDO + ENDDO + ! ENDDO + + FORCE_COST = COST_FUNC - COST_TEMP + FORCE_COST + + !PRINT *,"FORCE_COST: ", FORCE_COST + + END SUBROUTINE COMPUTE_APRIORI_U + + FUNCTION GET_STT_X_U() RESULT ( STT_X_U ) + + !! + !! ********************************************************** + !! FUNCTION GET_STT_X_U reads the value of STT_ADJ into a 1D-array + !! ********************************************************** + !! + + USE TRACER_MOD, ONLY : N_TRACERS + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + + ! Local variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + REAL*8 :: STT_X_U ( NOPT_U ) + + !PRINT *,'WEAK_CONSTRAINT: MAX_STT_ADJ',MAXVAL(STT_ADJ) + + ! DO N = 1, N_TRACERS + DO L = MIN_LEV_U_INDEX, MAX_LEV_U_INDEX + DO J = MIN_LAT_U_INDEX, MAX_LAT_U_INDEX + DO I = MIN_LON_U_INDEX, MAX_LON_U_INDEX + + I_DUM = (I - MIN_LON_U_INDEX + 1) + & + (LEN_LON_U * ( J - MIN_LAT_U_INDEX ) ) + & + (LEN_LON_U * LEN_LAT_U * ( L - MIN_LEV_U_INDEX )) + ! &+( LEN_LON_U * LEN_LAT_U * LEN_LEV_U * ( N - 1 ) ) + + ! I_DUM = (I - MIN_LON_U_INDEX + 1) + ( LEN_LON_U * ( J - MIN_LAT_U_INDEX ) ) & + ! + ( LEN_LON_U * LEN_LAT_U * ( L - MIN_LEV_U_INDEX ) ) & + ! + ( LEN_LON_U * LEN_LAT_U * LEN_LEV_U * ( N - 1 ) ) + + STT_X_U( I_DUM ) = STT_ADJ( I, J, L, N_TRACER_U ) + + ENDDO + ENDDO + ENDDO + ! ENDDO + + END FUNCTION GET_STT_X_U + + SUBROUTINE MAKE_GDT_U_FILE( ) +! + !****************************************************************************** + ! Subroutine MAKE_GDT_FILE creates a binary file of forcing gradients + ! mkeller + !****************************************************************************** + ! + ! References to F90 modules + + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + + ! Local Variables + + CHARACTER(LEN=255) :: FILENAME + + INTEGER :: I, J + + CHARACTER(LEN=20) :: OUTPUT_GDT_FILE + CHARACTER(LEN=40) :: UNIT + + ! Hardwire output file for now + OUTPUT_GDT_FILE = 'gctm.gdt.forcing.NN' + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_GDT_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the OPTDATA_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + OPEN( UNIT = IU_RST, FILE = FILENAME, FORM = 'UNFORMATTED' ) + + DO I=1,NOPT_U + DO J=1,N_TIMESTEPS_U + + WRITE( IU_RST ) X_GRADNT_U(I,J) + + ENDDO + ENDDO + + CLOSE ( IU_RST ) + + END SUBROUTINE MAKE_GDT_U_FILE + + SUBROUTINE READ_GDT_U_FILE( ) + + ! + !****************************************************************************** + ! Subroutine MAKE_GDT_FILE creates a binary file of forcing gradients + ! mkeller + !****************************************************************************** + ! + ! References to F90 modules + + USE ADJ_ARRAYS_MOD, ONLY : N_CALC + USE ADJ_ARRAYS_MOD, ONLY : EXPAND_NAME + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + + ! Local Variables + + CHARACTER(LEN=255) :: FILENAME + + INTEGER :: I, J + + CHARACTER(LEN=20) :: OUTPUT_GDT_FILE + CHARACTER(LEN=40) :: UNIT + + + ! Hardwire output file for now + OUTPUT_GDT_FILE = 'gctm.gdt.forcing.NN' + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_GDT_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_NAME( FILENAME, N_CALC ) + + ! Add the OPTDATA_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + OPEN( UNIT = IU_RST, FILE = FILENAME, FORM = 'UNFORMATTED' ) + + DO I=1,NOPT_U + DO J=1,N_TIMESTEPS_U + + READ( IU_RST ) X_GRADNT_U(I,J) + + ENDDO + ENDDO + + CLOSE ( IU_RST ) + + ! Return to calling program + END SUBROUTINE READ_GDT_U_FILE + + SUBROUTINE GET_FORCE_U_FROM_X_U + + !! + !! ********************************************************** + !! SUBROUTINE GET_FORCE_U FROM_X_U obtains the current forcing estimate from the X_U array + !! ********************************************************** + !! + + USE TRACER_MOD, ONLY : N_TRACERS +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, M, N + INTEGER :: I_DUM + + I_DUM = 0 + ! DO N = 1, N_TRACERS + DO L = MIN_LEV_U_INDEX, MAX_LEV_U_INDEX + DO J = MIN_LAT_U_INDEX, MAX_LAT_U_INDEX + DO I = MIN_LON_U_INDEX, MAX_LON_U_INDEX + + I_DUM = (I - MIN_LON_U_INDEX + 1) + & + (LEN_LON_U * ( J - MIN_LAT_U_INDEX ) ) + & + (LEN_LON_U * LEN_LAT_U * ( L - MIN_LEV_U_INDEX )) + ! &+( LEN_LON_U * LEN_LAT_U * LEN_LEV_U * ( N - 1 ) ) + + FORCE_U_FULLGRID( I, J, L ) = X_U( I_DUM, CT_MAIN_U ) + + ENDDO + ENDDO + ENDDO + ! ENDDO + + END SUBROUTINE GET_FORCE_U_FROM_X_U + + SUBROUTINE MAKE_FORCE_U_FILE( YYYYMMDD, HHMMSS ) + + ! + !****************************************************************************** + ! Subroutine MAKE_ADJ_FILE creates a binary file of STT_ADJ + ! (dkh, 10/03/04)exit + + ! + ! Arguments as Input: + ! ============================================================================ + ! (1 ) YYYYMMDD : Year-Month-Date + ! (2 ) HHMMSS : and Hour-Min-Sec for which to create an adjoint file + ! + + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE BPCH2_MOD + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LTRAJ_SCALE + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : STT + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, I0, IOS, J, J0, L, N + INTEGER :: YYYY, MM, DD, HH, SS + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + REAL*4 :: LONRES, LATRES + INTEGER, PARAMETER :: HALFPOLAR = 1 + INTEGER, PARAMETER :: CENTER180 = 1 + + CHARACTER(LEN=40) :: OUTPUT_FORCE_U_FILE + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED = '' + CHARACTER(LEN=80) :: TITLE + + ! Should make these user defined in input.gcadj + !! Parameter + INTEGER, PARAMETER :: LLADJKEEP = LLPAR + !INTEGER, PARAMETER :: NNADJKEEP = N_TRACERS + ! Now specify this input.gcadj + !LOGICAL, PARAMETER :: LTRAJ_SCALE = .TRUE. + + !================================================================= + ! MAKE_FORCE_U_FILE begins here! + !================================================================= + + ! Hardwire output file for now + OUTPUT_FORCE_U_FILE = 'gctm.forcing.YYYYMMDD.hhmm' + + ! Define variables for BINARY PUNCH FILE OUTPUT + TITLE = 'GEOS-CHEM Forcing File: Instantaneous Forcing Values' + CATEGORY = 'IJ-ADJ-$' + LONRES = DISIZE + LATRES = DJSIZE + + ! Call GET_MODELNAME to return the proper model name for + ! the given met data being used (bmy, 6/22/00) + MODELNAME = GET_MODELNAME() + + ! Get the nested-grid offsets + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + !================================================================= + ! Open the force file for output -- binary punch format + !================================================================= + + ! Copy the output observation file name into a local variable + FILENAME = TRIM( OUTPUT_FORCE_U_FILE ) + + ! Append the iteration number suffix to the file name + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add the ADJ_DIR prefix to the file name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + !WRITE( 6, 100 ) TRIM( FILENAME ) + !FORMAT( ' - MAKE_ADJ_FILE: Writing ', a ) + + ! Open checkpoint file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_RST, FILENAME, TITLE ) + + !================================================================= + ! Write forcing for each observed quantity to the forcing file + !================================================================= + !DO N = 1, N_TRACERS + + UNIT = 'J' + + !Temporarily store quantities in the TRACER array + + + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + TRACER(I,J,L) = FORCE_U_FULLGRID(I,J,L) + + ENDDO + ENDDO + ENDDO + + + CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, & + HALFPOLAR, CENTER180, CATEGORY, 1, & + UNIT, GET_TAU(), GET_TAU(), RESERVED, & + IIPAR, JJPAR, LLPAR, I0+1, & + J0+1, 1, TRACER ) + +! ENDDO + + ! TRACER = STT(:,:,:,1) + +! CALL BPCH2( IU_RST, MODELNAME, LONRES, LATRES, +! & HALFPOLAR, CENTER180, CATEGORY, N_TRACERS+1, +! & UNIT, GET_TAU(), GET_TAU(), RESERVED, +! & IIPAR, JJPAR, LLPAR, I0+1, +! & J0+1, 1, TRACER ) + + ! Close file + CLOSE( IU_RST ) + + END SUBROUTINE MAKE_FORCE_U_FILE + + SUBROUTINE READ_FORCE_U_FILE( YYYYMMDD, HHMMSS ) + + ! + !****************************************************************************** + ! Subroutine READ_FORCE_U_FILE reads forcing values + ! from a checkpoint file (binary punch file format) + ! (dkh, 8/30/04) + ! + ! Arguments as input: + ! ============================================================================ + ! (1 ) YYYYMMDD : Year-Month-Day + ! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file + ! + ! Passed via CMN: + ! ============================================================================ + ! (1 ) TAU : TAU value (elapsed hours) at start of diagnostic interval + ! + + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE COMODE_MOD, ONLY : CHK_CSPEC, JLOP + USE DIRECTORY_ADJ_MOD, ONLY : ADJTMP_DIR + USE DIRECTORY_ADJ_MOD, ONLY : DIAGADJ_DIR + USE DIRECTORY_ADJ_MOD, ONLY : OPTDATA_DIR + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE FILE_MOD, ONLY : IU_RST, IOERROR + USE GCKPP_ADJ_GLOBAL, ONLY : NTT + USE LOGICAL_MOD, ONLY : LCHEM , LSULF + USE LOGICAL_MOD, ONLY : LSOILNOX, LLIGHTNOX + USE LOGICAL_MOD, ONLY : LPRT + USE LOGICAL_ADJ_MOD, ONLY : LAERO_THERM + USE LOGICAL_ADJ_MOD, ONLY : LDEL_CHKPT + USE RESTART_MOD, ONLY : CHECK_DIMENSIONS + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : N_TRACERS + USE UNIX_CMDS_MOD, ONLY : REMOVE_CMD + +# include "CMN_SIZE" ! Size parameters +!# include "comode.h" ! ITLOOP, IGAS +# include "CMN_VEL" ! XYLAI + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, N, JLOOP, NN, NTL + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: TRACER(IIPAR,JJPAR,LLPAR) + ! Remove these since we always recompute instead + ! of checkpointing (dkh, 06/11/09) + ! REAL*4 :: CHECK1(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK2(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK3(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK4(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK5(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK6(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK7(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK8(IIPAR,JJPAR,LLPAR) + ! REAL*4 :: CHECK9(IIPAR,JJPAR,LLPAR) + !REAL*4 :: SMVGARRAY(ITLOOP,IGAS) + + !>>> + ! Now include adjoint of F (dkh, 10/03/08) + INTEGER :: NS + !<<< + + REAL*8 :: SUMTC + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: UNZIP_FILE_CMD + CHARACTER(LEN=255) :: REMOVE_CHK_FILE_CMD + + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL, NV + INTEGER :: IJLOOP + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + ! added by Martin Keller + + CHARACTER(LEN=255) :: INPUT_FILE + LOGICAL :: EX + + !================================================================= + ! READ_FORCE_U_FILE begins here! + !================================================================= + + ! Hardwire output file for now + INPUT_FILE = 'gctm.forcing.YYYYMMDD.hhmm' + + ! Initialize some variables + NCOUNT(:) = 0 + TRACER(:,:,:) = 0e0 + + !================================================================= + ! Open checkpoint file and read top-of-file header + !================================================================= + + ! Copy input file name to a local variable + FILENAME = TRIM( INPUT_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Add ADJ_DIR prefix to name + FILENAME = TRIM( OPTDATA_DIR ) // TRIM( FILENAME ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a,/)' ) 'F O R C I N G F I L E I N P U T' + + !WRITE( 6, 100 ) TRIM( FILENAME ) + !FORMAT( ' - READ_FORCE_U_FILE: Reading ', a ) + + ! MAKE SURE FILE EXISTS + + INQUIRE( FILE = FILENAME, EXIST=EX) + + IF( .NOT. EX ) THEN + CALL MAKE_FORCE_U_FILE(YYYYMMDD,HHMMSS) + RETURN + ENDIF + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_RST, FILENAME ) + + ! DO N = 1, N_TRACERS + READ( IU_RST, IOSTAT=IOS ) MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + ! IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:7' ) + + READ( IU_RST, IOSTAT=IOS ) & + CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, & + NI, NJ, NL, IFIRST, JFIRST, LFIRST, & + NSKIP + + IF ( IOS /= 0 ) CALL IOERROR(IOS,IU_RST,'read_checkpt_file:8' ) + + READ( IU_RST, IOSTAT=IOS ) ( ( ( TRACER(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + PRINT *,'WEAK_CONSTRAINT: TRACER ',MINVAL(TRACER),MAXVAL(TRACER) + + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_RST,'read_checkpt_file:9') + + !============================================================== + ! Assign data from the TRACER array to the FORCE_U_FULLGRID array. + !============================================================== + + ! Only process checkpoint data (i.e. mixing ratio) + !IF ( CATEGORY(1:8) == 'IJ-CHK-$' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + ! CALL CHECK_DIMENSIONS( NI, NJ, NL ) + + + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + FORCE_U_FULLGRID(I,J,L) = TRACER(I,J,L) + ENDDO + ENDDO + ENDDO + + !ENDIF + ! ENDDO + + ! Close file + + CLOSE( IU_RST ) + + END SUBROUTINE READ_FORCE_U_FILE + +END MODULE WEAK_CONSTRAINT_MOD diff --git a/code/adjoint/wetscav_adj_mod.f b/code/adjoint/wetscav_adj_mod.f new file mode 100644 index 0000000..874ca71 --- /dev/null +++ b/code/adjoint/wetscav_adj_mod.f @@ -0,0 +1,7140 @@ +! $Id: wetscav_adj_mod.f,v 1.4 2012/04/20 19:19:31 nicolas Exp $ + MODULE WETSCAV_ADJ_MOD +! +!****************************************************************************** +! Module WETSCAV_MOD contains arrays for used in the wet scavenging of +! tracer in cloud updrafts, rainout, and washout. (bmy, 2/28/00, 3/5/08) +! +! Module Variables: +! ============================================================================ +! (1 ) NSOLMAX (INTEGER) : Max # of soluble tracers [unitless] +! (2 ) NSOL (INTEGER) : Actual # of soluble tracers [unitless] +! (3 ) IDWETD (INTEGER) : Index array for WETDEP routine [unitless] +! (4 ) Vud (REAL*8 ) : Array for updraft velocity [m/s] +! (5 ) CLDLIQ (REAL*8 ) : Array for cloud liquid water [cm3 H2O/cm3 air] +! (6 ) CLDICE (REAL*8 ) : Array for cloud ice content [cm3 ice/cm3 air] +! (7 ) C_H2O (REAL*8 ) : Array for Mixing ratio of , +! water, computed from Eice(T) [v/v] +! (8 ) PDOWN (REAL*8 ) : Precip thru bottom of grid box [cm3 H2O/cm2 area/s] +! (9 ) QQ (REAL*8 ) : Rate of new precip formation [cm3 H2O/cm3 air/s] +! (10) EPSILON (REAL*8 ) : A very small positive number [unitless] +! (11) H2O2s (REAL*8 ) : Array to save H2O2 for wetdep [v/v] +! (12) SO2s (REAL*8 ) : Array to save SO2 for wetdep [v/v] +! +! Module Routines: +! ============================================================================ +! (1 ) MAKE_QQ : Constructs the QQ field (precipitable water) +! (2 ) E_ICE : Computes saturation vapor pressure for ice +! (3 ) COMPUTE_L2G : Computes the ratio [v/v liquid] / [v/v gas] +! (4 ) COMPUTE_F : Computes fraction of tracer lost in cloud updrafts +! (5 ) F_AEROSOL : Computes fraction of tracer scavenged in updrafts +! (6 ) GET_ISOL : Returns correct index for ND38 diagnostic +! (7 ) RAINOUT : Computes fraction of soluble tracer lost to rainout +! (8 ) GET_RAINFRAC : Computes rainout fraction -- called by RAINOUT +! (9 ) WASHOUT : Computes fraction of soluble tracer lost to washout +! (10) WASHFRAC_AEROSOL : Computes fraction of aerosol lost to washout +! (11) WASHFRAC_LIQ_GAS : Computes fraction of soluble gases lost to washout +! (12) WETDEP : Driver routine for computing wet deposition losses +! (13) LS_K_RAIN : Computes K_RAIN (for LS precipitation) +! (14) LS_F_PRIME : Computes F_PRIME (for LS precipitation) +! (15) CONV_F_PRIME : Computes F_PRIME (for convective precipitation) +! (16) SAFETY : Stops WETDEP w/ error msg if negative tracer found +! (17) WETDEPID : Initalizes the IDWETD array for routine WETDEP +! (18) GET_WETDEP_NMAX : Returns max # of soluble tracers per simulation +! (19) GET_WETDEP_NSOL : Returns actual # of soluble tracers per simulation +! (20) GET_WETDEP_IDWETD : Returns CTM tracer # of for a given wetdep species +! (21) INIT_WETSCAV : Initializes fields used for computing wetdep losses +! (22) CLEANUP_WETSCAV : Deallocates all allocatable module arrays +! +! GEOS-CHEM modules referenced by wetscav_mod.f +! ============================================================================ +! (1 ) dao_mod.f : Module containing arrays for DAO met fields +! (2 ) diag_mod.f : Module containing GEOS-CHEM diagnostic arrays +! (3 ) error_mod.f : Module containing NaN and other error check routines +! (4 ) logical_mod.f : Module containing GEOS-CHEM logical switches +! (5 ) pressure_mod.f : Module containing routines to compute P(I,J,L) +! (6 ) tracer_mod.f : Module containing GEOS-CHEM tracer array STT etc. +! (7 ) tracerid_mod.f : Module containing pointers to tracers and emissions +! +! References: +! ============================================================================ +! (1 ) Liu,H., D.J. Jacob, I. Bey and R.M. Yantosca, "Constraints from 210Pb +! and 7Be on wet deposition and transport in a global three-dimensional +! chemical tracer model driven by assimilated meteorological fields", +! JGR, Vol 106, pp 12109-12128, 2001. +! (2 ) D.J. Jacob, H. Liu, C. Mari, and R. M. Yantosca, "Harvard wet +! deposition scheme for GMI", Harvard Atmospheric Chemistry Modeling +! Group, March 2000. +! (3 ) Chin, M., D.J. Jacob, G.M. Gardner, M.S. Foreman-Fowler, and P.A. +! Spiro, "A global three-dimensional model of tropospheric sulfate", +! J. Geophys. Res., 101, 18667-18690, 1996. +! (4 ) Balkanski, Y D.J. Jacob, G.M. Gardner, W.C. Graustein, and K.K. +! Turekian, "Transport and Residence Times of Tropospheric Aerosols +! from a Global Three-Dimensional Simulation of 210Pb", JGR, Vol 98, +! (D11) pp 20573-20586, 1993. +! (5 ) Giorgi, F, & W.L. Chaimedes, "Rainout Lifetimes of Highly Soluble +! Aerosols and Gases as Inferred from Simulations With a General +! Circulation Model", JGR, Vol 86 (D13) pp 14367-14376, 1986. +! +! NOTES: +! (1 ) Now trap allocation errors with routine ALLOC_ERR. (bmy, 7/11/00) +! (2 ) Moved routine MAKE_QQ here from "dao_mod.f" (bmy, 10/12/00) +! (3 ) Reordered arguments in INIT_PRECIP (bmy, 10/12/00) +! (4 ) Updated comments (bmy, 9/4/01) +! (5 ) Bug fix in MAKE_QQ: BXHEIGHT is sized IIPAR,JJPAR,LLPAR (bmy, 10/4/01) +! (6 ) Removed obsolete, commented-out code from 10/01 (bmy, 11/26/01) +! (7 ) Now divide module header into MODULE PRIVATE, MODULE VARIABLES, and +! MODULE ROUTINES sections. Updated comments (bmy, 5/28/02) +! (8 ) Now zero allocatable arrays (bmy, 8/5/02) +! (9 ) Bug fix: ND39 diagnostic now closes the budget. Also bundled several +! standalone routines into this module. Now references F90 module +! "tracerid_mod.f". Also set NSOLMAX=10 since we now have sulfate +! tracers for wetdep. Now prevent out-of-bounds errors in routine +! WETDEP. Added GET_WETDEP_NMAX function to return max # of soluble +! tracers for allocating diagnostic arrays. Added functions +! GET_WETDEP_NSOL and GET_WETDEP_IDWETD. Now init H2O2s and SO2s +! to the initial H2O2 and SO2 from STT. Updated comments. +! (qli, bmy, 1/14/03) +! (10) Improvements for SO2/SO4 scavenging (rjp, bmy, 3/23/03) +! (11) Now references "time_mod.f". Added driver routine DO_WETDEP to +! remove cumbersome calling sequence from MAIN program. Also declared +! WETDEP and MAKE_QQ PRIVATE to this module. (bmy, 3/27/03) +! (11) Add parallelization to routine WETDEP (bmy, 3/17/04) +! (12) Added carbon and dust aerosol tracers (rjp, tdf, bmy, 4/5/04) +! (13) Added seasalt aerosol tracers (rjp, bec, bmy, 4/20/04) +! (14) Added secondary organic aerosol tracers (rjp, bmy, 7/13/04) +! (15) Now references "logical_mod.f" and "tracer_mod.f". Now move all +! internal routines to the module and pass arguments explicitly in +! order to facilitate parallelization on the Altix. (bmy, 7/20/04) +! (16) Updated for mercury aerosol tracers (eck, bmy, 12/9/04) +! (17) Updated for AS, AHS, LET, NH4aq, SO4aq. Also now pass Hg2 wetdep loss +! to "ocean_mercury_mod.f". (cas, sas, bmy, 1/20/05) +! (18) Bug fix to avoid numerical blowup in WETDEP. Now use analytical +! function for E_ICE(T). (bmy, 3/7/05) +! (19) Added SO4s, NITs. Increased NSOLMAX to 31. Also block out +! parallel loop in WETDEP for SGI MIPS compiler. (bec, bmy, 5/5/05) +! (20) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (21) Bug fixes: do not over-deplete H2O2s. Also include updates for +! tagged Hg simulation. (dkh, rjp, eck, cdh, bmy, 1/6/06) +! (22) Now wet deposit SOG4, SOA4. Remove unnecessary variables in WETDEP. +! (dkh, bmy, 5/18/06) +! (23) Bug fixes in COMPUTE_F (bmy, 7/26/06) +! (24) Resize DSTT array in WETDEP to save memory. Added fixes for GEOS-5 +! wet deposition per Hongyu Liu's suggestions. (bmy, 3/5/08) +! (25) Add wet scavenging of GLYX, MGLY, GLYC, SOAG, SOAM (tmf, 1/7/09) +! (26) Effective Henry's law constant and coefficient from +! Sander, R, 1999, Compilation of Henry's Law Constants for +! Inorganic and Organic Species of Potential Importance in +! Environmental Chemistry. +! http://www.mpch-mainz.mpg.de/~sander/res/henry.html +! (tmf, 1/7/09) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these variables ... + !PUBLIC :: H2O2s + !PUBLIC :: SO2s + + PUBLIC :: H2O2s_ADJ + PUBLIC :: SO2s_ADJ + + ! ... and these routines + PUBLIC :: CLEANUP_WETSCAV_ADJ + !PUBLIC :: COMPUTE_F + PUBLIC :: DO_WETDEP_ADJ + !PUBLIC :: GET_WETDEP_IDWETD + !PUBLIC :: GET_WETDEP_NMAX + !PUBLIC :: GET_WETDEP_NSOL + PUBLIC :: INIT_WETSCAV_ADJ + PUBLIC :: ADJ_INIT_WETSCAV + PUBLIC :: WETSCAV_ADJ_FORCE + !PUBLIC :: WETDEPID + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Parameters +! INTEGER, PARAMETER :: NSOLMAX = 38 +! REAL*8, PARAMETER :: EPSILON = 1d-32 +! +! ! Scalars +! INTEGER :: NSOL +! +! ! Arrays +! INTEGER :: IDWETD(NSOLMAX) +! REAL*8, ALLOCATABLE :: Vud(:,:) +! REAL*8, ALLOCATABLE :: C_H2O(:,:,:) +! REAL*8, ALLOCATABLE :: CLDLIQ(:,:,:) +! REAL*8, ALLOCATABLE :: CLDICE(:,:,:) +! REAL*8, ALLOCATABLE :: PDOWN(:,:,:) +! REAL*8, ALLOCATABLE :: QQ(:,:,:) +! REAL*8, ALLOCATABLE :: H2O2s(:,:,:) +! REAL*8, ALLOCATABLE :: SO2s(:,:,:) + + ! adjoint variables + REAL*8, ALLOCATABLE :: H2O2s_ADJ(:,:,:) + REAL*8, ALLOCATABLE :: SO2s_ADJ(:,:,:) + + !>>> + ! Now include adjoint of F (dkh, 10/03/08) + REAL*8, ALLOCATABLE :: F_ADJ(:,:,:) + !<<< + + ! wetdep adj (fp, dkh, 03/04/13) + REAL*8, ALLOCATABLE :: BOX_DEP(:,:,:,:) + REAL*8, ALLOCATABLE :: LOWER_DEP(:,:,:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_WETDEP_ADJ +! +!****************************************************************************** +! Subroutine DO_WETDEP_ADJ is a driver for the adjoint of the wet deposition +! code. (dkh, 02/??/05) ! +! +! It is based on the subroutine DO_WETDEP, a driver for the wet deposition code, +! called from the MAIN program. (bmy, 3/27/03, 3/5/08) +! +! NOTES: +! (1 ) BUG FIX. Do adjoint wetdep of convective precip BEFORE adjoint wetdep +! of stratiform precip. (dkh, 10/23/05) +! (2 ) Added support for full chemistry. Now call ADJ_SO2_WETDEP to do the +! adjoint for SO2. Now call forward wetdep routines first +! in order to recompute variables (H2O2s, SO2s,STT(SO4)) needed for +! ADJ_SO2_WETDEP. (dkh, 10/23/05) +! (3 ) Updated to GCv8 adjoint (dkh, 09/28/09) +! +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : DEBUG_MSG + USE LOGICAL_MOD, ONLY : LPRT + ! adj_group debug (dkh, 06/08/09) + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE CHECKPT_MOD, ONLY : CHK_STT_BEFCHEM + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD, ONLY : LMAX_OBS + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE WETSCAV_MOD, ONLY : H2O2s, SO2s + USE WETSCAV_MOD, ONLY : MAKE_QQ + USE WETSCAV_MOD, ONLY : RESTORE + USE WETSCAV_MOD, ONLY : RECALC_SOX_WETDEP + USE TIME_MOD, ONLY : GET_TS_DYN + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACERID_MOD, ONLY : IDTSO4 + USE TRACERID_MOD, ONLY : IDTSO2 + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM +#if defined(EANET_OBS) || defined(EMEP_OBS) || defined(NADP_OBS) || defined(IDAF_OBS) + USE N_DEPOSITION_OBS_MOD, ONLY : NDEP_FORCING +#endif + + +# include "CMN_SIZE" ! Size parameters +# include "define_adj.h" ! Obs operators + + INTEGER :: I, J, L + REAL*8, SAVE :: OBS_COUNT = 0 + + + !================================================================== + ! DO_WETDEP_ADJ begins here! + !================================================================== + + !================================================================= + ! Adjoint of wetdep for all species other than SO2 + ! ( need to do adjoint of wetdep of SO4 before adjoint of SO2 ) + !================================================================= + +#if !defined( GEOS_5 ) && !defined( GEOS_FP ) + + ! Adjoint of wetdep by convective precip + CALL MAKE_QQ( .FALSE. ) + CALL WETDEP_ADJ( .FALSE. ) + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + ! Adjoint of wetdep by convective precip for SO2 + ! Restore initial values of H2O2s, SO2s, STT(SO4), STT(SO2) + CALL RESTORE + + IF ( LPRINTFD ) THEN + WRITE(6,*) ' WETD CHK variables before RECALC_SOX ' + print*, ' H2O2s(FD) = ', H2O2s(IFD,JFD,LFD) + print*, ' SO2s(FD) = ', SO2s(IFD,JFD,LFD) + print*, ' SO4(FD) = ', STT(IFD,JFD,LFD,IDTSO4) + ENDIF + + ! Recompute intemediate values + CALL MAKE_QQ( .TRUE. ) + ! Just do fwd LS precip for SO2 and SO4 + CALL RECALC_SOX_WETDEP( .TRUE. ) + + IF ( LPRINTFD ) THEN + WRITE(6,*) ' WETD CHK variables before ADJ_SO2_WETDEP(F) ' + print*, ' H2O2s(FD) = ', H2O2s(IFD,JFD,LFD) + print*, ' SO2s(FD) = ', SO2s(IFD,JFD,LFD) + print*, ' SO4(FD) = ', STT(IFD,JFD,LFD,IDTSO4) + print*, ' STT_ADJ(FD) = ', STT_ADJ(IFD,JFD,LFD,NFD) + print*, ' STT(FD) = ', STT(IFD,JFD,LFD,NFD) + ENDIF + + CALL MAKE_QQ( .FALSE. ) + CALL ADJ_SO2_WETDEP( .FALSE. ) + + ENDIF + + IF ( LPRT ) CALL DEBUG_MSG('### DO_WETDEP_ADJ: after conv wetdep') + +#endif + + ! Wetdep by large-scale (stratiform) precip + CALL MAKE_QQ( .TRUE. ) + CALL WETDEP_ADJ( .TRUE. ) + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + ! Restore initial values of H2O2s, SO2s, STT(SO4) + CALL RESTORE + + IF ( LPRINTFD ) THEN + WRITE(6,*) ' WETD CHK variables before ADJ_SO2_WETDEP(T) ' + print*, ' H2O2s(FD) = ', H2O2s(IFD,JFD,LFD) + print*, ' SO2s(FD) = ', SO2s(IFD,JFD,LFD) + print*, ' SO4(FD) = ', STT(IFD,JFD,LFD,IDTSO4) + print*, ' SO2(FD) = ', STT(IFD,JFD,LFD,IDTSO2) + ENDIF + + CALL ADJ_SO2_WETDEP( .TRUE. ) + + ! Reset SO2 and SO4 in STT to values before chemistry +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + STT(I,J,L,IDTSO4) = CHK_STT_BEFCHEM(I,J,L,IDTSO4) + STT(I,J,L,IDTSO2) = CHK_STT_BEFCHEM(I,J,L,IDTSO2) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + IF ( LPRT ) CALL DEBUG_MSG( '### DO_WETDEP_ADJ: after LS wetdep' ) + + ! Apply adjoint forcing now because WETSCAV_ADJ_FORCE and NDEP_FORCING + ! use arrays calculated in WETDEP_ADJ currently stored in memory + IF ( LMAX_OBS ) THEN + OBS_COUNT = OBS_COUNT + & + REAL(GET_TS_DYN(),8) / REAL(GET_TS_CHEM(),8) + + IF ( OBS_COUNT > NSPAN ) RETURN + ENDIF + +#if defined(EANET_OBS) || defined(EMEP_OBS) || defined(NADP_OBS) || defined(IDAF_OBS) + CALL NDEP_FORCING + CALL WETSCAV_ADJ_FORCE +#else + IF ( LADJ_WDEP_LS ) THEN + CALL WETSCAV_ADJ_FORCE + ENDIF +#endif + + ! Return to calling program + END SUBROUTINE DO_WETDEP_ADJ + +!------------------------------------------------------------------------------ +! +! SUBROUTINE MAKE_QQ( LS ) +!! +!!***************************************************************************** +!! Subroutine MAKE_QQ computes the large-scale or convective precipitation +!! fields for use with wetdep.f. (hyl, bmy, 2/29/00, 11/8/02) +!! +!! Arguments as Input: +!! =========================================================================== +!! (1 ) LS : = T for Large-scale precip, =F otherwise +!! +!! DAO met fields from "dao_mod.f:" +!! =========================================================================== +!! (1 ) AIRDEN : Density of air in grid box (I,J,L) [kg air/m^3] +!! (2 ) BXHEIGHT : Height of grid box (I,J,L) in [m] +!! (3 ) MOISTQ : DAO field for change in specific +!! humidity due to moist processes [kg H2O/kg air/s] +!! (4 ) PREACC : DAO total accumulated precipitaton [mm/day] +!! (5 ) PRECON : DAO convective precipitation [mm/day] +!! +!! References (see above for full citations): +!! =========================================================================== +!! (1 ) Liu et al, 2000 +!! (2 ) Jacob et al, 2000 +!! +!! NOTES: +!! (1 ) Now we partition MOISTQ into large-scale and convective parts, using +!! total precipitation PREACC and convective precipitation PRECON (both +!! are vertical integral amounts). The precipitation field at altitudes +!! (PDOWN) is also made (hyl, djj, 10/17/98). +!! (2 ) MAKE_QQ is written in Fixed-Form Fortran 90. (bmy, 4/2/99)! +!! (3 ) AIRDEN, MOISTQ, QQ, and PDOWN are dimensioned (LLPAR,IIPAR,JJPAR) +!! in order to maximize loop efficiency when processing an (I,J) +!! column layer by layer. (bmy, 3/14/00) +!! (4 ) MOISTQ is originally [g H2O/kg air/day], and is converted in +!! READ_A6 to [kg H2O/kg air/s]. (bmy, 3/14/00) +!! (5 ) Now reference PREACC, PRECON from "dao_mod.f" instead of from +!! common block header file "CMN_PRECIP" (bmy, 6/26/00) +!! (6 ) Now pass BXHEIGHT as an argument. Also added to "dao_mod.f". +!! (bmy, 6/26/00) +!! (7 ) Moved from "dao_mod.f" to "wetscav_mod.f". Also made PREACC +!! and PRECON into arguments. (bmy, 10/12/00) +!! (8 ) Updated comments (bmy, 9/4/01) +!! (9 ) BXHEIGHT is now sized (IIPAR,JJPAR,LLPAR) (bmy, 10/4/01) +!! (10) Removed obsolete, commented-out code from 10/01 (bmy, 11/26/01) +!! (11) Now reference met field arrays directly from "dao_mod.f" (bmy, 11/8/02) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE DAO_MOD, ONLY : AIRDEN, BXHEIGHT, MOISTQ, PREACC, PRECON +! USE ERROR_MOD, ONLY : ALLOC_ERR +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! LOGICAL, INTENT(IN) :: LS +! +! ! Local variables +! INTEGER :: I, J, L, AS +! REAL*8 :: PTEMP, FRAC +! LOGICAL :: FIRST = .TRUE. +! +! !================================================================= +! ! MAKE_QQ begins here! +! !================================================================= +! IF ( FIRST ) THEN +! +! ! Allocate PDOWN on first call +! ALLOCATE( PDOWN( LLPAR, IIPAR, JJPAR ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'PDOWN' ) +! PDOWN = 0d0 +! +! ! Allocate QQ on first call +! ALLOCATE( QQ( LLPAR, IIPAR, JJPAR ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'QQ' ) +! QQ = 0d0 +! +! ! Reset flag +! FIRST = .FALSE. +! ENDIF +! +! !================================================================= +! ! Loop over surface grid boxes +! !================================================================= +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, FRAC, L, PTEMP ) +!!$OMP+SCHEDULE( DYNAMIC ) +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! !============================================================== +! ! If there is total precipitation in the (I,J) column, then: +! ! +! ! (1) Compute FRAC, the large scale fraction (if LS = .TRUE.) +! ! or convective fraction (if LS = .FALSE.) total +! ! precipitation. FRAC is computed from PREACC and PRECON. +! ! +! ! (2) Compute QQ, the rate of formation of precipitation +! ! [cm3 H2O/cm3 air/s]. From MOISTQ [kg H2O/kg air/s], +! ! the unit conversion is: +! ! +! ! kg H2O | m^3 H2O | AIRDEN kg air m^3 H2O +! ! ------------+-------------+--------------- ==> ------------- +! ! kg air * s | 1000 kg H2O | m^3 air m^3 air * s +! ! +! ! and +! ! +! ! m^3 H2O cm^3 H2O +! ! ------------- is equivalent to -------------- +! ! m^3 air * s cm^3 air * s! +! ! +! ! since the same conversion factor (10^6 cm^3/m^3) is in both +! ! the numerator and the denominator. +! ! +! ! Therefore, the equation for QQ is: +! ! +! ! QQ(L,I,J) = FRAC * MOISTQ(L,I,J) * AIRDEN(L,I,J) / 1000.0 +! ! +! ! (3) Compute PDOWN, the column precipitation +! ! [cm3 H2O/cm2 air/s], by multiplying QQ(L,I,J) by +! ! BXHEIGHT(I,J,L) * 100 cm. +! ! +! ! (4) The reason why we do not force PTEMP to be positive is +! ! that PREACC is the integral of the MOISTQ field. MOISTQ +! ! contains both negative (evap) and positive (precip) +! ! values. If we forced PTEMP to be positive, then we would +! ! be adding extra precipitation to PDOWN (hyl, bmy, 3/6/99). +! !============================================================== +! IF ( PREACC(I,J) > 0d0 ) THEN +! +! ! Large scale or convective fraction of precipitation +! IF ( LS ) THEN +! FRAC = ( PREACC(I,J) - PRECON(I,J) ) / PREACC(I,J) +! ELSE +! FRAC = PRECON(I,J) / PREACC(I,J) +! ENDIF +! +! ! Start at the top of the atmosphere +! L = LLPAR +! +! ! Compute QQ and PDOWN. Keep PTEMP for the next level +! QQ(L,I,J) = FRAC * MOISTQ(L,I,J) * AIRDEN(L,I,J) / 1d3 +! PTEMP = QQ(L,I,J) * BXHEIGHT(I,J,L) * 1d2 +! PDOWN(L,I,J) = PTEMP +! +! ! PDOWN cannot be negative +! IF ( PDOWN(L,I,J) < 0d0 ) PDOWN(L,I,J) = 0.d0 +! +! ! Loop down from LLPAR to the surface +! DO L = LLPAR-1, 1, -1 +! +! ! Compute QQ and PDOWN. Keep PTEMP for the next level. +! QQ(L,I,J) = FRAC * MOISTQ(L,I,J) * AIRDEN(L,I,J) / 1d3 +! PDOWN(L,I,J) = PTEMP + QQ(L,I,J) * BXHEIGHT(I,J,L) * 1d2 +! PTEMP = PDOWN(L,I,J) +! +! ! PDOWN cannot be negative +! IF ( PDOWN(L,I,J) < 0.0d0 ) PDOWN(L,I,J) = 0.d0 +! ENDDO +! +! !============================================================== +! ! If there is no precipitation reaching the surface in the +! ! (I,J) column, then assume any precipitation at altitude to +! ! be large-scale. +! ! +! ! (1) Assume the large scale fraction = 1d0, +! ! convective fraction = 0d0 +! ! (2) Compute QQ as described above +! ! (3) Compute PDOWN as described above +! !============================================================== +! ELSE +! +! ! Assume large-scale precipitation! +! IF ( LS ) THEN +! FRAC = 1d0 +! ELSE +! FRAC = 0d0 +! ENDIF +! +! ! Start at the top of the atmosphere +! L = LLPAR +! +! ! Compute QQ and PDOWN. Keep PTEMP for the next level +! QQ(L,I,J) = FRAC * MOISTQ(L,I,J) * AIRDEN(L,I,J) / 1d3 +! PTEMP = QQ(L,I,J) * BXHEIGHT(I,J,L) * 1d2 +! PDOWN(L,I,J) = PTEMP +! +! ! PDOWN cannot be negative +! IF( PDOWN(L,I,J) < 0d0 ) PDOWN(L,I,J) = 0.d0 +! +! ! Loop down from LLPAR to the surface +! DO L = LLPAR-1, 1, -1 +! +! ! Compute QQ and PDOWN. Keep PTEMP for the next level +! QQ(L,I,J) = FRAC * MOISTQ(L,I,J) * AIRDEN(L,I,J) / 1d3 +! PDOWN(L,I,J) = PTEMP + QQ(L,I,J) * BXHEIGHT(I,J,L) * 1d2 +! PTEMP = PDOWN(L,I,J) +! +! ! PDOWN cannot be negative +! IF ( PDOWN(L,I,J) < 0.0d0 ) PDOWN(L,I,J) = 0.d0 +! ENDDO +! ENDIF +! ENDDO ! J +! ENDDO ! I +!!$OMP END PARALLEL DO +! +! ! Return to calling program +! END SUBROUTINE MAKE_QQ +! +!!------------------------------------------------------------------------------ +! +! FUNCTION E_ICE( TK ) RESULT( VALUE ) +!! +!!****************************************************************************** +!! Subroutine E_ICE computes Eice(T), the saturation vapor pressure of ice +!! at a given Celsius temperature. (bmy, 2/8/05) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) TK (REAL*8) : Ambient temperature [K] +!! +!! References: +!! ============================================================================ +!! (1 ) Marti & Mauersberber (GRL '93) formulation of saturation +!! vapor pressure of ice [Pa] is: log P = A/TK + B +!! +!! NOTES: +!! (1 ) Now use the same analytic function as the Goddard CTM (bmy, 2/8/05) +!!****************************************************************************** +!! +! ! Arguments as Input +! REAL*8, INTENT(IN) :: TK +! +! ! Return value +! REAL*8 :: VALUE +! +! ! Parameters +! REAL*8, PARAMETER :: A = -2663.5d0 +! REAL*8, PARAMETER :: B = 12.537d0 +! +! !================================================================= +! ! E_ICE begins here! +! !================================================================= +! +! ! Saturation vap press of Ice [Pa] -- divide by 100 for [hPa] +! VALUE = ( 10d0**( A/TK + B ) ) / 100d0 +! +! ! Return to calling program +! END FUNCTION E_ICE +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE COMPUTE_L2G( Kstar298, H298_R, TK, H2OLIQ, L2G ) +!! +!!****************************************************************************** +!! Subroutine COMPUTE_L2G computes the ratio L2G = Cliq / Cgas, which is +!! the mixing ratio of tracer in the liquid phase, divided by the mixing +!! ratio of tracer in the gas phase. (bmy, 2/23/00, 11/8/02) +!! +!! The ratio Cliq / Cgas is obtained via Henry's law. The appropriate +!! values of Kstar298 and H298_R must be supplied for each tracer. +!! (cf Jacob et al 2000, p. 3) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) Kstar298 (REAL*8) : Eff. Henry's law constant @ 298 K [moles/atm] +!! (2 ) H298_R (REAL*8) : Molar heat of formation @ 298 K / R [K] +!! (3 ) TK (REAL*8) : Temperature at grid box (I,J,L) [K] +!! (4 ) H2OLIQ (REAL*8) : Liquid water content at (I,J,L) [cm3 H2O/cm3 air] +!! +!! Arguments as Output: +!! ============================================================================ +!! (5 ) L2G (REAL*8) : Cliq/Cgas ratio for given tracer [unitless] +!! +!! References (see above for full citations): +!! =========================================================================== +!! (1 ) Jacob et al, 2000 +!! +!! NOTES: +!! (1 ) Bundled into "wetscav_mod.f" (bmy, 11/8/02) +!!****************************************************************************** +!! +! ! Arguments +! REAL*8, INTENT(IN) :: KStar298, H298_R, TK, H2OLIQ +! REAL*8, INTENT(OUT) :: L2G +! +! ! Local variables +! REAL*8 :: Kstar +! +! ! R = universal gas constant [atm/moles/K] +! REAL*8, PARAMETER :: R = 8.32d-2 +! +! ! INV_T0 = 1/298 K +! REAL*8, PARAMETER :: INV_T0 = 1d0 / 298d0 +! +! !================================================================= +! ! COMPUTE_L2G begins here! +! !================================================================= +! +! ! Get Kstar, the effective Henry's law constant for temperature TK +! Kstar = Kstar298 * EXP( -H298_R * ( ( 1d0 / TK ) - INV_T0 ) ) +! +! ! Use Henry's Law to get the ratio: +! ! [ mixing ratio in liquid phase / mixing ratio in gas phase ] +! L2G = Kstar * H2OLIQ * R * TK +! +! ! Return to calling program +! END SUBROUTINE COMPUTE_L2G +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE COMPUTE_F( N, F, ISOL ) +!! +!!****************************************************************************** +!! Subroutine COMPUTE_F computes F, the fraction of soluble tracer lost by +!! scavenging in convective cloud updrafts. (hyl, bmy, djj, 2/23/00, 7/26/06) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) N (INTEGER) : Tracer number +!! +!! Arguments as Output: +!! ============================================================================ +!! (2 ) F (REAL*8) : Fraction of tracer scavenged in cloud updraft [0-1] +!! (3 ) ISOL (INTEGER) : Index number for ND38 diagnostic +!! +!! References (see above for full citations): +!! =========================================================================== +!! (1 ) Jacob et al, 2000 +!! (2 ) Chin et al, 1996 +!! +!! NOTES: +!! (1 ) Currently works computes scavenging fractions for either full +!! chemistry simulation (NSRCX == 3) or Rn-Pb-Be chemistry simulation +!! (NSRCX == 1). Set the scavenging fraction to zero for other +!! simulations which do not carry soluble tracers. (bmy, 3/2/00) +!! (2 ) Need to call INIT_SCAV to initialize the Vud, C_H2O, CLDLIQ, +!! and CLDICE fields once per timestep. (bmy, 2/23/00) +!! (3 ) For aerosols only: now apply Eq. 2 for all temperatures. Also +!! use the distance between the grid box centers in Eq. 2. Updated +!! comments and made some cosmetic changes (hyl, bmy, 6/18/01) +!! (4 ) Remove IREF, JREF -- these are obsolete. T is now dimensioned +!! (IIPAR,JJPAR,LLPAR). T(IREF,JREF,L) is now T(I,J,L). (bmy, 9/27/01) +!! (5 ) Removed obsolete code from 9/01 (bmy, 10/23/01) +!! (6 ) Fix 2 bugs for aerosol scavenging in Rn-Pb-Be simulation: +!! (a) set F(:,:,1) = 0 since we don't do any scavenging there. +!! (b) DO L = 2, LLPAR to avoid any subscript range out of bounds +!! errors (rjp, hyl, bmy, 1/10/02) +!! (7 ) Now set F=0 in the first level for all tracers. Also now +!! compute the distance between grid box centers and use that in +!! in Eq. 10 from Jacob et al, 2000 to compute F. (hyl, bmy, 1/24/02) +!! (8 ) Eliminated obsolete code from 1/02 (bmy, 2/27/02) +!! (9 ) Now reference T from "dao_mod.f" instead of from "CMN". Also reference +!! BXHEIGHT from "dao_mod.f" instead of from "CMN_NOX". Now bundled +!! into "wetscav_mod.f". Now references IDTHNO3, IDTH2O2, etc, from +!! F90 module "tracerid_mod.f". Added internal routines F_AEROSOL +!! and GET_ISOL. Rewritten so that we don't duplicate code for +!! different chemistry simulations. (bmy, 1/17/03) +!! (10) Now compute F for SO2 in the same way for both fullchem and offline +!! simulations (rjp, bmy, 3/23/03) +!! (11) Added slots for carbon aerosol & dust tracers. Now modified internal +!! routine GET_ISOL so it's not hardwired anymore. (rjp, bmy, 4/5/04) +!! (12) Added slots for sea salt aerosol tracers (rjp, bec, bmy, 4/20/04) +!! (13) Added slots for secondary organic aerosol tracers (rjp, bmy, 7/13/04) +!! (14) Remove reference to CMN, it's not needed. Made internal routine +!! F_AEROSOL a module procedure rather than an internal routine to +!! COMPUTE_F in order to facilitate parallelization on the Altix. Also +!! now pass all arguments explicitly to F_AEROSOL. (bmy, 7/20/04) +!! (15) Now wet scavenge mercury aerosol tracers (eck, bmy, 12/9/04) +!! (16) Updated for AS, AHS, LET, NH4aq, SO4aq. Also condensed the IF +!! statement by combining branches for aerosols. (cas, bmy, 12/20/04) +!! (17) Updated for SO4s, NITs (bec, bmy, 4/25/05) +!! (18) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (19) Bug fix: Now do not over-deplete H2O2s. Also change Henry's law +!! constant for Hg2 to 1.0d+14. Now use functions IS_Hg2 and IS_HgP to +!! determine if a tracer is an Hg2 or HgP tagged tracer. +!! (dkh, rjp, eck, cdh, bmy, 1/6/06) +!! (20) Updated for SOG4 and SOA4 (dkh, bmy, 5/18/06) +!! (21) Bug fix: now use separate conversion factors for H2O2 and NH3. +!! (havala, bmy, 7/26/06) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE DAO_MOD, ONLY : BXHEIGHT, T +! USE TRACERID_MOD, ONLY : IDTPB, IDTBE7, IDTHNO3, IDTH2O2 +! USE TRACERID_MOD, ONLY : IDTCH2O, IDTMP, IDTSO2, IDTSO4 +! USE TRACERID_MOD, ONLY : IDTSO4s, IDTSO4aq, IDTMSA, IDTNH3 +! USE TRACERID_MOD, ONLY : IDTNH4, IDTNH4aq, IDTNIT, IDTNITs +! USE TRACERID_MOD, ONLY : IDTAS, IDTAHS, IDTLET, IDTBCPI +! USE TRACERID_MOD, ONLY : IDTOCPI, IDTBCPO, IDTOCPO, IDTDST1 +! USE TRACERID_MOD, ONLY : IDTDST2, IDTDST3, IDTDST4, IDTSALA +! USE TRACERID_MOD, ONLY : IDTSALC, IDTALPH, IDTLIMO, IDTALCO +! USE TRACERID_MOD, ONLY : IDTSOG1, IDTSOG2, IDTSOG3, IDTSOG4 +! USE TRACERID_MOD, ONLY : IDTSOA1, IDTSOA2, IDTSOA3, IDTSOA4 +! USE TRACERID_MOD, ONLY : IS_Hg2, IS_HgP +! USE TRACERID_MOD, ONLY : IDTGLYX, IDTMGLY, IDTGLYC +! USE TRACERID_MOD, ONLY : IDTSOAG, IDTSOAM +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: N +! REAL*8, INTENT(OUT) :: F(IIPAR,JJPAR,LLPAR) +! INTEGER, INTENT(OUT) :: ISOL +! +! ! Local variables +! INTEGER :: I, J, L, NN +! REAL*8 :: L2G, I2G, C_TOT, F_L, F_I, K, TMP, SO2LOSS +! +! ! Kc is the conversion rate from cloud condensate to precip [s^-1] +! REAL*8, PARAMETER :: KC = 5d-3 +! +! ! CONV_H2O2 = 0.6 * SQRT( 1.9 ), used for the ice to gas ratio for H2O2 +! ! 0.6 is ( sticking coeff H2O2 / sticking coeff water ) +! ! 1.9 is ( molecular weight H2O2 / molecular weight water ) +! REAL*8, PARAMETER :: CONV_H2O2 = 8.27042925126d-1 +! +! ! CONV_NH3 = 0.6 * SQRT( 0.9 ), used for the ice to gas ratio for NH3 +! ! 0.6 is ( sticking coeff NH3 / sticking coeff water ) +! ! 0.9 is ( molecular weight NH3 / molecular weight water ) +! REAL*8, PARAMETER :: CONV_NH3 = 5.69209978831d-1 +! +! !================================================================= +! ! COMPUTE_F begins here! +! ! +! ! For aerosol tracers, compute F with internal routine F_AEROSOL. +! ! ISOL = tracer index for the ND38 diagnostic. +! !================================================================= +! +! !------------------------------- +! ! 210Pb and 7Be (aerosols) +! !------------------------------- +! IF ( N == IDTPb .or. N == IDTBe7 ) THEN +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! HNO3 (aerosol) +! !------------------------------- +! ELSE IF ( N == IDTHNO3 ) THEN +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! H2O2 (liquid & ice phases) +! !------------------------------- +! ELSE IF ( N == IDTH2O2 ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Start scavenging at level 2 +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute ice to gas ratio for H2O2 by co-condensation +! ! (Eq. 9, Jacob et al, 2000) +! IF ( C_H2O(I,J,L) > 0d0 ) THEN +! I2G = ( CLDICE(I,J,L) / C_H2O(I,J,L) ) * CONV_H2O2 +! ELSE +! I2G = 0d0 +! ENDIF +! +! ! Compute liquid to gas ratio for H2O2, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 8.3d4, -7.4d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of H2O2 in liquid & ice phases +! ! (Eqs. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G + I2G +! F_L = L2G / C_TOT +! F_I = I2G / C_TOT +! +! ! Compute the rate constant K. The retention factor for +! ! liquid H2O2 is 0.05 for 248 K < T < 268 K and 1.0 for +! ! T >= 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * ( F_L + F_I ) +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( ( 5d-2 * F_L ) + F_I ) +! +! ELSE +! K = KC * F_I +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! Compute F, the fraction of scavenged H2O2. +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! CH2O (liquid phase only) +! !------------------------------- +! ELSE IF ( N == IDTCH2O ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Apply scavenging in levels 2 and higher +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute liquid to gas ratio for CH2O, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 3.0d3, -7.2d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of CH2O in liquid phase +! ! NOTE: CH2O does not exist in the ice phase! +! ! (Eqs. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. The retention factor +! ! for liquid CH2O is 0.0 for T <= 248K and 0.02 for +! ! 248 K < T < 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * F_L +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! F is the fraction of CH2O scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! ! Update GLYX and MGLY Henry's Law Const calculations (tmf, 9/13/06) +! !------------------------------- +! ! GLYX (liquid phase only) +! !------------------------------- +! ELSE IF ( N == IDTGLYX ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Apply scavenging in levels 2 and higher +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute liquid to gas ratio for GLYX, using +! ! (1) Zhou and Mopper (1990): Kstar298 = 3.6e5 M/atm +! ! (2) Schweitzer et al. (1998) showed that the temperature dependence +! ! for CH2O works well for glyoxal, so we use the same H298_R as CH2O +! CALL COMPUTE_L2G( 3.6d5, -7.2d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of GLYX in liquid phase +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! assume same retention factor as CH2O +! ! Compute the rate constant K. The retention factor +! ! for liquid CH2O is 0.0 for T <= 248K and 0.02 for +! ! 248 K < T < 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * F_L +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! F is the fraction of GLYX scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! MGLY (liquid phase only) +! !------------------------------- +! ELSE IF ( N == IDTMGLY ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Apply scavenging in levels 2 and higher +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute liquid to gas ratio for MGLY, using +! ! the appropriate parameters for Henry's law +! ! from Betterton and Hoffman 1988): Kstar298 = 3.71d3 M/atm; +! ! H298_R = -7.5d3 K +! CALL COMPUTE_L2G( 3.7d3, -7.5d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of MGLY in liquid phase +! ! NOTE: CH2O does not exist in the ice phase! +! ! (Eqs. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! assume same retention factor as CH2O +! ! Compute the rate constant K. The retention factor +! ! for liquid CH2O is 0.0 for T <= 248K and 0.02 for +! ! 248 K < T < 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * F_L +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! F is the fraction of MGLY scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! GLYC (liquid phase only) +! !------------------------------- +! ELSE IF ( N == IDTGLYC ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Apply scavenging in levels 2 and higher +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute liquid to gas ratio for GLYC, using +! ! the appropriate parameters for Henry's law +! ! from Betterton and Hoffman 1988): Kstar298 = 4.1d4 M/atm; H298_R = -4600 K +! CALL COMPUTE_L2G( 4.1d4, -4.6d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of MGLY in liquid phase +! ! NOTE: CH2O does not exist in the ice phase! +! ! (Eqs. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! assume same retention factor as CH2O +! ! Compute the rate constant K. The retention factor +! ! for liquid CH2O is 0.0 for T <= 248K and 0.02 for +! ! 248 K < T < 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * F_L +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! F is the fraction of MGLY scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! CH3OOH (liquid phase only) +! !------------------------------- +! ELSE IF ( N == IDTMP ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Start scavenging at level 2 +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute liquid to gas ratio for CH3OOH, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 3.1d2, -5.2d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of CH3OOH in liquid phase +! ! NOTE: CH3OOH does not exist in the ice phase! +! ! (Eq. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. The retention factor +! ! for liquid CH3OOH is 0.0 for T <= 248 K and 0.02 for +! ! 248 K < T < 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * F_L +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! F is the fraction of CH3OOH scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !------------------------------ +! ! SO2 (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTSO2 ) THEN +! +! ! Compute fraction of SO2 scavenged +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !============================================================== +! ! Coupled full chemistry/aerosol simulation: +! ! Use the wet scavenging formula of Chin et al [1996], +! ! such that a soluble fraction of SO2 is limited by the +! ! availability of H2O2 in the precipitating grid box. +! ! Scavenge the soluble SO2 at the same rate as the sulfate. +! ! Update H2O2_sav and SO2_sav for use in RAINOUT, WASHOUT +! !============================================================== +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Make sure to deplete H2O2s the same as SO2s. +! ! (dkh, rjp, bmy, 11/17/05) +! IF ( SO2s(I,J,L) > EPSILON ) THEN +! +! ! Limit F +! SO2LOSS = MIN( H2O2s(I,J,L), SO2s(I,J,L) ) +! F(I,J,L) = F(I,J,L) * SO2LOSS / SO2s(I,J,L) +! F(I,J,L) = MAX(F(I,J,L), 0d0) +! +! ! Update saved H2O2 concentration +! H2O2s(I,J,L) = H2O2s(I,J,L) - ( SO2s(I,J,L) * F(I,J,L) ) +! H2O2s(I,J,L) = MAX( H2O2s(I,J,L), EPSILON ) +! +! ELSE +! +! ! Set F = 0 if SO2s < EPSILON (dkh, rjp, bmy, 11/17/05) +! F(I,J,L) = 0d0 +! +! ENDIF +! +! ! Update SO2 +! SO2s(I,J,L) = SO2s(I,J,L) * ( 1d0 - F(I,J,L) ) +! SO2s(I,J,L) = MAX( SO2s(I,J,L), EPSILON ) +! +! ENDDO +! ENDDO +! ENDDO +! +! !------------------------------- +! ! SO4 (gaseous aerosol) or +! ! SO4aq (aqueous aerosol) +! !------------------------------- +! ELSE IF ( N == IDTSO4 .or. N == IDTSO4s .or. N == IDTSO4aq ) THEN +! +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! MSA (aerosol) +! !------------------------------- +! ELSE IF ( N == IDTMSA ) THEN +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! NH3 (liquid & ice phases) +! !------------------------------- +! ELSE IF ( N == IDTNH3 ) THEN +! +! ! No scavenging at surface +! F(:,:,1) = 0d0 +! +! ! Start scavenging at level 2 +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute ice to gas ratio for NH3 by co-condensation +! ! (Eq. 9, Jacob et al, 2000) +! IF ( C_H2O(I,J,L) > 0d0 ) THEN +! I2G = ( CLDICE(I,J,L) / C_H2O(I,J,L) ) * CONV_NH3 +! ELSE +! I2G = 0d0 +! ENDIF +! +! ! Compute liquid to gas ratio for NH3, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 3.3d6, -4.1d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of NH3 in liquid & ice phases +! ! (Eqs. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G + I2G +! F_L = L2G / C_TOT +! F_I = I2G / C_TOT +! +! ! Compute the rate constant K. The retention factor +! ! for liquid NH3 is 0.0 for T <= 248 K and 0.05 for +! ! 248 K < T < 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * ( F_L + F_I ) +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( ( 5d-2 * F_L ) + F_I ) +! +! ELSE +! K = KC * F_I +! +! ENDIF +! +! ! F is the fraction of NH3 scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * BXHEIGHT(I,J,L) / Vud(I,J) ) +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! NH4 (gaseous aerosol) or +! ! NH4aq (aqueous aerosol) +! !------------------------------- +! ELSE IF ( N == IDTNH4 .or. N == IDTNH4aq ) THEN +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! NIT / LET / AS / AHS (aerosol) +! !------------------------------- +! ELSE IF ( N == IDTNIT .or. N == IDTNITs .or. +! & N == IDTAS .or. N == IDTAHS .or. +! & N == IDTLET ) THEN +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! BC HYDROPHILIC (aerosol) or +! ! OC HYDROPHILIC (aerosol) +! !------------------------------- +! ELSE IF ( N == IDTBCPI .or. N == IDTOCPI ) THEN +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! BC HYDROPHOBIC (aerosol) or +! ! OC HYDROPHOBIC (aerosol) +! !------------------------------- +! ELSE IF ( N == IDTBCPO .or. N == IDTOCPO ) THEN +! +! ! Force not to be lost in convective updraft for now +! F = 0d0 +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! DST1/DST2/DST3/DST4 (aerosol) +! !------------------------------- +! ELSE IF ( N == IDTDST1 .or. N == IDTDST2 .or. +! & N == IDTDST3 .or. N == IDTDST4 ) THEN +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! Accum mode seasalt (aerosol) +! ! Coarse mode seasalt (aerosol) +! !------------------------------- +! ELSE IF ( N == IDTSALA .or. N == IDTSALC ) THEN +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! ALPH (liquid phase only) +! !------------------------------- +! ELSE IF ( N == IDTALPH ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Start scavenging at level 2 +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute liquid to gas ratio for ALPH, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 0.023d0, 0.d0, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of ALPH in liquid phase +! ! (Eq. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. Assume retention factor +! ! for liquid ALPH is 0.0 for T <= 248 K and 0.02 for +! ! 248 K < T < 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * F_L +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! F is the fraction of ALPH scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! LIMO (liquid phase only) +! !------------------------------- +! ELSE IF ( N == IDTLIMO ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Start scavenging at level 2 +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute liquid to gas ratio for LIMO, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 0.07d0, 0.d0, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of LIMO in liquid phase +! ! (Eq. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. Assume retention factor +! ! for liquid LIMO is 0.0 for T <= 248 K and 0.02 for +! ! 248 K < T < 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * F_L +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! F is the fraction of LIMO scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! ALCO (liquid phase only) +! !------------------------------- +! ELSE IF ( N == IDTALCO ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Start scavenging at level 2 +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute liquid to gas ratio for ALCO, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 54.d0, 0.d0, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of ALCO in liquid phase +! ! (Eq. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. Assume retention factor +! ! for liquid ALCO is 0.0 for T <= 248 K and 0.02 for +! ! 248 K < T < 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * F_L +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! F is the fraction of ALCO scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !----------------------------------- +! ! SOG[1,2,3,4] (liquid phase only) +! !----------------------------------- +! ELSE IF ( N == IDTSOG1 .or. N == IDTSOG2 .or. +! & N == IDTSOG3 .or. N == IDTSOG4 ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Start scavenging at level 2 +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute liquid to gas ratio for GAS1, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 1.0d5, -6.039d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of GAS1 in liquid phase +! ! (Eq. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. Assume retention factor +! ! for liquid GAS1 is 0.0 for T <= 248 K and 0.02 for +! ! 248 K < T < 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * F_L +! +! ELSE IF ( T(I,J,L) > 248d0 .and. T(I,J,L) < 268d0 ) THEN +! K = KC * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! F is the fraction of GAS1 scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !------------------------------------------ +! ! SOA[1,2,3,4] (aerosol) +! ! Scavenging efficiency for SOA is 0.8 +! !------------------------------------------ +! ELSE IF ( N == IDTSOA1 .or. N == IDTSOA2 .or. +! & N == IDTSOA3 .or. N == IDTSOA4 ) THEN +! CALL F_AEROSOL( KC, F ) +! +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! F(I,J,L) = 0.8d0 * F(I,J,L) +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! +! !------------------------------------------ +! ! SOAG, SOAM (aerosol) +! ! Scavenging efficiency for SOA is 0.8 +! !------------------------------------------ +! ELSE IF ( N == IDTSOAG .or. N == IDTSOAM ) THEN +! CALL F_AEROSOL( KC, F ) +! +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! F(I,J,L) = 0.8d0 * F(I,J,L) +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! Hg2 (liquid phase only) +! !------------------------------- +! ELSE IF ( IS_Hg2( N ) ) THEN +! +! ! No scavenging at the surface +! F(:,:,1) = 0d0 +! +! ! Apply scavenging in levels 2 and higher +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute liquid to gas ratio for HgCl2, using +! ! the appropriate parameters for Henry's law +! ! (Refs: INSERT HERE) +! ! +! CALL COMPUTE_L2G( 1.0d+14, -8.4d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of HgCl2 in liquid phase +! ! Assume that HgCl2 is not present in ice phase +! ! (Eqs. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. Assume scavenging takes +! ! place only in warm clouds (retention = 0 where T<268) +! ! +! IF ( T(I,J,L) >= 268d0 ) THEN +! K = KC * F_L +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! F is the fraction of HgCl2 scavenged out of the updraft +! ! (Eq. 2, Jacob et al, 2000) +! F(I,J,L) = 1d0 - EXP( -K * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! ND38 index +! ISOL = GET_ISOL( N ) +! +! !------------------------------- +! ! HgP (treat like aerosol) +! !------------------------------- +! ELSE IF ( IS_HgP( N ) ) THEN +! +! CALL F_AEROSOL( KC, F ) +! ISOL = GET_ISOL( N ) +! +! !---------------------------- +! ! Insoluble tracer, set F=0 +! !---------------------------- +! ELSE +! F(:,:,:) = 0d0 +! ISOL = 0 +! +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE COMPUTE_F +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE F_AEROSOL( KC, F ) +!! +!!****************************************************************************** +!! Subroutine F_AEROSOL returns the fraction of aerosol scavenged in updrafts +!! (bmy, 11/7/02, 7/20/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) KC (REAL*8) : Conversion rate from cloud condensate to precip [s^-1] +!! +!! Arguments as Output: +!! ============================================================================ +!! (2 ) F (REAL*8) : Fraction of aerosol scavenged in updrafts [unitless] +!! +!! NOTES: +!! (1 ) Split off +!!****************************************************************************** +!! +! ! References to F90 modules +! USE DAO_MOD, ONLY : BXHEIGHT +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! REAL*8, INTENT(IN) :: KC +! REAL*8, INTENT(OUT) :: F(IIPAR,JJPAR,LLPAR) +! +! ! Local variables +! INTEGER :: I, J, L +! REAL*8 :: TMP +! +! !================================================================= +! ! F_AEROSOL begins here! +! ! +! ! Aerosol tracers are 100% in the cloud condensate phase, so +! ! we set K = Kc, and compute F accordingly (cf Jacob et al 2000 ) +! !================================================================= +! +! ! Turn off scavenging in the first level by setting F = 0 +! F(:,:,1) = 0d0 +! +! ! Apply scavenging in levels 2 and higher +! DO L = 2, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Distance between grid box centers [m] +! TMP = 0.5d0 * ( BXHEIGHT(I,J,L-1) + BXHEIGHT(I,J,L) ) +! +! ! (Eq. 2, Jacob et al, 2000, with K = Kc) +! F(I,J,L) = 1d0 - EXP( -KC * TMP / Vud(I,J) ) +! +! ENDDO +! ENDDO +! ENDDO +! +! ! Return to calling program +! END SUBROUTINE F_AEROSOL +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_ISOL( N_TEST ) RESULT( VALUE ) +!! +!!****************************************************************************** +!! Function GET_ISOL returns the value of ISOL (tracer index for ND38) for +!! all simulation types. (bmy, 4/5/04, 7/20/04) +!! +!! +!! NOTES: +!! (1 ) Now initializes a lookup table for faster execution. Now made into +!! an EXTERNAL function. (rjp, bmy, 4/5/04) +!! (2 ) Now references N_TRACERS from "tracer_mod.f" (bmy, 7/20/04) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE TRACER_MOD, ONLY : N_TRACERS +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: N_TEST +! +! ! Local variables +! LOGICAL, SAVE :: FIRST = .TRUE. +! INTEGER, SAVE :: NSOL_INDEX(NNPAR) +! INTEGER :: I, L, N +! +! ! Function value +! INTEGER :: VALUE +! +! !================================================================= +! ! GET_ISOL begins here! +! !================================================================= +! +! ! Initialize lookup table on the first call +! IF ( FIRST ) THEN +! +! ! Initialize +! NSOL_INDEX(:) = 0 +! +! ! Loop over tracers +! DO N = 1, N_TRACERS +! +! ! Loop over soluble tracers +! DO L = 1, NSOL +! +! ! Test if tracer N is among the soluble tracers +! IF ( IDWETD(L) == N ) THEN +! +! ! Save location into the lookup table +! NSOL_INDEX(N) = L +! +! ! Go to next N +! GOTO 100 +! ENDIF +! ENDDO +! +! 100 CONTINUE +! ENDDO +! +! ! Reset first-time flag +! FIRST = .FALSE. +! ENDIF +! +! ! Return value +! VALUE = NSOL_INDEX(N_TEST) +! +! ! Return to COMPUTE_F +! END FUNCTION GET_ISOL +! +!------------------------------------------------------------------------------ +! +! SUBROUTINE RAINOUT( I, J, L, N, K_RAIN, DT, F, RAINFRAC ) +!! +!!****************************************************************************** +!! Subroutine RAINOUT computes RAINFRAC, the fraction of soluble tracer +!! lost to rainout events in precipitation. (djj, bmy, 2/28/00, 3/5/08) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1-3) I, J, L (INTEGER) : Grid box lon-lat-alt indices +!! (4 ) N (INTEGER) : Tracer number +!! (5 ) K_RAIN (REAL*8 ) : Rainout rate constant for tracer N [s^-1] +!! (6 ) DT (REAL*8 ) : Timestep for rainout event [s] +!! (7 ) F (REAL*8 ) : Fraction of grid box precipitating [unitless] +!! +!! Arguments as Output: +!! ============================================================================ +!! (8 ) RAINFRAC (REAL*8) : Fraction of tracer lost to rainout [unitless] +!! +!! References (see above for full citations): +!! ============================================================================ +!! (1 ) Jacob et al, 2000 +!! (2 ) Chin et al, 1996 +!! +!! NOTES: +!! (1 ) Currently works for either full chemistry simulation (NSRCX == 3) +!! or Rn-Pb-Be chemistry simulation (NSRCX == 1). Other simulations +!! do not carry soluble tracer, so set RAINFRAC = 0. (bmy, 2/28/00) +!! (2 ) Need to call INIT_SCAV to initialize the Vud, C_H2O, CLDLIQ, +!! and CLDICE fields once per dynamic timestep. (bmy, 2/28/00) +!! (3 ) K_RAIN, the rainout rate constant, and F, the areal fraction of the +!! grid box undergoing precipitiation, are computed according to +!! Giorgi & Chaimedes, as described in Jacob et al, 2000. +!! (4 ) Now no longer suppress scavenging of HNO3 and aerosol below 258K. +!! Updated comments, cosmetic changes. Now set TK = T(I,J,L) since +!! T is now sized (IIPAR,JJPAR,LLPAR) in "CMN". (djj, hyl, bmy, 1/24/02) +!! (5 ) Eliminated obsolete code (bmy, 2/27/02) +!! (6 ) Now reference T from "dao_mod.f". Updated comments. Now bundled +!! into "wetscav_mod.f". Now refererences "tracerid_mod.f". Also +!! removed reference to CMN since we don't need NSRCX. (bmy, 11/8/02) +!! (7 ) Now updated for carbon & dust aerosol tracers (rjp, bmy, 4/5/04) +!! (8 ) Now updated for seasalt aerosol tracers (rjp, bec, bmy, 4/20/04) +!! (9 ) Now updated for secondary aerosol tracers (rjp, bmy, 7/13/04) +!! (10) Now treat rainout of mercury aerosol tracers (eck, bmy, 12/9/04) +!! (11) Updated for AS, AHS, LET, NH4aq, SO4aq. Also condensed the IF +!! statement by grouping blocks together. (cas, bmy, 12/20/04) +!! (12) Updated for SO4s, NITs (bec, bmy, 4/25/05) +!! (13) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (14) Change Henry's law constant for Hg2 to 1.0d+14. Now use functions +!! IS_Hg2 and IS_HgP to determine if the tracer is a tagged Hg0 or +!! HgP tracer. (eck, cdh, bmy, 1/6/06) +!! (15) Updated for SOG4 and SOA4 (dkh, bmy, 5/18/06) +!! (16) For GEOS-5, suppress rainout when T < 258K (hyl, bmy, 3/5/08) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE DAO_MOD, ONLY : T +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE TRACERID_MOD, ONLY : IDTPB, IDTBE7, IDTHNO3, IDTH2O2 +! USE TRACERID_MOD, ONLY : IDTCH2O, IDTMP, IDTSO2, IDTSO4 +! USE TRACERID_MOD, ONLY : IDTSO4s, IDTSO4aq, IDTMSA, IDTNH3 +! USE TRACERID_MOD, ONLY : IDTNH4, IDTNH4aq, IDTNIT, IDTNITs +! USE TRACERID_MOD, ONLY : IDTAS, IDTAHS, IDTLET, IDTBCPI +! USE TRACERID_MOD, ONLY : IDTOCPI, IDTBCPO, IDTOCPO, IDTDST1 +! USE TRACERID_MOD, ONLY : IDTDST2, IDTDST3, IDTDST4, IDTSALA +! USE TRACERID_MOD, ONLY : IDTSALC, IDTALPH, IDTLIMO, IDTALCO +! USE TRACERID_MOD, ONLY : IDTSOG1, IDTSOG2, IDTSOG3, IDTSOG4 +! USE TRACERID_MOD, ONLY : IDTSOA1, IDTSOA2, IDTSOA3, IDTSOA4 +! USE TRACERID_MOD, ONLY : IS_Hg2, IS_HgP +! USE TRACERID_MOD, ONLY : IDTGLYX, IDTMGLY, IDTGLYC +! USE TRACERID_MOD, ONLY : IDTSOAG, IDTSOAM +! +! IMPLICIT NONE +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: I, J, L, N +! REAL*8, INTENT(IN) :: K_RAIN, DT, F +! REAL*8, INTENT(OUT) :: RAINFRAC +! +! ! Local variables +! REAL*8 :: L2G, I2G, C_TOT, F_L, F_I, K, TK, SO2LOSS +! +! ! CONV = 0.6 * SQRT( 1.9 ), used for the ice to gas ratio for H2O2 +! REAL*8, PARAMETER :: CONV = 8.27042925126d-1 +! +! !================================================================== +! ! RAINOUT begins here! +! ! +! ! For aerosols, set K = K_RAIN and compute RAINFRAC according +! ! to Eq. 10 of Jacob et al 2000. Call function GET_RAINFRAC. +! !================================================================== +! +! ! Save the local temperature in TK for convenience +! TK = T(I,J,L) +! +!#if defined( GEOS_5 ) +! !------------------------------------------------------------------ +! ! NOTE FROM HONGYU LIU (hyl@nianet.org) -- 3/5/08 +! ! +! ! Lead-210 (210Pb) and Beryllium-7 (7Be) simulations indicate +! ! that we can improve the GEOS-5 simulation by (1) turning off +! ! rainout/washout for convective precip (see DO_WETDEP) +! ! and (2) suppressing rainout for large-scale precip at +! ! temperatures below 258K. +! ! +! ! Place an #if block here to set RAINFRAC=0 when T < 258K for +! ! GEOS-5 met. This will suppress rainout. (hyl, bmy, 3/5/08) +! !------------------------------------------------------------------- +! IF ( TK < 258d0 ) THEN +! RAINFRAC = 0d0 +! RETURN +! ENDIF +!#endif +! +! !------------------------------ +! ! 210Pb and 7Be (aerosol) +! !------------------------------ +! IF ( N == IDTPb .or. N == IDTBe7 ) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! !------------------------------ +! ! HNO3 (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTHNO3 ) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! !------------------------------ +! ! H2O2 (liquid & ice phases) +! !------------------------------ +! ELSE IF ( N == IDTH2O2 ) THEN +! +! ! Compute ice to gas ratio for H2O2 by co-condensation +! ! (Eq. 9, Jacob et al, 2000) +! IF ( C_H2O(I,J,L) > 0d0 ) THEN +! I2G = ( CLDICE(I,J,L) / C_H2O(I,J,L) ) * CONV +! ELSE +! I2G = 0d0 +! ENDIF +! +! ! Compute liquid to gas ratio for H2O2, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8 and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 8.3d4, -7.4d3, TK, CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of H2O2 in liquid & ice phases +! ! (Eqs. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G + I2G +! F_L = L2G / C_TOT +! F_I = I2G / C_TOT +! +! ! Compute the rate constant K. The retention factor +! ! for liquid H2O2 is 0.05 for 248 K < T < 268 K, and +! ! 1.0 for T >= 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * ( F_L + F_I ) +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( ( 5d-2 * F_L ) + F_I ) +! +! ELSE +! K = K_RAIN * F_I +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out H2O2 +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! !------------------------------ +! ! CH2O (liquid phase only) +! !------------------------------ +! ELSE IF ( N == IDTCH2O ) THEN +! +! ! Compute liquid to gas ratio for CH2O, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8 and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 3.0d3, -7.2d3, TK, CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of CH2O in liquid phase +! ! NOTE: CH2O does not exist in the ice phase! +! ! (Eqs. 4, 5, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. The retention factor +! ! for liquid CH2O is 0.02 for 248 K < T < 268 K, and +! ! 1.0 for T > 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * F_L +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out CH2O +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! ! Update GLYX and MGLY Henry's Law Const calculations (tmf, 9/13/06) +! !------------------------------ +! ! GLYX (liquid phase only) +! !------------------------------ +! ELSE IF ( N == IDTGLYX ) THEN +! +! ! Compute liquid to gas ratio for GLYX, using +! ! (1) Zhou and Mopper (1990): Kstar298 = 3.6e5 M/atm +! ! (2) Schweitzer et al. (1998) showed that the temperature dependence +! ! for CH2O works well for glyoxal, so we use the same H298_R as CH2O +! CALL COMPUTE_L2G( 3.6d5, -7.2d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of GLYX in liquid phase +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! assume same retention factor as CH2O +! ! Compute the rate constant K. The retention factor +! ! for liquid CH2O is 0.02 for 248 K < T < 268 K, and +! ! 1.0 for T > 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * F_L +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out GLYX +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! !------------------------------ +! ! MGLY (liquid phase only) +! !------------------------------ +! ELSE IF ( N == IDTMGLY ) THEN +! +! ! Compute liquid to gas ratio for MGLY, using +! ! the appropriate parameters for Henry's law +! ! from Betterton and Hoffman 1988): Kstar298 = 3.71d3 M/atm; H298_R = -7.5d3 K +! CALL COMPUTE_L2G( 3.7d3, -7.5d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! +! ! Fraction of MGLY in liquid phase +! ! NOTE: CH2O does not exist in the ice phase! +! ! (Eqs. 4, 5, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! assume same retention factor as CH2O +! ! Compute the rate constant K. The retention factor +! ! for liquid CH2O is 0.02 for 248 K < T < 268 K, and +! ! 1.0 for T > 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * F_L +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out MGLY +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! !------------------------------ +! ! GLYC (liquid phase only) +! !------------------------------ +! ELSE IF ( N == IDTGLYC ) THEN +! +! ! Compute liquid to gas ratio for GLYC, using +! ! the appropriate parameters for Henry's law +! ! from Betterton and Hoffman 1988): Kstar298 = 4.1d4 M/atm; H298_R = -4.6d3 K +! CALL COMPUTE_L2G( 4.1d4, -4.6d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! +! ! Fraction of GLYC in liquid phase +! ! NOTE: CH2O does not exist in the ice phase! +! ! (Eqs. 4, 5, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! assume same retention factor as CH2O +! ! Compute the rate constant K. The retention factor +! ! for liquid CH2O is 0.02 for 248 K < T < 268 K, and +! ! 1.0 for T > 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * F_L +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out MGLY +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! +! !------------------------------ +! ! CH3OOH (liquid phase only) +! !------------------------------ +! ELSE IF ( N == IDTMP ) THEN +! +! ! Compute liquid to gas ratio for CH3OOH, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 3.1d2, -5.2d3, TK, CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of CH3OOH in liquid phase +! ! NOTE: CH3OOH does not exist in the ice phase! +! ! (Eqs. 4, 5, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. The retention factor +! ! for liquid CH3OOH is 0.02 for 248 K < T < 268 K, and +! ! 1.0 for T > 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * F_L +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out CH3OOH +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! !------------------------------ +! ! SO2 +! !------------------------------ +! ELSE IF ( N == IDTSO2 ) THEN +! +! !============================================================== +! ! NOTE: SO2 and H2O2 are in [v/v] and here RAINFRAC contains +! ! the amount of SO2 lost due to rainout normalized by the +! ! total SO2 -- so that in WETDEP routine mulitiplying SO2 in +! ! [kg] will produce correct amount. Need to verify this. +! ! (rjp, 01/16/02) +! !============================================================== +! +! ! Treat SO2 as an aerosol +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! ! We need to save a copy of the original RAINFRAC when +! ! recalculating these terms for the adjoint . (dkh, 10/26/05) +! IF ( LADJ ) THEN +! RAINFRAC_0(L) = RAINFRAC +! IF ( L_PRINTFD .and. I == IFD .and. J == JFD .and. L == LFD) +! & THEN +! print*, ' rainfrac_0 = ', rainfrac_0(L) +! ENDIF +! ENDIF +! +! ! Update SO2 and H2O2 +! IF ( SO2s(I,J,L) > EPSILON ) THEN +! +! ! Limit RAINFRAC +! SO2LOSS = MIN( SO2s(I,J,L), H2O2s(I,J,L) ) +! RAINFRAC = SO2LOSS * RAINFRAC / SO2s(I,J,L) +! RAINFRAC = MAX( RAINFRAC, 0d0 ) +! +! ! Update saved H2O2 concentration +! H2O2s(I,J,L) = H2O2s(I,J,L) - ( SO2s(I,J,L) * RAINFRAC ) +! H2O2s(I,J,L) = MAX( H2O2s(I,J,L), EPSILON ) +! +! ELSE +! RAINFRAC = 0D0 +! +! ENDIF +! +! ! Update saved SO2 concentration +! SO2s(I,J,L) = SO2s(I,J,L) * ( 1.D0 - RAINFRAC ) +! SO2s(I,J,L) = MAX( SO2s(I,J,L), EPSILON ) +! +! !---------------------------- +! ! SO4 and SO4aq (aerosol) +! !---------------------------- +! ELSE IF ( N == IDTSO4 .or. N == IDTSO4s .or. N == IDTSO4aq ) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! !------------------------------ +! ! MSA (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTMSA ) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! !------------------------------ +! ! NH3 (liquid & ice phases) +! !------------------------------ +! ELSE IF ( N == IDTNH3 ) THEN +! +! ! Compute ice to gas ratio for NH3 by co-condensation +! ! (Eq. 9, Jacob et al, 2000) +! IF ( C_H2O(I,J,L) > 0d0 ) THEN +! I2G = ( CLDICE(I,J,L) / C_H2O(I,J,L) ) * CONV +! ELSE +! I2G = 0d0 +! ENDIF +! +! ! Compute liquid to gas ratio for NH3, using +! ! the appropriate parameters for Henry's law +! ! (Seinfeld and Pandis, p343 eq. 6.8) +! ! PH = 4.5 ! Assumed PH for typical cloud drop +! ! Hstar = 1.054d11 * (10.**(-PH)) == 3.3d6 +! CALL COMPUTE_L2G( 3.3d6, -4.1d3, TK, CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of NH3 in liquid & ice phases +! ! (Eqs. 4, 5, 6, Jacob et al, 2000) +! C_TOT = 1d0 + L2G + I2G +! F_L = L2G / C_TOT +! F_I = I2G / C_TOT +! +! ! Compute the rate constant K. The retention factor +! ! for liquid NH3 is 0.05 for 248 K < T < 268 K, and +! ! 1.0 for T >= 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * ( F_L + F_I ) +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( ( 5d-2 * F_L ) + F_I ) +! +! ELSE +! K = K_RAIN * F_I +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out NH3 +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! !------------------------------ +! ! NH4 and NH4aq (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTNH4 .or. N == IDTNH4aq ) THEN +! +! ! NOTE: NH4aq may have a henry's law constant; +! ! Carine will investigate (cas, bmy, 12/20/04) +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! !------------------------------ +! ! NIT/AS/AHS/LET (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTNIT .or. N == IDTNITs .or. +! & N == IDTAS .or. N == IDTAHS .or. +! & N == IDTLET ) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! !------------------------------ +! ! BC HYDROPHILIC (aerosol) or +! ! OC HYDROPHILIC (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTBCPI .or. N == IDTOCPI) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! !------------------------------- +! ! BC HYDROPHOBIC (aerosol) or +! ! OC HYDROPHOBIC (aerosol) +! !------------------------------- +! ELSE IF ( N == IDTBCPO .or. N == IDTOCPO ) THEN +! +! ! No rainout +! RAINFRAC = 0.0D0 +! +! !------------------------------- +! ! DUST all size bins (aerosol) +! !------------------------------- +! ELSE IF ( N == IDTDST1 .or. N == IDTDST2 .or. +! & N == IDTDST3 .or. N == IDTDST4 ) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! !------------------------------ +! ! Accum seasalt (aerosol) or +! ! Coarse seasalt (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTSALA .or. N == IDTSALC ) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! !------------------------------ +! ! ALPH (liquid phase only) +! !------------------------------ +! ELSE IF ( N == IDTALPH ) THEN +! +! ! Compute liquid to gas ratio for ALPH, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 0.023d0, 0.d0, TK, CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of ALPH in liquid phase +! ! (Eqs. 4, 5, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. Assume that the retention factor +! ! for liquid ALPH is 0.02 for 248 K < T < 268 K, and +! ! 1.0 for T > 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * F_L +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out ALPH +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! !------------------------------ +! ! LIMO (liquid phase only) +! !------------------------------ +! ELSE IF ( N == IDTLIMO ) THEN +! +! ! Compute liquid to gas ratio for LIMO, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 0.07d0, 0.d0, TK, CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of LIMO in liquid phase +! ! (Eqs. 4, 5, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. Assume that the retention factor +! ! for liquid LIMO is 0.02 for 248 K < T < 268 K, and +! ! 1.0 for T > 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * F_L +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out LIMO +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! !------------------------------ +! ! ALCO (liquid phase only) +! !------------------------------ +! ELSE IF ( N == IDTALCO ) THEN +! +! ! Compute liquid to gas ratio for ALCO, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 54.d0, 0.d0, TK, CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of ALCO in liquid phase +! ! (Eqs. 4, 5, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. Assume that the retention factor +! ! for liquid ALCO is 0.02 for 248 K < T < 268 K, and +! ! 1.0 for T > 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * F_L +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out ALCO +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! !---------------------------------- +! ! SOG[1,2,3,4] (liquid phase only) +! !---------------------------------- +! ELSE IF ( N == IDTSOG1 .or. N == IDTSOG2 .or. +! & N == IDTSOG3 .or. N == IDTSOG4 ) THEN +! +! ! Compute liquid to gas ratio for GAS1, using +! ! the appropriate parameters for Henry's law +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( 1.0d5, -6.039d3, TK, CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of GAS1 in liquid phase +! ! (Eqs. 4, 5, Jacob et al, 2000) +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. Assume that the retention factor +! ! for liquid GAS1 is 0.02 for 248 K < T < 268 K, and +! ! 1.0 for T > 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * F_L +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! K = K_RAIN * ( 2d-2 * F_L ) +! +! ELSE +! K = 0d0 +! +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out SOG{1,2,3} +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! !-------------------------------------- +! ! SOA[1,2,3,4] (aerosol) +! ! Scavenging efficiency for SOA is 0.8 +! !-------------------------------------- +! ELSE IF ( N == IDTSOA1 .or. N == IDTSOA2 .or. +! & N == IDTSOA3 .or. N == IDTSOA4 ) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! RAINFRAC = RAINFRAC * 0.8d0 +! +! !-------------------------------------- +! ! SOAG and SOAM (aerosol) +! ! Scavenging efficiency for SOA is 0.8 +! !-------------------------------------- +! ELSE IF ( N == IDTSOAG .OR. N == IDTSOAM ) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! RAINFRAC = RAINFRAC * 0.8d0 +! +! !------------------------------ +! ! Hg2 (liquid phase only) +! !------------------------------ +! ELSE IF ( IS_Hg2( N ) ) THEN +! +! ! Compute liquid to gas ratio for HgCl2, using +! ! the appropriate parameters for Henry's law +! ! (Refs: INSERT HERE) +! CALL COMPUTE_L2G( 1.0d+14, -8.4d3, +! & T(I,J,L), CLDLIQ(I,J,L), L2G ) +! +! ! Fraction of HgCl2 in liquid phase +! ! Assume no HgCl2 in the ice phase +! C_TOT = 1d0 + L2G +! F_L = L2G / C_TOT +! +! ! Compute the rate constant K. Assume the retention factor +! ! for liquid HgCl2 is 0 for T < 268 K, and +! ! 1.0 for T > 268 K. (Eq. 1, Jacob et al, 2000) +! IF ( TK >= 268d0 ) THEN +! K = K_RAIN * F_L +! ELSE +! K = 0d0 +! ENDIF +! +! ! Compute RAINFRAC, the fraction of rained-out HgCl2 +! ! (Eq. 10, Jacob et al, 2000) +! RAINFRAC = GET_RAINFRAC( K, F, DT ) +! +! !------------------------------ +! ! HgP (treat like aerosol) +! !------------------------------ +! ELSE IF ( IS_HgP( N ) ) THEN +! RAINFRAC = GET_RAINFRAC( K_RAIN, F, DT ) +! +! !------------------------------ +! ! ERROR: insoluble tracer! +! !------------------------------ +! ELSE +! CALL ERROR_STOP( 'Invalid tracer!', 'RAINOUT (wetscav_mod.f)' ) +! +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE RAINOUT +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_RAINFRAC( K, F, DT ) RESULT( RAINFRAC ) +!! +!!****************************************************************************** +!! Function GET_RAINFRAC computes the fraction of tracer lost to rainout +!! according to Jacob et al 2000. (bmy, 11/8/02, 7/20/04) +!! +!! Arguments as Input: +!! =========================================================================== +!! (1 ) K (REAL*8) : Rainout rate constant [1/s] +!! (2 ) DT (REAL*8) : Timestep for rainout event [s] +!! (3 ) F (REAL*8) : Fraction of grid box precipitating [unitless] +!! +!! NOTES: +!! (1 ) Now move internal routines GET_RAINFRAC to the module and pass all +!! arguments explicitly. This facilitates parallelization on the +!! Altix platform (bmy, 7/20/04) +!!****************************************************************************** +!! +! ! Arguments +! REAL*8, INTENT(IN) :: K, F, DT +! +! ! Local variables +! REAL*8 :: RAINFRAC +! +! !================================================================= +! ! GET_RAINFRAC begins here! +! !================================================================= +! +! ! (Eq. 10, Jacob et al, 2000 ) +! RAINFRAC = F * ( 1 - EXP( -K * DT ) ) +! +! ! Return to RAINOUT +! END FUNCTION GET_RAINFRAC +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE WASHOUT( I, J, L, N, PP, DT, F, WASHFRAC, AER ) +!! +!!****************************************************************************** +!! Subroutine WASHOUT computes WASHFRAC, the fraction of soluble tracer +!! lost to washout events in precipitation. (djj, bmy, 2/28/00, 5/18/06) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1-3) I, J, L (INTEGER) : Grid box lon-lat-alt indices [unitless] +!! (4 ) N (INTEGER) : Tracer number [unitless] +!! (5 ) PP (REAL*8 ) : Precip rate thru at bottom +!! of grid box (I,J,L) [cm3 H2O/cm2 air/s] +!! (6 ) DT (REAL*8 ) : Timestep for rainout event [s] +!! (7 ) F (REAL*8 ) : Fraction of grid box +!! that is precipitating [unitless] +!! +!! Arguments as Output: +!! ============================================================================ +!! (8 ) WASHFRAC (REAL*8) : Fraction of tracer lost to rainout [unitless] +!! (9 ) AER (LOGICAL) : = T if the tracer is an aerosol, =F otherwise +!! +!! Reference (see above for full citations): +!! ============================================================================ +!! (1 ) Jacob et al, 2000 +!! +!! NOTES: +!! (1 ) Currently works for either full chemistry simulation (NSRCX == 3) +!! or Rn-Pb-Be chemistry simulation (NSRCX == 1). Other simulations +!! do not carry soluble tracers, so set WASHFRAC = 0. +!! (2 ) K_WASH, the rainout rate constant, and F, the areal fraction of the +!! grid box undergoing precipitiation, are computed according to +!! Giorgi & Chaimedes, as described in Jacob et al, 2000. +!! (3 ) Washout is only done for T >= 268 K, when the cloud condensate is +!! in the liquid phase. +!! (4 ) T(I+I0,J+J0,L) is now T(I,J,L). Removed IREF, JREF -- these are +!! obsolete. Updated comments. (bmy, 9/27/01) +!! (5 ) Removed obsolete commented out code from 9/01 (bmy, 10/24/01) +!! (6 ) Now reference BXHEIGHT, T from "dao_mod.f". Also remove reference +!! to "CMN_NOX". Updated comments. Now bundled into "wetscav_mod.f". +!! Now also references "tracerid_mod.f". Added internal routines +!! WASHFRAC_AEROSOL and WASHFRAC_LIQ_GAS. Also removed reference to +!! CMN since we don't need to use NSRCX here. (bmy, 11/6/02) +!! (7 ) Updated for carbon aerosol and dust tracers (rjp, bmy, 4/5/04) +!! (8 ) Updated for seasalt aerosol tracers (rjp, bec, bmy, 4/20/04) +!! (9 ) Updated for secondary organic aerosol tracers (rjp, bmy, 7/13/04) +!! (10) Now move internal routines WASHFRAC_AEROSOL and WASHFRAC_LIQ_GAS +!! to the module and pass all arguments explicitly. This facilitates +!! parallelization on the Altix platform (bmy, 7/20/04) +!! (11) Now handle washout of mercury aerosol tracers (eck, bmy, 12/9/04) +!! (13) Updated for AS, AHS, LET, NH4aq, SO4aq. Also condensed the IF +!! statement by grouping blocks together (cas, bmy, 12/20/04) +!! (14) Updated for SO4s, NITs (bec, bmy, 4/25/05) +!! (15) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (16) Bug fix: Deplete H2O2s the same as SO2s. Also change Henry's law +!! constant for Hg2 to 1.0d+14. Now use functions IS_Hg2 and IS_HgP to +!! determine if a tracer is a tagged Hg0 or HgP tracer. +!! (dkh, rjp, eck, cdh, bmy, 1/6/06) +!! (17) Updated for SOG4 and SOA4 (bmy, 5/18/06) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE DAO_MOD, ONLY : BXHEIGHT, T +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE TRACERID_MOD, ONLY : IDTPB, IDTBE7, IDTHNO3, IDTH2O2 +! USE TRACERID_MOD, ONLY : IDTCH2O, IDTMP, IDTSO2, IDTSO4 +! USE TRACERID_MOD, ONLY : IDTSO4s, IDTSO4aq, IDTMSA, IDTNH3 +! USE TRACERID_MOD, ONLY : IDTNH4, IDTNH4aq, IDTNIT, IDTNITs +! USE TRACERID_MOD, ONLY : IDTAS, IDTAHS, IDTLET, IDTBCPI +! USE TRACERID_MOD, ONLY : IDTOCPI, IDTBCPO, IDTOCPO, IDTDST1 +! USE TRACERID_MOD, ONLY : IDTDST2, IDTDST3, IDTDST4, IDTSALA +! USE TRACERID_MOD, ONLY : IDTSALC, IDTALPH, IDTLIMO, IDTALCO +! USE TRACERID_MOD, ONLY : IDTSOG1, IDTSOG2, IDTSOG3, IDTSOG4 +! USE TRACERID_MOD, ONLY : IDTSOA1, IDTSOA2, IDTSOA3, IDTSOA4 +! USE TRACERID_MOD, ONLY : IS_Hg2, IS_HgP +! USE TRACERID_MOD, ONLY : IDTGLYX, IDTMGLY, IDTGLYC +! USE TRACERID_MOD, ONLY : IDTSOAG, IDTSOAM +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Arguments +! INTEGER, INTENT(IN) :: I, J, L, N +! REAL*8, INTENT(IN) :: PP, DT, F +! REAL*8, INTENT(OUT) :: WASHFRAC +! LOGICAL, INTENT(OUT) :: AER +! +! ! Local variables +! REAL*8 :: L2G, DZ, TK, SO2LOSS +! +! ! First order washout rate constant for HNO3, aerosols = 1 cm^-1 +! REAL*8, PARAMETER :: K_WASH = 1d0 +! +! !================================================================= +! ! WASHOUT begins here! +! ! +! ! Call either WASHFRAC_AEROSOL or WASHFRAC_LIQ_GAS to compute the +! ! fraction of tracer lost to washout according to Jacob et al 2000 +! !================================================================= +! +! ! TK is Kelvin temperature +! TK = T(I,J,L) +! +! ! DZ is the height of the grid box in cm +! DZ = BXHEIGHT(I,J,L) * 1d2 +! +! !------------------------------ +! ! 210Pb or 7Be (aerosol) +! !------------------------------ +! IF ( N == IDTPb .or. N == IDTBe7 ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! HNO3 (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTHNO3 ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! H2O2 (liquid & gas phases) +! !------------------------------ +! ELSE IF ( N == IDTH2O2 ) THEN +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 8.3d4, -7.4d3, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !------------------------------ +! ! CH2O (liquid & gas phases) +! !------------------------------ +! ELSE IF ( N == IDTCH2O ) THEN +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 3.0d3, -7.2d3, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !------------------------------ +! ! GLYX (liquid & gas phases) +! !------------------------------ +! ELSE IF ( N == IDTGLYX ) THEN +! +! ! Compute liquid to gas ratio for GLYX, using +! ! (1) Zhou and Mopper (1990): Kstar298 = 3.6e5 M/atm +! ! (2) Schweitzer et al. (1998) showed that the temperature dependence for CH2O works well for glyoxal, +! ! so we use the same H298_R as CH2O +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 3.6d5, -7.2d3, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !------------------------------ +! ! MGLY (liquid & gas phases) +! !------------------------------ +! ELSE IF ( N == IDTMGLY ) THEN +! ! Compute liquid to gas ratio for MGLY, using +! ! the appropriate parameters for Henry's law +! ! from Betterton and Hoffman 1988): Kstar298 = 3.71d3 M/atm; H298_R = -7.5d3 K +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 3.7d3, -7.5d3, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !------------------------------ +! ! GLYC (liquid & gas phases) +! !------------------------------ +! ELSE IF ( N == IDTGLYC ) THEN +! ! Compute liquid to gas ratio for GLYC, using +! ! the appropriate parameters for Henry's law +! ! from Betterton and Hoffman 1988): Kstar298 = 4.6d4 M/atm; H298_R = -4.6d3 K +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 4.1d4, -4.6d3, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! +! !------------------------------ +! ! MP (liquid & gas phases) +! !------------------------------ +! ELSE IF ( N == IDTMP ) THEN +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 3.1d2, -5.2d3, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !------------------------------ +! ! SO2 (aerosol treatment) +! !------------------------------ +! ELSE IF ( N == IDTSO2 ) THEN +! +! !============================================================== +! ! NOTE: Even though SO2 is not an aerosol we treat it as SO4 in +! ! wet scavenging. When evaporation occurs, it returns to SO4. +! !============================================================== +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! ! For adjoint recalculation, need to save the initial value of +! ! WASHFRAC here. (dkh, 10/26/05) +! IF ( LADJ ) THEN +! WASHFRAC_0(L) = WASHFRAC +! ENDIF +! +! +! !============================================================== +! ! Use the wet-scavenging following [Chin et al, 1996] such +! ! that a soluble fraction of SO2 is limited by the availability +! ! of H2O2 in the precipitating grid box. Then scavenge the +! ! soluble SO2 at the same rate as sulfate. +! !============================================================== +! IF ( TK >= 268d0 .AND. SO2s(I,J,L) > EPSILON ) THEN +! +! ! Adjust WASHFRAC +! SO2LOSS = MIN( SO2s(I,J,L), H2O2s(I,J,L) ) +! WASHFRAC = SO2LOSS * WASHFRAC / SO2s(I,J,L) +! WASHFRAC = MAX( WASHFRAC, 0d0 ) +! +! ! Deplete H2O2s the same as SO2s (dkh, rjp, bmy, 11/17/05) +! H2O2s(I,J,L) = H2O2s(I,J,L) - ( SO2s(I,J,L) * WASHFRAC ) +! H2O2s(I,J,L) = MAX( H2O2s(I,J,L), EPSILON ) +! +! ELSE +! WASHFRAC = 0d0 +! +! ENDIF +! +! ! Update saved SO2 concentration +! SO2s(I,J,L) = SO2s(I,J,L) * ( 1d0 - WASHFRAC ) +! SO2s(I,J,L) = MAX( SO2s(I,J,L), EPSILON ) +! +! !------------------------------ +! ! SO4 and SO4aq (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTSO4 .or. N == IDTSO4s .or. N == IDTSO4aq ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! MSA (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTMSA ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! NH3 (liquid & gas phases) +! !------------------------------ +! ELSE IF ( N == IDTNH3 ) THEN +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 3.3d6, -4.1d3, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !------------------------------ +! ! NH4 and NH4aq (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTNH4 .or. N == IDTNH4aq ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! NIT/AS/AHS/LET (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTNIT .or. N == IDTNITs .or. +! & N == IDTAS .or. N == IDTAHS .or. +! & N == IDTLET ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! BC HYDROPHILIC (aerosol) or +! ! OC HYDROPHILIC (aerosol) or +! ! BC HYDROPHOBIC (aerosol) or +! ! OC HYDROPHOBIC (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTBCPI .or. N == IDTOCPI .or. +! & N == IDTBCPO .or. N == IDTOCPO ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! DUST all size bins (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTDST1 .or. N == IDTDST2 .or. +! & N == IDTDST3 .or. N == IDTDST4 ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! Accum seasalt (aerosol) or +! ! Coarse seasalt (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTSALA .or. N == IDTSALC ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! ALPH (liquid & gas phases) +! !------------------------------ +! ELSE IF ( N == IDTALPH ) THEN +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 0.023d0, 0.d0, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !------------------------------ +! ! LIMO (liquid & gas phases) +! !------------------------------ +! ELSE IF ( N == IDTLIMO ) THEN +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 0.07d0, 0.d0, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !------------------------------ +! ! ALCO (liquid & gas phases) +! !------------------------------ +! ELSE IF ( N == IDTALCO ) THEN +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 54.d0, 0.d0, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !--------------------------------- +! ! SOG[1,2,3,4] (liq & gas phases) +! !--------------------------------- +! ELSE IF ( N == IDTSOG1 .or. N == IDTSOG2 .or. +! & N == IDTSOG3 .or. N == IDTSOG4 ) THEN +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 1.0d5, -6.039d3, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !------------------------------ +! ! SOA[1,2,3,4] (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTSOA1 .or. N == IDTSOA2 .or. +! & N == IDTSOA3 .or. N == IDTSOA4 ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! SOAG and SOAM (aerosol) +! !------------------------------ +! ELSE IF ( N == IDTSOAG .or. N == IDTSOAM ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! Hg2 (liquid & gas phases) +! !------------------------------ +! ELSE IF ( IS_Hg2( N ) ) THEN +! AER = .FALSE. +! WASHFRAC = WASHFRAC_LIQ_GAS( 1.0d+14, -8.4d3, PP, DT, +! & F, DZ, TK, K_WASH ) +! +! !------------------------------ +! ! HgP (treat like aerosol) +! !------------------------------ +! ELSE IF ( IS_HgP( N ) ) THEN +! AER = .TRUE. +! WASHFRAC = WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! +! !------------------------------ +! ! ERROR: Insoluble tracer +! !------------------------------ +! ELSE +! CALL ERROR_STOP( 'Invalid tracer!', 'WASHOUT (wetscav_mod.f)' ) +! +! ENDIF +! +! ! Return to calling program +! END SUBROUTINE WASHOUT +! +!!------------------------------------------------------------------------------ +! +! FUNCTION WASHFRAC_AEROSOL( DT, F, K_WASH, PP, TK ) +! & RESULT( WASHFRAC ) +!! +!!****************************************************************************** +!! Function WASHFRAC_AEROSOL returns the fraction of soluble aerosol tracer +!! lost to washout. (bmy, 11/8/02, 7/20/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) TK (REAL*8 ) : Temperature in grid box [K] +!! (2 ) F (REAL*8 ) : Fraction of grid box +!! that is precipitating [unitless] +!! (3 ) K_WASH (REAL*8 ) : 1st order washout rate constant [1/cm] +!! (3 ) PP (REAL*8 ) : Precip rate thru at bottom +!! of grid box (I,J,L) [cm3 H2O/cm2 air/s] +!! +!! NOTES: +!! (1 ) WASHFRAC_AEROSOL used to be an internal function to subroutine WASHOUT. +!! This caused NaN's in the parallel loop on Altix, so we moved it to +!! the module and now pass Iall arguments explicitly (bmy, 7/20/04) +!!****************************************************************************** +!! +! ! Arguments +! REAL*8, INTENT(IN) :: DT, F, K_WASH, PP, TK +! +! ! Function value +! REAL*8 :: WASHFRAC +! +! !================================================================= +! ! WASHFRAC_AEROSOL begins here! +! !================================================================= +! +! ! Washout only happens at or above 268 K +! IF ( TK >= 268d0 ) THEN +! WASHFRAC = F * ( 1d0 - EXP( -K_WASH * ( PP / F ) * DT ) ) +! ELSE +! WASHFRAC = 0d0 +! ENDIF +! +! ! Return to calling program +! END FUNCTION WASHFRAC_AEROSOL +! +!!------------------------------------------------------------------------------ +! +! FUNCTION WASHFRAC_LIQ_GAS( Kstar298, H298_R, PP, DT, +! & F, DZ, TK, K_WASH ) +! & RESULT( WASHFRAC ) +!! +!!****************************************************************************** +!! Function WASHFRAC_LIQ_GAS returns the fraction of soluble liquid/gas phase +!! tracer lost to washout. (bmy, 11/8/02, 7/20/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) Kstar298 (REAL*8 ) : Eff. Henry's law constant @ 298 K [moles/atm] +!! (2 ) H298_R (REAL*8 ) : Henry's law coefficient [K] +!! (3 ) PP (REAL*8 ) : Precip rate thru at bottom +!! of grid box (I,J,L) [cm3 H2O/cm2 air/s] +!! (4 ) DT (REAL*8 ) : Dynamic timestep [s] +!! (5 ) F (REAL*8 ) : Fraction of grid box +!! that is precipitating [unitless] +!! (6 ) DZ (REAL*8 ) : Height of grid box [cm] +!! (7 ) TK (REAL*8 ) : Temperature in grid box [K] +!! (8 ) K_WASH (REAL*8 ) : 1st order washout rate constant [1/cm] +!! +!! NOTES: +!! (1 ) WASHFRAC_LIQ_GAS used to be an internal function to subroutine WASHOUT. +!! This caused NaN's in the parallel loop on Altix, so we moved it to +!! the module and now pass all arguments explicitly (bmy, 7/20/04) +!!****************************************************************************** +!! +! ! Arguments +! REAL*8, INTENT(IN) :: Kstar298, H298_R, PP, DT, F, DZ, TK, K_WASH +! +! ! Local variables +! REAL*8 :: L2G, LP, WASHFRAC, WASHFRAC_F_14 +! +! !================================================================= +! ! WASHFRAC_LIQ_GAS begins here! +! !================================================================= +! +! ! Suppress washout below 268 K +! IF ( TK >= 268d0 ) THEN +! +! ! Rainwater content in the grid box (Eq. 17, Jacob et al, 2000) +! LP = ( PP * DT ) / ( F * DZ ) +! +! ! Compute liquid to gas ratio for H2O2, using the appropriate +! ! parameters for Henry's law -- also use rainwater content Lp +! ! (Eqs. 7, 8, and Table 1, Jacob et al, 2000) +! CALL COMPUTE_L2G( Kstar298, H298_R, TK, LP, L2G ) +! +! ! Washout fraction from Henry's law (Eq. 16, Jacob et al, 2000) +! WASHFRAC = L2G / ( 1d0 + L2G ) +! +! ! Washout fraction / F from Eq. 14, Jacob et al, 2000 +! WASHFRAC_F_14 = 1d0 - EXP( -K_WASH * ( PP / F ) * DT ) +! +! ! Do not let the Henry's law washout fraction exceed +! ! ( washout fraction / F ) from Eq. 14 -- this is a cap +! IF ( WASHFRAC > WASHFRAC_F_14 ) WASHFRAC = WASHFRAC_F_14 +! +! ELSE +! WASHFRAC = 0d0 +! +! ENDIF +! +! ! Return to calling program +! END FUNCTION WASHFRAC_LIQ_GAS +! +!!------------------------------------------------------------------------------ + + SUBROUTINE WETDEP_ADJ( LS ) +! +!****************************************************************************** +! Subroutine WETDEP_ADJ is the same as WETDEP except +! - it acts on the adjoint tracers +! - negative sensitivity values are allowed (i.e., don't call SAFETY) +! - skip SO2, which is treated separately. +! (dkh, 10/24/05, 09/28/09) +! +! Based on WETDEP, which computes the downward mass flux of tracer due to washout +! and rainout of aerosols and soluble tracers in a column. The timestep is +! the dynamic timestep. (hyl, bey, bmy, djj, 4/2/99, 5/24/06) +! +! Notes +! (1 ) All changes have ADJ or adj_group in them. +! (2 ) Completely revised to properly treat adjoint of DSTT (dkh, 03/18/12) +! (3 ) Now support deposition cost function (fp, dkh, 03/04/13) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, NFD, LFD + USE DAO_MOD, ONLY : BXHEIGHT + USE DIAG_MOD, ONLY : AD16, AD17, AD18 + USE DIAG_MOD, ONLY : CT16, CT17, CT18, AD39 + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP, IT_IS_NAN + USE LOGICAL_MOD, ONLY : LDYNOCEAN + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE OCEAN_MERCURY_MOD, ONLY : ADD_Hg2_WD + USE TIME_MOD, ONLY : GET_TS_DYN + USE TRACER_MOD, ONLY : ITS_A_MERCURY_SIM + USE TRACERID_MOD, ONLY : IDTSO2, IDTSO4, IS_Hg2 + USE WETSCAV_MOD, ONLY : QQ + USE WETSCAV_MOD, ONLY : IDWETD + USE WETSCAV_MOD, ONLY : LS_K_RAIN + USE WETSCAV_MOD, ONLY : LS_F_PRIME + USE WETSCAV_MOD, ONLY : PDOWN + USE WETSCAV_MOD, ONLY : CONV_F_PRIME + USE WETSCAV_MOD, ONLY : RAINOUT + USE WETSCAV_MOD, ONLY : WASHOUT + USE WETSCAV_MOD, ONLY : NSOL + ! dkh debug + USE WETSCAV_MOD, ONLY : H2O2s + USE WETSCAV_MOD, ONLY : SO2s + USE TRACER_MOD, ONLY : STT + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic arrays and switches + + ! Arguments + LOGICAL, INTENT(IN) :: LS + + ! Local Variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: IS_Hg + LOGICAL :: AER + + INTEGER :: I, IDX, J, L, N, NN + + REAL*8 :: Q, QDOWN, DT, DT_OVER_TAU + REAL*8 :: K, K_MIN, K_RAIN, RAINFRAC + REAL*8 :: F, FTOP, F_PRIME, WASHFRAC + REAL*8 :: LOST, GAINED, MASS_WASH, MASS_NOWASH + REAL*8 :: ALPHA, ALPHA2, WETLOSS, TMP + REAL*8 :: WETLOSS_ADJ + + ! DSTT is the accumulator array of rained-out + ! soluble tracer for a given (I,J) column + REAL*8 :: DSTT_ADJ(NSOL,LLPAR,IIPAR,JJPAR) + + REAL*8 :: F_SAVE(IIPAR,JJPAR,LLPAR) + + !================================================================= + ! WETDEP_ADJ begins here! + ! + ! (1) I n i t i a l i z e V a r i a b l e s + !================================================================= + + ! Is this a mercury simulation with dynamic online ocean? + IS_Hg = ( ITS_A_MERCURY_SIM() .and. LDYNOCEAN ) + + ! Dynamic timestep [s] + DT = GET_TS_DYN() * 60d0 + + ! Select index for diagnostic arrays -- will archive either + ! large-scale or convective rainout/washout fractions + IF ( LS ) THEN + IDX = 1 + ELSE + IDX = 2 + ENDIF + + !================================================================= + ! (2) L o o p O v e r (I, J) S u r f a c e B o x e s + ! + ! just recalculate the values of F and save in F_SAVE + !================================================================= + + ! initialize + F_SAVE(:,:,:) = 0d0 + +#if !defined( SGI_MIPS ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, FTOP ) +!$OMP+PRIVATE( F, F_PRIME, K_RAIN ) +!$OMP+PRIVATE( L, Q ) +!$OMP+SCHEDULE( DYNAMIC ) +#endif + DO J = 1, JJPAR + DO I = 1, IIPAR + + !============================================================== + ! (3) R a i n o u t F r o m T o p L a y e r (L = LLPAR) + !============================================================== + ! Zero variables for this level + F = 0d0 + F_PRIME = 0d0 + K_RAIN = 0d0 + Q = 0d0 + + ! Start at the top of the atmosphere + L = LLPAR + + ! If precip forms at (I,J,L), assume it all rains out + IF ( QQ(L,I,J) > 0d0 ) THEN + + ! Q is the new precip that is forming within grid box (I,J,L) + Q = QQ(L,I,J) + + ! Compute K_RAIN and F' for either large-scale or convective + ! precipitation (cf. Eqs. 11-13, Jacob et al, 2000) + IF ( LS ) THEN + K_RAIN = LS_K_RAIN( Q ) + F_PRIME = LS_F_PRIME( Q, K_RAIN ) + ELSE + K_RAIN = 1.5d-3 + F_PRIME = CONV_F_PRIME( Q, K_RAIN, DT ) + ENDIF + + ! Set F = F', since there is no FTOP at L = LLPAR + F = F_PRIME + + F_SAVE(I,J,L) = F + + FTOP = F + + ENDIF + + !============================================================== + ! (4) R a i n o u t i n t h e M i d d l e L e v e l s + !============================================================== + DO L = LLPAR-1, 2, -1 + + ! Zero variables for each level + F = 0d0 + F_PRIME = 0d0 + K_RAIN = 0d0 + Q = 0d0 + + ! Rainout criteria + IF ( PDOWN(L,I,J) > 0d0 .and. QQ(L,I,J) > 0d0 ) THEN + + ! Q is the new precip that is forming within grid box (I,J,L) + Q = QQ(L,I,J) + + ! Compute K_RAIN and F' for either large-scale or convective + ! precipitation (cf. Eqs. 11-13, Jacob et al, 2000) + IF ( LS ) THEN + K_RAIN = LS_K_RAIN( Q ) + F_PRIME = LS_F_PRIME( Q, K_RAIN ) + ELSE + K_RAIN = 1.5d-3 + F_PRIME = CONV_F_PRIME( Q, K_RAIN, DT ) + ENDIF + + ! F is the effective area of precip seen by grid box (I,J,L) + F = MAX( F_PRIME, FTOP ) + + F_SAVE(I,J,L) = F + + ! Save FTOP for next level + FTOP = F + + !============================================================== + ! (5) W a s h o u t i n t h e m i d d l e l e v e l s + !============================================================== + ELSE IF ( PDOWN(L,I,J) > 0d0 .and. QQ(L,I,J) <= 0d0 ) THEN + + ! Since no precipitation is forming within grid box (I,J,L), + ! F' = 0, and F = MAX( F', FTOP ) reduces to F = FTOP. + F = FTOP + + F_SAVE(I,J,L) = F + + ! Save FTOP for next level + FTOP = F + + !=========================================================== + ! (6) N o D o w n w a r d P r e c i p i t a t i o n + !=========================================================== + ELSE IF ( ABS( PDOWN(L,I,J) ) < 1d-30 ) THEN + + ! No precipitation at grid box (I,J,L), thus F = 0 + F = 0d0 + + F_SAVE(I,J,L) = F + + ! Save FTOP for next level + FTOP = F + ENDIF + ENDDO + + !============================================================== + ! (7) W a s h o u t i n L e v e l 1 + !============================================================== + + ! We are at the surface, set L = 1 + L = 1 + + ! Washout at level 1 criteria + IF ( PDOWN(L+1,I,J) > 0d0 ) THEN + + ! Since no precipitation is forming within grid box (I,J,L), + ! F' = 0, and F = MAX( F', FTOP ) reduces to F = FTOP. + F = FTOP + + F_SAVE(I,J,L) = F + + ENDIF + ENDDO + ENDDO +#if !defined( SGI_MIPS ) +!$OMP END PARALLEL DO +#endif + + !================================================================= + ! (2) L o o p O v e r (I, J) S u r f a c e B o x e s + ! + ! Process rainout / washout by columns. + !================================================================= + +#if !defined( SGI_MIPS ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, FTOP, ALPHA ) +!$OMP+PRIVATE( ALPHA2, F, F_PRIME, GAINED, K_RAIN ) +!$OMP+PRIVATE( LOST, MASS_NOWASH, MASS_WASH, RAINFRAC, WASHFRAC ) +!$OMP+PRIVATE( WETLOSS, L, Q, NN, N ) +!$OMP+PRIVATE( QDOWN, AER, TMP ) +!$OMP+PRIVATE( WETLOSS_ADJ ) +!$OMP+SCHEDULE( DYNAMIC ) +#endif + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Zero accumulator array + DO L = 1, LLPAR + DO NN = 1, NSOL + DSTT_ADJ(NN,L,I,J) = 0d0 + ENDDO + ENDDO + + + ! wetdep adj (fp, dkh, 03/04/13) + IF ( LADJ_WDEP_LS ) THEN + BOX_DEP (I,J,:,:) = 0d0 + LOWER_DEP(I,J,:,:) = 1d0 + ENDIF + + !============================================================== + ! (7) W a s h o u t i n L e v e l 1 + !============================================================== + + ! Zero variables for this level + F = 0d0 + Q = 0d0 + QDOWN = 0d0 + WASHFRAC = 0d0 + WETLOSS = 0d0 + + L = 1 + + IF ( PDOWN(L+1,I,J) > 0d0 ) THEN + + QDOWN = PDOWN(L+1,I,J) + + F = F_SAVE(I,J,L) + + IF ( F > 0d0 ) THEN + + DO NN = 1, NSOL + N = IDWETD(NN) + + CALL WASHOUT( I, J, L, N, + & QDOWN, DT, F, WASHFRAC, AER ) + + IF ( AER ) THEN + WETLOSS = STT_ADJ(I,J,L,N) * WASHFRAC + IF ( LADJ_WDEP_LS ) THEN + BOX_DEP(I,J,L,N) = WASHFRAC / DT + ENDIF + ELSE + WETLOSS = STT_ADJ(I,J,L,N) * WASHFRAC * F + IF ( LADJ_WDEP_LS ) THEN + BOX_DEP(I,J,L,N)=WASHFRAC * F / DT + ENDIF + ENDIF + + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) - WETLOSS + + ENDDO + ENDIF + ENDIF + + !============================================================== + ! (4) R a i n o u t i n t h e M i d d l e L e v e l s + !============================================================== + DO L = 2, LLPAR-1 + + ! Zero variables for each level + ALPHA = 0d0 + ALPHA2 = 0d0 + F = 0d0 + F_PRIME = 0d0 + GAINED = 0d0 + K_RAIN = 0d0 + LOST = 0d0 + MASS_NOWASH = 0d0 + MASS_WASH = 0d0 + Q = 0d0 + QDOWN = 0d0 + RAINFRAC = 0d0 + WASHFRAC = 0d0 + WETLOSS = 0d0 + + WETLOSS_ADJ = 0d0 + + ! Rainout criteria + IF ( PDOWN(L,I,J) > 0d0 .and. QQ(L,I,J) > 0d0 ) THEN + + Q = QQ(L,I,J) + + IF ( LS ) THEN + K_RAIN = LS_K_RAIN( Q ) + F_PRIME = LS_F_PRIME( Q, K_RAIN ) + ELSE + K_RAIN = 1.5d-3 + F_PRIME = CONV_F_PRIME( Q, K_RAIN, DT ) + ENDIF + + F = F_SAVE(I,J,L) + + IF ( F > 0d0 ) THEN + + DO NN = 1, NSOL + N = IDWETD(NN) + + CALL RAINOUT( I, J, L, N, K_RAIN, DT, F, RAINFRAC ) + + ! fwd: + !DSTT(NN,L,I,J) = DSTT(NN,L+1,I,J) + WETLOSS + ! adj: + DSTT_ADJ(NN,L+1,I,J) = DSTT_ADJ(NN,L+1,I,J) + & + DSTT_ADJ(NN,L,I,J) + WETLOSS_ADJ = WETLOSS_ADJ + & + DSTT_ADJ(NN,L,I,J) + DSTT_ADJ(NN,L,I,J) = 0d0 + + ! fwd: + !STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS + ! adj: + WETLOSS_ADJ = WETLOSS_ADJ - STT_ADJ(I,J,L,N) + + ! fwd: + !WETLOSS = STT(I,J,L,N) * RAINFRAC + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + & + RAINFRAC * WETLOSS_ADJ + WETLOSS_ADJ = 0d0 + + IF ( LADJ_WDEP_LS ) THEN + BOX_DEP(I,J,L,N) = RAINFRAC / DT + LOWER_DEP(I,J,L,N) = 1D0 + ENDIF + + ENDDO + ENDIF + + !============================================================== + ! (5) W a s h o u t i n t h e m i d d l e l e v e l s + !============================================================== + ELSE IF ( PDOWN(L,I,J) > 0d0 .and. QQ(L,I,J) <= 0d0 ) THEN + + QDOWN = PDOWN(L,I,J) + Q = QQ(L,I,J) + + F = F_SAVE(I,J,L) + + IF ( F > 0d0 ) THEN + + DO NN = 1, NSOL + N = IDWETD(NN) + + CALL WASHOUT( I, J, L, N, + & QDOWN, DT, F, WASHFRAC, AER ) + + + IF ( AER ) THEN + + ! fwd: + !DSTT(NN,L,I,J) = DSTT(NN,L+1,I,J) + WETLOSS + ! adj: + DSTT_ADJ(NN,L+1,I,J) = DSTT_ADJ(NN,L+1,I,J) + & + DSTT_ADJ(NN,L,I,J) + WETLOSS_ADJ = WETLOSS_ADJ + & + DSTT_ADJ(NN,L,I,J) + DSTT_ADJ(NN,L,I,J) = 0d0 + +! Treat SO2 separately +! IF ( N == IDTSO2 ) THEN +! STT(I,J,L,IDTSO4) = STT(I,J,L,IDTSO4) +! & + GAINED * 96D0 / 64D0 +! +! STT(I,J,L,N) = STT(I,J,L,N) * +! & ( 1d0 - WASHFRAC ) +! ELSE + + ! fwd: + !STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS + ! adj: + WETLOSS_ADJ = WETLOSS_ADJ - STT_ADJ(I,J,L,N) + +! ENDIF + + ! recalculate ALPHA + ALPHA = ( ABS( Q ) * BXHEIGHT(I,J,L) * 100d0 ) / + & PDOWN(L+1,I,J) + + ! Restrict ALPHA to be less than 1 + ! (>1 is unphysical) (hma, 24-Dec-2010) + IF ( ALPHA > 1d0 ) ALPHA = 1d0 + + ALPHA2 = 0.5d0 * ALPHA + + ! fwd: + !GAINED = DSTT(NN,L+1,I,J) * ALPHA2 + !WETLOSS = STT(I,J,L,N) * WASHFRAC - GAINED + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + & + WASHFRAC + & * WETLOSS_ADJ + DSTT_ADJ(NN,L+1,I,J) = DSTT_ADJ(NN,L+1,I,J) +!---------------------------------------------------------------------- +! BUG FIX: +! old: +! & - ALPHA +! new: + & - ALPHA2 +!---------------------------------------------------------------------- + & * WETLOSS_ADJ + WETLOSS_ADJ = 0d0 + + IF ( LADJ_WDEP_LS ) THEN + BOX_DEP(I,J,L,N) = WASHFRAC / DT + LOWER_DEP(I,J,L,N)= 1D0 - ALPHA2 + ENDIF + + ELSE + + + ! fwd: + !DSTT(NN,L,I,J) = DSTT(NN,L+1,I,J) + WETLOSS + ! adj: + DSTT_ADJ(NN,L+1,I,J) = DSTT_ADJ(NN,L+1,I,J) + & + DSTT_ADJ(NN,L,I,J) + WETLOSS_ADJ = WETLOSS_ADJ + & + DSTT_ADJ(NN,L,I,J) + DSTT_ADJ(NN,L,I,J) = 0d0 + + ! fwd: + !STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS + WETLOSS_ADJ = WETLOSS_ADJ - STT_ADJ(I,J,L,N) + + ! fwd: + !MASS_WASH = ( F*STT(I,J,L,N) ) +DSTT(NN,L+1,I,J) + !WETLOSS = MASS_WASH * WASHFRAC -DSTT(NN,L+1,I,J) + ! adj: + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + & + F * WASHFRAC + & * WETLOSS_ADJ + DSTT_ADJ(NN,L+1,I,J) = DSTT_ADJ(NN,L+1,I,J) + & + ( WASHFRAC - 1d0 ) + & * WETLOSS_ADJ + WETLOSS_ADJ = 0d0 + + IF ( LADJ_WDEP_LS ) THEN + BOX_DEP(I,J,L,N) = F * WASHFRAC / DT + LOWER_DEP(I,J,L,N) = WASHFRAC + ENDIF + + ENDIF + + ENDDO + ENDIF + + FTOP = F + + !=========================================================== + ! (6) N o D o w n w a r d P r e c i p i t a t i o n + !=========================================================== + ELSE IF ( ABS( PDOWN(L,I,J) ) < 1d-30 ) THEN + + F = 0d0 + + DO NN = 1, NSOL + N = IDWETD(NN) + + ! fwd: + !DSTT(NN,L,I,J) = 0d0 + ! adj: + DSTT_ADJ(NN,L,I,J) = 0d0 + + + IF ( LADJ_WDEP_LS ) THEN + LOWER_DEP(I,J,L,N) = 0D0 + ENDIF + + + IF ( N == IDTSO2 ) THEN +! WETLOSS = -DSTT(NN,L+1,I,J) +! STT(I,J,L,IDTSO4) = STT(I,J,L,IDTSO4) +! & - ( WETLOSS * 96d0 / 64d0 ) + ELSE + ! fwd: + !WETLOSS = -DSTT(NN,L+1,I,J) + !STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS + + ! adj: + DSTT_ADJ(NN,L+1,I,J) = STT_ADJ(I,J,L,N) + + ENDIF + + + ENDDO + + ENDIF + ENDDO + + !============================================================== + ! (3) R a i n o u t F r o m T o p L a y e r (L = LLPAR) + !============================================================== + + ! Zero variables for this level + F = 0d0 + F_PRIME = 0d0 + K_RAIN = 0d0 + Q = 0d0 + RAINFRAC = 0d0 + + WETLOSS_ADJ = 0d0 + + ! Start at the top of the atmosphere + L = LLPAR + + IF ( QQ(L,I,J) > 0d0 ) THEN + + Q = QQ(L,I,J) + + IF ( LS ) THEN + K_RAIN = LS_K_RAIN( Q ) + F_PRIME = LS_F_PRIME( Q, K_RAIN ) + ELSE + K_RAIN = 1.5d-3 + F_PRIME = CONV_F_PRIME( Q, K_RAIN, DT ) + ENDIF + + F = F_PRIME + + IF ( F > 0d0 ) THEN + + DO NN = 1, NSOL + N = IDWETD(NN) + + CALL RAINOUT( I, J, L, N, K_RAIN, DT, F, RAINFRAC ) + + IF ( LADJ_WDEP_LS ) THEN + BOX_DEP(I,J,L,N) = RAINFRAC / DT + ENDIF + + WETLOSS_ADJ = 0d0 + + ! fwd: + !DSTT(NN,L,I,J) = WETLOSS + ! adj: + WETLOSS_ADJ = WETLOSS_ADJ + DSTT_ADJ(NN,L,I,J) + DSTT_ADJ(NN,L,I,J) = 0d0 + + ! fwd: + !STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS + ! adj: + WETLOSS_ADJ = WETLOSS_ADJ - STT_ADJ(I,J,L,N) + + ! fwd: + !WETLOSS = STT(I,J,L,N) * RAINFRAC + ! adj: + STT_ADJ(I,J,L,N) = STT_ADJ(I,J,L,N) + + & + WETLOSS_ADJ * RAINFRAC + WETLOSS_ADJ = 0d0 + + ENDDO + ENDIF + + ENDIF + + ENDDO + ENDDO +#if !defined( SGI_MIPS ) +!$OMP END PARALLEL DO +#endif + + ! Return to calling program + END SUBROUTINE WETDEP_ADJ + +!----------------------------------------------------------------------------- + SUBROUTINE ADJ_SO2_WETDEP( LS ) +! +!****************************************************************************** +! Subroutine ADJ_SO2_WETDEP is the wetdep adjoint for just SO2. This +! is treated separately owing to it being nonlinear for this species. +! (dkh, 10/23/05) +! +! Notes: +! (1 ) Updated to GCv8 adjoint (dkh, 09/28/09) +! (2 ) Remove obsolete STT_MCHK (dkh, 09/30/09) +!****************************************************************************** +! + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, NFD + USE DAO_MOD, ONLY : BXHEIGHT + USE DAO_MOD, ONLY : T +! USE DIAG_MOD, ONLY : AD16, AD17, AD18, CT16, CT17, CT18, AD39 + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE TIME_MOD, ONLY : GET_TS_DYN + USE TRACERID_MOD, ONLY : IDTSO2, IDTSO4 + USE TRACER_MOD, ONLY : STT + !USE WETSCAV_MOD, ONLY : WASHFRAC_0, RAINFRAC_0 + USE WETSCAV_MOD, ONLY : SO2s + USE WETSCAV_MOD, ONLY : H2O2s + USE WETSCAV_MOD, ONLY : QQ + USE WETSCAV_MOD, ONLY : LS_K_RAIN + USE WETSCAV_MOD, ONLY : LS_F_PRIME + USE WETSCAV_MOD, ONLY : CONV_F_PRIME + USE WETSCAV_MOD, ONLY : PDOWN + USE WETSCAV_MOD, ONLY : RAINOUT + USE WETSCAV_MOD, ONLY : WASHOUT + USE WETSCAV_MOD, ONLY : SAFETY + USE WETSCAV_MOD, ONLY : NSOL + USE WETSCAV_MOD, ONLY : NSOLMAX + USE WETSCAV_MOD, ONLY : WASHFRAC_FINE_AEROSOL + USE WETSCAV_MOD, ONLY : GET_RAINFRAC + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + LOGICAL, INTENT(IN) :: LS + !REAL*8 :: IN(10,3) + !REAL*8 :: OUT(10,3) + + ! Dummy variables used to make adjoint with TAMC + !REAL*8 :: H2O2s(10,10,10) + !REAL*8 :: SO2s(10,10,10) + !REAL*8 :: QQ(10,10,10) + !REAL*8 :: PDOWN(10,10,10) + !REAL*8 :: STT(10,10,10,10) + !INTEGER :: IDTSO2, LLPAR, IDTSO4 + !REAL*8 :: DSTT(10,10) + + ! Local Variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: AER + + INTEGER :: I, IDX, J, L, N, NN + + REAL*8 :: Q, QDOWN, DT, DT_OVER_TAU + REAL*8 :: K, K_MIN, K_RAIN, RAINFRAC + REAL*8 :: F, FTOP, F_PRIME, WASHFRAC + REAL*8 :: LOST, GAINED, MASS_WASH, MASS_NOWASH + REAL*8 :: ALPHA, ALPHA2, WETLOSS, L_PLUS_W + REAL*8 :: XDSTT, TMP + + ! DSTT is the accumulator array of rained-out + ! soluble tracer for a given (I,J) column + REAL*8 :: DSTT(NSOLMAX,LLPAR) + + ! Checkpointing vectors. Label them MCHK because we store + ! them in Memory. + REAL*8 :: F_MCHK(LLPAR) + REAL*8 :: SO2_MCHK(LLPAR) + REAL*8 :: SO4_MCHK(LLPAR) + REAL*8 :: H2O2s_MCHK(LLPAR) + REAL*8 :: SO2s_MCHK(LLPAR) + REAL*8 :: ALPHA_MCHK(LLPAR) + REAL*8 :: RAINFRAC_MCHK(LLPAR) + REAL*8 :: WASHFRAC_MCHK(LLPAR) + REAL*8 :: WASHFRAC_0(LLPAR) + REAL*8 :: RAINFRAC_0(LLPAR) + + +C============================================== +C define local variables +C============================================== + ! Replace adh2o2s and adso2s with ADJ_H2O2s and ADJ_SO2s, which + ! are module variables. + ! Replace adstt with ADJ_STT. + !real*8 addstt(10,10) + REAL*8 ADDSTT(1,LLPAR) + real*8 adgained + !real*8 ADJ_H2O2s(10,10,10) + real*8 adrainfrac + !real*8 ADJ_SO2s(10,10,10) + !real*8 adstt(10,10,10,10) + real*8 adwashfrac + real*8 adwetloss + + REAL*8, PARAMETER :: NEG_SMALL = -1.0D-10 + + !================================================================= + ! ADJ_SO2_WETDEP begins here! + ! + ! (1) I n i t i a l i z e V a r i a b l e s + !================================================================= + + + !STT(10,10,:,IDTSO2) = IN(:,1) + !H2O2s(10,10,:) = IN(:,2) + !SO2s(10,10,:) = IN(:,3) + + ! Reset checkpointing arrays +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( L ) + DO L = 1, LLPAR + + WASHFRAC_0(L) = 0d0 + RAINFRAC_0(L) = 0d0 + F_MCHK(L) = 0d0 + SO2_MCHK(L) = 0d0 + SO4_MCHK(L) = 0d0 + H2O2s_MCHK(L) = 0d0 + SO2s_MCHK(L) = 0d0 + ALPHA_MCHK(L) = 0d0 + RAINFRAC_MCHK(L) = 0d0 + WASHFRAC_MCHK(L) = 0d0 + + ENDDO +!$OMP END PARALLEL DO + + ! Dynamic timestep [s] + DT = GET_TS_DYN() * 60d0 + +! ! Select index for diagnostic arrays -- will archive either +! ! large-scale or convective rainout/washout fractions +! IF ( LS ) THEN +! IDX = 1 +! ELSE +! IDX = 2 +! ENDIF + + !================================================================= + ! (2) L o o p O v e r (I, J) S u r f a c e B o x e s + ! + ! Process rainout / washout by columns. + !================================================================= + +#if !defined( SGI_MIPS ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, FTOP, DSTT, ALPHA ) +!$OMP+PRIVATE( ALPHA2, F, F_PRIME, GAINED, K_RAIN ) +!$OMP+PRIVATE( LOST, MASS_NOWASH, MASS_WASH, RAINFRAC, WASHFRAC ) +!$OMP+PRIVATE( WETLOSS, L, Q, NN, N ) +!$OMP+PRIVATE( XDSTT, QDOWN, AER, TMP ) +!$OMP+PRIVATE( ADDSTT, ADGAINED, ADRAINFRAC, ADWASHFRAC ) +!$OMP+PRIVATE( ADWETLOSS ) +!$OMP+PRIVATE( F_MCHK, H2O2s_MCHK, SO2s_MCHK ) +!$OMP+PRIVATE( SO2_MCHK ) +!$OMP+PRIVATE( ALPHA_MCHK, RAINFRAC_MCHK, WASHFRAC_MCHK ) +!$OMP+PRIVATE( WASHFRAC_0, RAINFRAC_0 ) +!$OMP+SCHEDULE( DYNAMIC ) +#endif + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Zero arrays for this column + FTOP = 0d0 + DSTT(:,:) = 0d0 + + !============================================================== + ! (3) R a i n o u t F r o m T o p L a y e r (L = LLPAR) + !============================================================== + + ! Zero variables for this level + ALPHA = 0d0 + ALPHA2 = 0d0 + F = 0d0 + F_PRIME = 0d0 + GAINED = 0d0 + K_RAIN = 0d0 + LOST = 0d0 + MASS_NOWASH = 0d0 + MASS_WASH = 0d0 + RAINFRAC = 0d0 + WASHFRAC = 0d0 + WETLOSS = 0d0 + + + ! Set a few things for the entire routine that are just for + ! SO2 + NN = 1 ! The dimension of DSTT is (1,LLPAR) + AER = .TRUE. + + ! Start at the top of the atmosphere + L = LLPAR + + ! Checkpt H2O2s, SO2s, STT + H2O2s_MCHK(L) = H2O2s(I,J,L) + SO2s_MCHK(L) = SO2s(I,J,L) + SO2_MCHK(L) = STT(I,J,L,IDTSO2) + SO4_MCHK(L) = STT(I,J,L,IDTSO4) + + ! If precip forms at (I,J,L), assume it all rains out + IF ( QQ(L,I,J) > 0d0 ) THEN + + ! Q is the new precip that is forming within grid box (I,J,L) + Q = QQ(L,I,J) + + ! Compute K_RAIN and F' for either large-scale or convective + ! precipitation (cf. Eqs. 11-13, Jacob et al, 2000) + IF ( LS ) THEN + K_RAIN = LS_K_RAIN( Q ) + F_PRIME = LS_F_PRIME( Q, K_RAIN ) + ELSE + K_RAIN = 1.5d-3 + F_PRIME = CONV_F_PRIME( Q, K_RAIN, DT ) + ENDIF + + ! Set F = F', since there is no FTOP at L = LLPAR + F = F_PRIME + + ! Only compute rainout if F > 0. + ! This helps to eliminate unnecessary CPU cycles. + IF ( F > 0d0 ) THEN + +! ! ND16 diagnostic...save LS and Conv fractions +! IF ( ND16 > 0 .and. L <= LD16 ) THEN +! AD16(I,J,L,IDX) = AD16(I,J,L,IDX) + F +! CT16(I,J,L,IDX) = CT16(I,J,L,IDX) + 1 +! ENDIF + +! ! ND17 diagnostic...increment counter +! IF ( ND17 > 0 .and. L <= LD17 ) THEN +! CT17(I,J,L,IDX) = CT17(I,J,L,IDX) + 1 +! ENDIF + + ! Loop over soluble tracers and/or aerosol tracers +! DO NN = 1, NSOL +! N = IDWETD(NN) + N = IDTSO2 + + ! save a copy of the initial value of RAINFRAC (dkh, 10/08/09) + RAINFRAC_0(L) = GET_RAINFRAC( K_RAIN, F, DT ) +#if defined( GEOS_5 ) || defined( GEOS_FP ) + IF ( T(I,J,L) < 258d0 ) THEN + RAINFRAC_0(L) = 0d0 + ENDIF +#endif + + ! Call subroutine RAINOUT to compute the fraction + ! of tracer lost to rainout in grid box (I,J,L=LLPAR) + CALL RAINOUT( I, J, L, N, K_RAIN, DT, F, RAINFRAC ) + + ! use this for generating adjoint (dkh, 10/24/05) +! CALL RAINOUT_SO2(I,J,L,RAINFRAC, H2O2s, SO2s ) + + ! WETLOSS is the amount of soluble tracer + ! lost to rainout in grid box (I,J,L=LLPAR) + WETLOSS = STT(I,J,L,N) * RAINFRAC + + ! Remove rainout losses in grid box (I,J,L=LLPAR) from STT + STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS + + ! DSTT is an accumulator array for rained-out tracers. + ! The tracers in DSTT are in the liquid phase and will + ! precipitate to the levels below until a washout occurs. + ! Initialize DSTT at (I,J,L=LLPAR) with WETLOSS. + DSTT(NN,L) = WETLOSS + +! ! ND17 diagnostic...LS and conv rainout fractions [unitless] +! IF ( ND17 > 0 .and. L <= LD17 ) THEN +! AD17(I,J,L,NN,IDX) = +! & AD17(I,J,L,NN,IDX) + RAINFRAC / F +! ENDIF + +! ! ND39 diag - save rainout losses in [kg/s] +! IF ( ND39 > 0 .and. L <= LD39 ) THEN +! XDSTT = WETLOSS / DT +! AD39(I,J,L,NN) = AD39(I,J,L,NN) + XDSTT +! ENDIF + + ! Negative tracer...call subroutine SAFETY + !IF ( STT(I,J,L,N) < 0d0 ) THEN + ! Relax the condition and set it zero (hml, 10/15/13) + IF ( -1d-10 < STT(I,J,L,N) .and. + & STT(I,J,L,N) < 0d0 ) THEN + print*, 'Warning!! -1d-10 < STT(I,J,L,N) < 0d0 !!' + STT(I,J,L,N) = 0 + ENDIF + !ENDDO + ENDIF + + ! Save FTOP for the next lower level + FTOP = F + ENDIF + + ! Checkpt + F_MCHK(L) = F + RAINFRAC_MCHK(L) = RAINFRAC + + !============================================================== + ! (4) R a i n o u t i n t h e M i d d l e L e v e l s + ! + !============================================================== + DO L = LLPAR-1, 2, -1 + + + ! Checkpt H2O2s, SO2s, STT + H2O2s_MCHK(L) = H2O2s(I,J,L) + SO2s_MCHK(L) = SO2s(I,J,L) + SO2_MCHK(L) = STT(I,J,L,IDTSO2) + SO4_MCHK(L) = STT(I,J,L,IDTSO4) + + ! Zero variables for each level + ALPHA = 0d0 + ALPHA2 = 0d0 + F = 0d0 + F_PRIME = 0d0 + GAINED = 0d0 + K_RAIN = 0d0 + LOST = 0d0 + MASS_NOWASH = 0d0 + MASS_WASH = 0d0 + RAINFRAC = 0d0 + WASHFRAC = 0d0 + WETLOSS = 0d0 + + ! Rainout criteria + IF ( PDOWN(L,I,J) > 0d0 .and. QQ(L,I,J) > 0d0 ) THEN + + ! Q is the new precip that is forming within grid box (I,J,L) + Q = QQ(L,I,J) + + ! Compute K_RAIN and F' for either large-scale or convective + ! precipitation (cf. Eqs. 11-13, Jacob et al, 2000) + IF ( LS ) THEN + K_RAIN = LS_K_RAIN( Q ) + F_PRIME = LS_F_PRIME( Q, K_RAIN ) + ELSE + K_RAIN = 1.5d-3 + F_PRIME = CONV_F_PRIME( Q, K_RAIN, DT ) + ENDIF + + ! F is the effective area of precip seen by grid box (I,J,L) + F = MAX( F_PRIME, FTOP ) + + ! Only compute rainout if F > 0. + ! This helps to eliminate unnecessary CPU cycles. + IF ( F > 0d0 ) THEN + +! ! ND16 diagnostic...save F +! IF ( ND16 > 0 .and. L <= LD16 ) THEN +! AD16(I,J,L,IDX) = AD16(I,J,L,IDX) + F +! CT16(I,J,L,IDX) = CT16(I,J,L,IDX) + 1 +! ENDIF + +! ! ND17 diagnostic...increment counter +! IF ( ND17 > 0 .and. L <= LD17 ) THEN +! CT17(I,J,L,IDX) = CT17(I,J,L,IDX) + 1 +! ENDIF + + ! Loop over soluble tracers and/or aerosol tracers +! DO NN = 1, NSOL +! N = IDWETD(NN) + N = IDTSO2 + + ! save a copy of the initial value of RAINFRAC (dkh, 10/08/09) + RAINFRAC_0(L) = GET_RAINFRAC( K_RAIN, F, DT ) +#if defined( GEOS_5 ) || defined( GEOS_FP ) + IF ( T(I,J,L) < 258d0 ) THEN + RAINFRAC_0(L) = 0d0 + ENDIF +#endif + + ! Call subroutine RAINOUT to comptue the fraction + ! of tracer lost to rainout in grid box (I,J,L) + CALL RAINOUT( I, J, L, N, K_RAIN, DT, F, RAINFRAC ) + + ! use this for generating adjoint (dkh, 10/24/05) +! CALL RAINOUT_SO2( I, J, L,RAINFRAC, H2O2s, SO2s ) + + ! WETLOSS is the amount of tracer in grid box + ! (I,J,L) that is lost to rainout. + WETLOSS = STT(I,J,L,N) * RAINFRAC + + ! dkh debug + IF ( I == IFD .and. J == JFD .and. L == LFD ) THEN + print*, ' RAINFRAC at adj so2 = ', RAINFRAC + print*, ' K_RAIN at adj so2 = ', K_RAIN + print*, ' F at adj so2 = ', F + print*, ' WETLOSS = ', WETLOSS + print*, ' STT(FD) before = ', STT(I,J,L,NFD) + print*, ' DSTT(LFD)=', DSTT(NN,L) + print*, ' DSTT(LFD+1)=', DSTT(NN,L+1) + ENDIF + + + ! Subtract the rainout loss in grid box (I,J,L) from STT + STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS + + ! Add to DSTT the tracer lost to rainout in grid box + ! (I,J,L) plus the tracer lost to rainout from grid box + ! (I,J,L+1), which has by now precipitated down into + ! grid box (I,J,L). DSTT will continue to accumulate + ! rained out tracer in this manner until a washout + ! event occurs. + DSTT(NN,L) = DSTT(NN,L+1) + WETLOSS + +! ! ND17 diagnostic...rainout fractions [unitless] +! IF ( ND17 > 0 .and. L <= LD17 ) THEN +! AD17(I,J,L,NN,IDX) = +! & AD17(I,J,L,NN,IDX) + RAINFRAC / F +! ENDIF +! +! ! ND39 diag -- save rainout losses in [kg/s] +! IF ( ND39 > 0 .and. L <= LD39 ) THEN +! XDSTT = WETLOSS / DT +! AD39(I,J,L,NN) = AD39(I,J,L,NN) + XDSTT +! ENDIF + + ! Negative tracer...call subroutine SAFETY + !IF ( STT(I,J,L,N) < 0d0 ) THEN + ! Relax the condition and set it zero (hml, 10/15/13) + IF ( -1d-10 < STT(I,J,L,N) .and. + & STT(I,J,L,N) < 0d0 ) THEN + print*, 'Warning!! -1d-10 < STT(I,J,L,N) < 0d0 !!' + STT(I,J,L,N) = 0 + ENDIF +! ENDDO + ENDIF + + ! Save FTOP for next level + FTOP = F + + !============================================================== + ! (5) W a s h o u t i n t h e m i d d l e l e v e l s + ! + !============================================================== + ELSE IF ( PDOWN(L,I,J) > 0d0 .and. QQ(L,I,J) <= 0d0 ) THEN + + ! QDOWN is the precip leaving thru the bottom of box (I,J,L) + ! Q is the new precip that is forming within box (I,J,L) + QDOWN = PDOWN(L,I,J) + Q = QQ(L,I,J) + + ! Since no precipitation is forming within grid box (I,J,L), + ! F' = 0, and F = MAX( F', FTOP ) reduces to F = FTOP. + F = FTOP + + ! Only compute washout if F > 0. + ! This helps to eliminate needless CPU cycles. + IF ( F > 0d0 ) THEN + +! ! ND16 diagnostic...save F (fraction of grid box raining) +! IF ( ND16 > 0d0 .and. L <= LD16 ) THEN +! AD16(I,J,L,IDX) = AD16(I,J,L,IDX) + F +! CT16(I,J,L,IDX) = CT16(I,J,L,IDX) + 1 +! ENDIF + + ! ND18 diagnostic...increment counter +! IF ( ND18 > 0 .and. L <= LD18 ) THEN +! CT18(I,J,L,IDX) = CT18(I,J,L,IDX) + 1 +! ENDIF +! + ! Loop over soluble tracers and/or aerosol tracers +! DO NN = 1, NSOL +! N = IDWETD(NN) + + N = IDTSO2 + + ! save a copy of the initial value of WASHFRAC (dkh, 10/08/09) + WASHFRAC_0(L) = + & WASHFRAC_FINE_AEROSOL( DT, F, QDOWN, T(I,J,L) ) + + + ! Call WASHOUT to compute the fraction of + ! tracer lost to washout in grid box (I,J,L) + CALL WASHOUT( I, J, L, N, + & QDOWN, DT, F, WASHFRAC, AER ) + ! Use this for generating adjoint (dkh, 10/24/05) +! CALL WASHOUT_SO2(I, J, L, WASHFRAC, H2O2s, SO2s ) + + + !===================================================== + ! Washout of aerosol tracers -- + ! this is modeled as a kinetic process + !===================================================== +! IF ( AER ) THEN + + ! ALPHA is the fraction of the raindrops that + ! re-evaporate when falling from (I,J,L+1) to (I,J,L) + ALPHA = ( ABS( Q ) * BXHEIGHT(I,J,L) * 100d0 ) / + & PDOWN(L+1,I,J) + + ! Restrict ALPHA to be less than 1 + ! (>1 is unphysical) (hma, 24-Dec-2010) + IF ( ALPHA > 1d0 ) ALPHA = 1d0 + + ! ALPHA2 is the fraction of the rained-out aerosols + ! that gets resuspended in grid box (I,J,L) + ALPHA2 = 0.5d0 * ALPHA + + ! GAINED is the rained out aerosol coming down from + ! grid box (I,J,L+1) that will evaporate and re-enter + ! the atmosphere in the gas phase in grid box (I,J,L). + GAINED = DSTT(NN,L+1) * ALPHA2 + + ! Amount of aerosol lost to washout in grid box + ! (qli, bmy, 10/29/02) + WETLOSS = STT(I,J,L,N) * WASHFRAC - GAINED + + ! Remove washout losses in grid box (I,J,L) from STT. + ! Add the aerosol that was reevaporated in (I,J,L). + ! SO2 in sulfate chemistry is wet-scavenged on the + ! raindrop and converted to SO4 by aqeuous chem. + ! If evaporation occurs then SO2 comes back as SO4 + ! (rjp, bmy, 3/23/03) +! IF ( N == IDTSO2 ) THEN + STT(I,J,L,IDTSO4) = STT(I,J,L,IDTSO4) + & + GAINED * 96D0 / 64D0 + + STT(I,J,L,N) = STT(I,J,L,N) + & - ( WETLOSS + GAINED ) +! ELSE +! STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS +! ENDIF + + ! LOST is the rained out aerosol coming down from + ! grid box (I,J,L+1) that will remain in the liquid + ! phase in grid box (I,J,L) and will NOT re-evaporate. + LOST = DSTT(NN,L+1) - GAINED + + ! Add the washed out tracer from grid box (I,J,L) to + ! DSTT. Also add the amount of tracer coming down + ! from grid box (I,J,L+1) that does NOT re-evaporate. + DSTT(NN,L) = DSTT(NN,L+1) + WETLOSS + +! ! ND18 diagnostic...divide washout fraction by F +! IF ( ND18 > 0 .and. L <= LD18 ) THEN +! AD18(I,J,L,NN,IDX) = +! & AD18(I,J,L,NN,IDX) + WASHFRAC / F +! ENDIF + + !===================================================== + ! Washout of non-aerosol tracers + ! This is modeled as an equilibrium process + !===================================================== +! ELSE +! +! ! MASS_NOWASH is the amount of non-aerosol tracer in +! ! grid box (I,J,L) that is NOT available for washout. +! MASS_NOWASH = ( 1d0 - F ) * STT(I,J,L,N) +! +! ! MASS_WASH is the total amount of non-aerosol tracer +! ! that is available for washout in grid box (I,J,L). +! ! It consists of the mass in the precipitating +! ! part of box (I,J,L), plus the previously rained-out +! ! tracer coming down from grid box (I,J,L+1). +! ! (Eq. 15, Jacob et al, 2000). +! MASS_WASH = ( F * STT(I,J,L,N) ) + DSTT(NN,L+1) +! +! ! WETLOSS is the amount of tracer mass in +! ! grid box (I,J,L) that is lost to washout. +! ! (Eq. 16, Jacob et al, 2000) +! WETLOSS = MASS_WASH * WASHFRAC - DSTT(NN,L+1) +! +! ! The tracer left in grid box (I,J,L) is what was +! ! in originally in the non-precipitating fraction +! ! of the box, plus MASS_WASH, less WETLOSS. +! STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS +! +! ! Add washout losses in grid box (I,J,L) to DSTT +! DSTT(NN,L) = DSTT(NN,L+1) + WETLOSS +! +! ! ND18 diagnostic...we don't have to divide the +! ! washout fraction by F since this is accounted for. +! IF ( ND18 > 0 .and. L <= LD18 ) THEN +! AD18(I,J,L,NN,IDX) = +! & AD18(I,J,L,NN,IDX) + WASHFRAC +! ENDIF +! ENDIF +! +! ! ND39 diag -- save rainout losses in [kg/s] +! IF ( ND39 > 0 .and. L <= LD39 ) THEN +! XDSTT = WETLOSS / DT +! AD39(I,J,L,NN) = AD39(I,J,L,NN) + XDSTT +! ENDIF +! +! ! Negative tracer...call subroutine SAFETY +! IF ( STT(I,J,L,N) < 0d0 ) THEN +! CALL SAFETY( I, J, L, N, 6, +! & LS, PDOWN(L,I,J), +! & QQ(L,I,J), ALPHA, +! & ALPHA2, RAINFRAC, +! & WASHFRAC, MASS_WASH, +! & MASS_NOWASH, WETLOSS, +! & GAINED, LOST, +! & DSTT(NN,:), STT(I,J,:,N) ) +! ENDIF +! ENDDO + ENDIF + + ! Save FTOP for next level + FTOP = F + + !=========================================================== + ! (6) N o D o w n w a r d P r e c i p i t a t i o n + ! + ! If there is no precipitation leaving grid box (I,J,L), + ! then set F, the effective area of precipitation in grid + ! box (I,J,L), to zero. + ! + ! Also, all of the previously rained-out tracer that is now + ! coming down from grid box (I,J,L+1) will evaporate and + ! re-enter the atmosphere in the gas phase in grid box + ! (I,J,L). This is called "resuspension". + !=========================================================== + ELSE IF ( ABS( PDOWN(L,I,J) ) < 1d-30 ) THEN + + ! No precipitation at grid box (I,J,L), thus F = 0 + F = 0d0 + + ! Loop over soluble tracers and/or aerosol tracers +! DO NN = 1, NSOL +! N = IDWETD(NN) + N = IDTSO2 + + ! WETLOSS is the amount of tracer in grid box (I,J,L) + ! that is lost to rainout. (qli, bmy, 10/29/02) + WETLOSS = -DSTT(NN,L+1) + + ! All of the rained-out tracer coming from grid box + ! (I,J,L+1) goes back into the gas phase at (I,J,L) + ! In evap, SO2 comes back as SO4 (rjp, bmy, 3/23/03) +! IF ( N == IDTSO2 ) THEN + STT(I,J,L,IDTSO4) = STT(I,J,L,IDTSO4) + & - ( WETLOSS * 96d0 / 64d0 ) +! ELSE +! STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS +! ENDIF + + ! There is nothing rained out/washed out in grid box + ! (I,J,L), so set DSTT at grid box (I,J,L) to zero. + DSTT(NN,L) = 0d0 + +! ! ND39 diag -- save rainout losses in [kg/s] +! IF ( ND39 > 0 .and. L <= LD39 ) THEN +! XDSTT = WETLOSS / DT +! AD39(I,J,L,NN) = AD39(I,J,L,NN) + XDSTT +! ENDIF + + ! Negative tracer...call subroutine SAFETY + !IF ( STT(I,J,L,N) < 0d0 ) THEN + ! Relax the condition and set it zero (hml, 10/15/13) + IF ( -1d-10 < STT(I,J,L,N) .and. + & STT(I,J,L,N) < 0d0 ) THEN + print*, 'Warning!! -1d-10 < STT(I,J,L,N) < 0d0 !!' + STT(I,J,L,N) = 0 + ENDIF +! ENDDO + + ! Save FTOP for next level + FTOP = F + ENDIF + + ! Checkpt + F_MCHK(L) = F + WASHFRAC_MCHK(L) = WASHFRAC + RAINFRAC_MCHK(L) = RAINFRAC + ALPHA_MCHK(L) = ALPHA + + ENDDO ! L + + !============================================================== + ! (7) W a s h o u t i n L e v e l 1 + ! + ! Assume all of the tracer precipitating down from grid box + ! (I,J,L=2) to grid box (I,J,L=1) gets washed out in grid box + ! (I,J,L=1). + !============================================================== + + ! BUG FIX? This should be at L = 1 (dkh, 10/08/09) + !! Checkpt H2O2s, SO2s, STT + !H2O2s_MCHK(L) = H2O2s(I,J,L) + !SO2s_MCHK(L) = SO2s(I,J,L) + !SO2_MCHK(L) = STT(I,J,L,IDTSO2) + !SO4_MCHK(L) = STT(I,J,L,IDTSO4) + + ! Zero variables for this level + ALPHA = 0d0 + ALPHA2 = 0d0 + F = 0d0 + F_PRIME = 0d0 + GAINED = 0d0 + K_RAIN = 0d0 + LOST = 0d0 + MASS_NOWASH = 0d0 + MASS_WASH = 0d0 + RAINFRAC = 0d0 + WASHFRAC = 0d0 + WETLOSS = 0d0 + + + ! We are at the surface, set L = 1 + L = 1 + + ! BUG FIX This should be here at L = 1 (dkh, 10/08/09) + ! Checkpt H2O2s, SO2s, STT + H2O2s_MCHK(L) = H2O2s(I,J,L) + SO2s_MCHK(L) = SO2s(I,J,L) + SO2_MCHK(L) = STT(I,J,L,IDTSO2) + SO4_MCHK(L) = STT(I,J,L,IDTSO4) + + ! Washout at level 1 criteria + IF ( PDOWN(L+1,I,J) > 0d0 ) THEN + + ! QDOWN is the precip leaving thru the bottom of box (I,J,L+1) + QDOWN = PDOWN(L+1,I,J) + + ! Since no precipitation is forming within grid box (I,J,L), + ! F' = 0, and F = MAX( F', FTOP ) reduces to F = FTOP. + F = FTOP + + ! Only compute washout if F > 0. + ! This helps to eliminate unnecessary CPU cycles. + IF ( F > 0d0 ) THEN + +! ! ND16 diagnostic...save F +! IF ( ND16 > 0 .and. L <= LD16 ) THEN +! AD16(I,J,L,IDX) = AD16(I,J,L,IDX) + F +! CT16(I,J,L,IDX) = CT16(I,J,L,IDX) + 1 +! ENDIF +! +! ! ND18 diagnostic...increment counter +! IF ( ND18 > 0 .and. L <= LD18 ) THEN +! CT18(I,J,L,IDX) = CT18(I,J,L,IDX) + 1 +! ENDIF + +! ! Loop over soluble tracers and/or aerosol tracers +! DO NN = 1, NSOL +! N = IDWETD(NN) + N = IDTSO2 + + ! save a copy of the initial value of WASHFRAC (dkh, 10/08/09) + WASHFRAC_0(L) = + & WASHFRAC_FINE_AEROSOL( DT, F, QDOWN, T(I,J,L) ) + + + ! Call WASHOUT to compute the fraction of tracer + ! in grid box (I,J,L) that is lost to washout. + CALL WASHOUT( I, J, L, N, + & QDOWN, DT, F, WASHFRAC, AER ) + + ! use this for generating adjoint (dkh, 10/24/05) +! CALL WASHOUT_SO2( I, J, L, WASHFRAC, H2O2s, SO2s) + + ! NOTE: for HNO3 and aerosols, there is an F factor + ! already present in WASHFRAC. For other soluble + ! gases, we need to multiply by the F (hyl, bmy, 10/27/00) +! IF ( AER ) THEN + WETLOSS = STT(I,J,L,N) * WASHFRAC +! ELSE +! WETLOSS = STT(I,J,L,N) * WASHFRAC * F +! ENDIF + + ! Subtract WETLOSS from STT + STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS + +! ! ND18 diagnostic...LS and conv washout fractions [unitless] +! IF ( ND18 > 0 .and. L <= LD18 ) THEN +! +! ! Only divide WASHFRAC by F for aerosols, since +! ! for non-aerosols this is already accounted for +! IF ( AER ) THEN +! TMP = WASHFRAC / F +! ELSE +! TMP = WASHFRAC +! ENDIF +! +! AD18(I,J,L,NN,IDX) = AD18(I,J,L,NN,IDX) + TMP +! ENDIF + +! ! ND39 diag -- save washout loss in [kg/s] +! IF ( ND39 > 0 .and. L <= LD39 ) THEN +! XDSTT = WETLOSS / DT +! AD39(I,J,L,NN) = AD39(I,J,L,NN) + XDSTT +! ENDIF + +! !----------------------------------------------------- +! ! Dirty kludge to prevent wet deposition from removing +! ! stuff from stratospheric boxes -- this can cause +! ! negative tracer (rvm, bmy, 6/21/00) +! ! +! IF ( STT(I,J,L,N) < 0d0 .and. L > 23 ) THEN +! WRITE ( 6, 101 ) I, J, L, N, 7 +! 101 FORMAT( 'WETDEP - STT < 0 at ', 3i4, +! & ' for tracer ', i4, 'in area ', i4 ) +! PRINT*, 'STT:', STT(I,J,:,N) +! STT(I,J,L,N) = 0d0 +! ENDIF +! !----------------------------------------------------- +! + ! Negative tracer...call subroutine SAFETY + !IF ( STT(I,J,L,N) < 0d0 ) THEN + ! Relax the condition and set it zero (hml, 10/15/13) + IF ( -1d-10 < STT(I,J,L,N) .and. + & STT(I,J,L,N) < 0d0 ) THEN + print*, 'Warning!! -1d-10 < STT(I,J,L,N) < 0d0 !!' + STT(I,J,L,N) = 0 + ENDIF +! ENDDO + ENDIF + ENDIF + + ! Checkpt + F_MCHK(L) = F + WASHFRAC_MCHK(L) = WASHFRAC + + ! dkh debug + IF ( LPRINTFD .and. I == IFD .and. J == JFD ) THEN + WRITE(6,*) ' WETD CHK variables after WETDEP(T) SO2' + print*, ' H2O2s(FD) aft so2 = ', H2O2s(IFD,JFD,LFD) + print*, ' SO2s(FD) aft so2 = ', SO2s(IFD,JFD,LFD) + print*, ' SO4(FD) aft so2 = ', STT(IFD,JFD,LFD,IDTSO4) + print*, ' STT(FD) aft so2 = ', STT(IFD,JFD,LFD,NFD) + ENDIF + + + !============================================================ + ! Adjoint begins here + !============================================================ + + ! Set N for adjoint of SO2 + N = IDTSO2 +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + ! Don't reset arrays that are involved in other adjoint routines + ! such as ADH2O2s, ADSO2s and ADSTT. + !do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! addstt(ip1,ip2) = 0. + ! end do + !end do + ADDSTT(:,:) = 0d0 + adgained = 0.d0 + !do ip3 = 1, 10 + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! ADJ_H2O2s(ip1,ip2,ip3) = 0. + ! end do + ! end do + !end do + adrainfrac = 0. + !do ip3 = 1, 10 + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! ADJ_SO2s(ip1,ip2,ip3) = 0. + ! end do + ! end do + !end do + !do ip4 = 1, 10 + ! do ip3 = 1, 10 + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! adstt(ip1,ip2,ip3,ip4) = 0. + ! end do + ! end do + ! end do + !end do + adwashfrac = 0. + adwetloss = 0. + + !============================================================ + ! Adjoint of 7 + !============================================================ + L = 1 + + F = F_MCHK(L) + H2O2s(I,J,L) = H2O2s_MCHK(L) + SO2s(I,J,L) = SO2s_MCHK(L) + !STT(I,J,L,IDTSO4) = SO2_MCHK(L) + + if (pdown(l+1,i,j) .gt. 0.d0) then + + !f = ftop + if (f .gt. 0.d0) then + !n = idtso2 + !call washout_so2( i,j,l,washfrac,h2o2s,so2s ) + WASHFRAC = WASHFRAC_MCHK(L) + ! Reference the working adjoint array + !adwetloss = adwetloss-adstt(i,j,l,n) + adwetloss = adwetloss-STT_ADJ(i,j,l,n) + ! Reference the working adjoint array + !adstt(i,j,l,n) = adstt(i,j,l,n)+adwetloss*washfrac + STT_ADJ(i,j,l,n) = STT_ADJ(i,j,l,n)+adwetloss*washfrac + ! Use original SO2 stored in memory + !adwashfrac = adwashfrac+adwetloss*stt(i,j,l,STT2ADJ(n)) + adwashfrac = adwashfrac+adwetloss*SO2_MCHK(L) + adwetloss = 0.d0 + !call adresto( 'memory_2_wetdep_so2_h2o2s',25,h2o2s,8,1000,1 ) + !call adresto( 'memory_2_wetdep_so2_so2s',24,so2s,8,1000,1 ) + ! Do not reset. Instead, we have checkpted the final value + ! and pass this instead. Also, don't have to arguments that + ! are actually module variables. + !washfrac = 0.d0 +! call adwashout_so2( i,j,l,washfrac,h2o2s,so2s,adwashfrac, +!! $adh2o2s,adso2s ) + ! Now make WASHFRAC_0 a local variable + !CALL ADWASHOUT_SO2( I, J, L, WASHFRAC, ADWASHFRAC ) + CALL ADWASHOUT_SO2( I, J, L, WASHFRAC, ADWASHFRAC, + & WASHFRAC_0 ) + endif + endif + adwashfrac = 0.d0 + + do l = 2, llpar-1 +! call adresto( 'memory_1_wetdep_so2_h2o2s',25,h2o2s,8,1000,1+ +! $llpar-1-l ) +! call adresto( 'memory_1_wetdep_so2_so2s',24,so2s,8,1000,1+llpar- +! $1-l ) +! call adresto( 'memory_1_wetdep_so2_stt',23,stt,8,10000,1+llpar- +! $1-l ) +! call adresto( 'memory_1_wetdep_so2_ftop',24,ftop,8,1,1+llpar-1- +! $l ) + !alpha = 0.d0 + !f = 0.d0 + !rainfrac = 0.d0 + !washfrac = 0.d0 + + F = F_MCHK(L) + H2O2s(I,J,L) = H2O2s_MCHK(L) + SO2s(I,J,L) = SO2s_MCHK(L) + !STT(I,J,L,IDTSO4) = STT_MCHK(L) + + ! just to be safe + ADRAINFRAC = 0d0 + ADWETLOSS = 0d0 + ADGAINED = 0d0 + + !============================================================ + ! Adjoint of 4 + !============================================================ + if (pdown(l,i,j) .gt. 0.d0 .and. qq(l,i,j) .gt. 0.d0) then + if (f .gt. 0.d0) then + !n = idtso2 + !call rainout_so2( i,j,l,rainfrac,h2o2s,so2s ) + RAINFRAC = RAINFRAC_MCHK(L) + adwetloss = adwetloss+addstt(nn,l) + addstt(nn,l+1) = addstt(nn,l+1)+addstt(nn,l) + addstt(nn,l) = 0. + ! Reference the working adjoint array + !adwetloss = adwetloss-adstt(i,j,l,n) + adwetloss = adwetloss-STT_ADJ(i,j,l,n) + ! Use original SO2 stored in memory + !adrainfrac = adrainfrac+adwetloss*stt(i,j,l,STT2ADJ(n)) + adrainfrac = adrainfrac+adwetloss*SO2_MCHK(L) + ! Reference the working adjoint array + !adstt(i,j,l,n) = adstt(i,j,l,n)+adwetloss*rainfrac + ! dkh debug + IF ( I == IFD .and. J == JFD .and. L == LFD + & .and. N == NFD .and. LPRINTFD ) THEN + print*, ' STT_ADJ(FD) before = ', STT_ADJ(I,J,L,N) + print*, ' ADWETLOSS = ', ADWETLOSS + print*, ' RAINFRAC = ', RAINFRAC + print*, ' H2O2s = ', H2O2s(I,J,L) + print*, ' SO2s = ', SO2s(I,J,L) + print*, ' STT(FD) =', STT(IFD,JFD,LFD,NFD) + print*, ' adrainfrac = ', adrainfrac + print*, ' SO2_MCHK = ', SO2_MCHK(L) + ENDIF + STT_ADJ(i,j,l,n) = STT_ADJ(i,j,l,n)+adwetloss*rainfrac + adwetloss = 0. + IF ( I == IFD .and. J == JFD .and. L == LFD + & .and. N == NFD .and. LPRINTFD ) THEN + print*, ' STT_ADJ(FD) after = ', STT_ADJ(I,J,L,N) + ENDIF +! call adresto( 'memory_1_wetdep_so2_h2o2s',25,h2o2s,8,1000,1+ +! $llpar-1-l ) +! call adresto( 'memory_1_wetdep_so2_so2s',24,so2s,8,1000,1+ +! $llpar-1-l ) + ! Do not reset. Instead, we have checkpted the final value + ! of RAINFRAC and pass this instead. Also, don't have to arguments that + ! are actually module variables. + !rainfrac = 0.d0 +! call adrainout_so2( i,j,l,rainfrac,h2o2s,so2s,adrainfrac, +! $adh2o2ss,adso2s ) + ! Now make RAINFRAC_0 a local variable + !CALL ADRAINOUT_SO2( I, J, L, RAINFRAC, ADRAINFRAC ) + CALL ADRAINOUT_SO2( I, J, L, RAINFRAC, ADRAINFRAC, + & RAINFRAC_0 ) + IF ( I == IFD .and. J == JFD .and. L == LFD + & .and. N == NFD .and. LPRINTFD ) THEN + print*, ' SO2s_ADJ(FD) = ', SO2s_ADJ(I,J,L) + ENDIF + endif + !============================================================ + ! Adjoint of 5 + !============================================================ + else if (pdown(l,i,j) .gt. 0.d0 .and. qq(l,i,j) .le. 0.d0) + & then + !f = ftop + if (f .gt. 0.d0) then + !n = idtso2 + !call washout_so2( i,j,l,washfrac,h2o2s,so2s ) + WASHFRAC = WASHFRAC_MCHK(L) + ALPHA = ALPHA_MCHK(L) + alpha2 = 0.5d0*alpha + adwetloss = adwetloss+addstt(nn,l) + addstt(nn,l+1) = addstt(nn,l+1)+addstt(nn,l) + addstt(nn,l) = 0. + ! Reference the working adjoint array + !adgained = adgained-adstt(i,j,l,n) + !adwetloss = adwetloss-adstt(i,j,l,n) + !adgained = adgained+1.5d0*adstt(i,j,l,idtso4) + adgained = adgained-STT_ADJ(i,j,l,n) + adwetloss = adwetloss-STT_ADJ(i,j,l,n) + adgained = adgained+1.5d0*STT_ADJ(i,j,l,IDTSO4) + adgained = adgained-adwetloss + ! Reference the working adjoint array + !adstt(i,j,l,n) = adstt(i,j,l,n)+adwetloss*washfrac + STT_ADJ(i,j,l,n) = STT_ADJ(i,j,l,n)+adwetloss*washfrac + ! Use the original SO2 stored in memory + !adwashfrac = adwashfrac+adwetloss*stt(i,j,l,STT2ADJ(n)) + adwashfrac = adwashfrac+adwetloss*SO2_MCHK(L) + adwetloss = 0. + addstt(nn,l+1) = addstt(nn,l+1)+adgained*alpha2 + adgained = 0. +! call adresto( 'memory_1_wetdep_so2_h2o2s',25,h2o2s,8,1000,1+ +! $llpar-1-l ) +! call adresto( 'memory_1_wetdep_so2_so2s',24,so2s,8,1000,1+ +! $llpar-1-l ) + ! Do not reset. Instead, we have checkpted the final value + ! and pass this instead. Also, don't have to arguments that + ! are actually module variables. + !washfrac = 0.d0 +! call adwashout_so2( i,j,l,washfrac,h2o2s,so2s,adwashfrac, +! $adh2o2ss,adso2s ) + ! Now make WASHFRAC_0 a local variable + !CALL ADWASHOUT_SO2( I, J, L, WASHFRAC, ADWASHFRAC ) + CALL ADWASHOUT_SO2( I, J, L, WASHFRAC, ADWASHFRAC, + & WASHFRAC_0 ) + endif + !============================================================ + ! Adjoint of 6 + !============================================================ + else if (abs(pdown(l,i,j)) .lt. 1.d-30) then + addstt(nn,l) = 0. + ! Reference the working adjoint array + !adwetloss = adwetloss-1.5d0*adstt(i,j,l,idtso4) + adwetloss = adwetloss-1.5d0*STT_ADJ(i,j,l,IDTSO4) + addstt(nn,l+1) = addstt(nn,l+1)-adwetloss + adwetloss = 0. + endif + adwashfrac = 0. + adrainfrac = 0. + end do ! L + + !============================================================ + ! Adjoint of 3 + !============================================================ + l = llpar + + F = F_MCHK(L) + H2O2s(I,J,L) = H2O2s_MCHK(L) + SO2s(I,J,L) = SO2s_MCHK(L) + !STT(I,J,L,IDTSO4) = STT_MCHK(L) + + if (qq(l,i,j) .gt. 0.d0) then + if (f .gt. 0.d0) then + adwetloss = adwetloss+addstt(nn,l) + addstt(nn,l) = 0. + ! Reference the working adjoint array + !adwetloss = adwetloss-adstt(i,j,l,n) + adwetloss = adwetloss-STT_ADJ(i,j,l,n) +! stt(10,10,:,idtso2) = in(:,1) +! h2o2s(10,10,:) = in(:,2) +! so2s(10,10,:) = in(:,3) + ! Use original SO2 stored in memory + !adrainfrac = adrainfrac+adwetloss*stt(i,j,l,STT2ADJ(n)) + adrainfrac = adrainfrac+adwetloss*SO2_MCHK(L) + ! Why didn't TAMC have a call to rainout_so2 here? + RAINFRAC = RAINFRAC_MCHK(L) + ! Reference the working adjoint array + !adstt(i,j,l,n) = adstt(i,j,l,n)+adwetloss*rainfrac + STT_ADJ(i,j,l,n) = STT_ADJ(i,j,l,n)+adwetloss*rainfrac + adwetloss = 0. +! h2o2s(10,10,:) = in(:,2) +! so2s(10,10,:) = in(:,3) + ! Do not reset. Instead, we have checkpted the final value + ! of RAINFRAC and pass this instead. Also, don't have to arguments that + ! are actually module variables. + !rainfrac = 0.d0 +! call adrainout_so2( i,j,l,rainfrac,h2o2s,so2s,adrainfrac, +! $ADJ_H2O2s,ADJ_SO2s ) + ! Now make RAINFRAC_0 a local variable (dkh, 10/08/09) + !CALL ADRAINOUT_SO2(I, J, L, RAINFRAC, ADRAINFRAC ) + CALL ADRAINOUT_SO2(I, J, L, RAINFRAC, ADRAINFRAC, + & RAINFRAC_0 ) + endif + endif + !dkh debug + ADRAINFRAC = 0d0 + + ENDDO + ENDDO +#if !defined( SGI_MIPS ) +!$OMP END PARALLEL DO +#endif + + +! OUT(:,1) = STT(10,10,:,IDTSO2) +! OUT(:,2) = H2O2s(10,10,:) +! OUT(:,3) = SO2s(10,10,:) + + ! Return to calling program + END SUBROUTINE ADJ_SO2_WETDEP + +!------------------------------------------------------------------------------ +C*************************************************************** +C DISCLAIMER +C +C This file was generated by TAMC version 5.3.2 +C +C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES +C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, +C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS +C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS. +C +C THIS CODE IS FOR NON-PROFIT-ORIENTED ACADEMIC RESEARCH AND EDUCATION +C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTED USE OR EVALUATION IS +C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT +C ALLOWED. +C +C FOR COMMERCIAL OR OTHER PROFIT-ORIENTED APPLICATIONS PLEASE CONTACT +C info@FastOpt.com +C + ! We don't actually need to pass H2O2s and SO2s or their + ! adjoints as arguments because they're module variables. . +! subroutine adrainout_so2( i, j, l, rainfrac, h2o2s, so2s, +! $adrainfrac, adjh2o2s, adso2s ) + SUBROUTINE ADRAINOUT_SO2( I, J, L, + & RAINFRAC, ADRAINFRAC, + & RAINFRAC_0 ) +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +! Modifications in CAPS by dkh. +! +! Notes: +! (1 ) Updated to GCv8 (dkh, 09/29/09) +! +C*************************************************************** +C*************************************************************** +C============================================== +C all entries are defined explicitly +C============================================== + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE WETSCAV_MOD, ONLY : SO2s + USE WETSCAV_MOD, ONLY : H2O2s + ! Now make this a local variable + !USE WETSCAV_MOD, ONLY : RAINFRAC_0 + USE WETSCAV_MOD, ONLY : EPSILON + + + implicit none +# include "CMN_SIZE" ! LLPAR +C============================================== +C define common blocks +C============================================== +C============================================== +C define arguments +C============================================== + ! make this a module var + !real*8 adh2o2s(10,10,10) + real*8 adrainfrac + ! make this a module var + !real*8 adso2s(10,10,10) + ! This is a module variable + !real*8 h2o2s(10,10,10) + integer i + integer j + integer l + real*8 rainfrac + ! This is a module variable + !real*8 so2s(10,10,10) + + REAL*8 RAINFRAC_0(LLPAR) + +C============================================== +C define local variables +C============================================== + real*8 adso2loss + ! EPSILON is actually a module variable + !real*8 epsilon + !real*8 h2o2sh(10,10,10) + REAL*8 H2O2sh + !integer ip1 + !integer ip2 + !integer ip3 + real*8 rainfrach + real*8 so2loss + !real*8 so2sh(10,10,10) + REAL*8 SO2sh + +C---------------------------------------------- +C SAVE ARGUMENTS +C---------------------------------------------- + ! Only save local scalar values + !do ip3 = 1, 10 + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! so2sh(ip1,ip2,ip3) = so2s(ip1,ip2,ip3) + ! end do + ! end do + !end do + ! dkh debug + !SO2s(I,J,L) = 1.5995817D-9 + !H2O2s(I,J,L) = 6.163918D-10 + + SO2sh = SO2s(I,J,L) + rainfrach = rainfrac + !do ip3 = 1, 10 + ! Only save local scalar values + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! h2o2sh(ip1,ip2,ip3) = h2o2s(ip1,ip2,ip3) + ! end do + ! end do + !end do + H2O2sh = H2O2s(I,J,L) + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adso2loss = 0. +C ROUTINE BODY +C---------------------------------------------- + if (so2s(i,j,l) .gt. epsilon) then + so2loss = min(so2s(i,j,l),h2o2s(i,j,l)) + ! Rather than recompute RAINFRAC, which would mean recomputing K_RAIN, + ! we'll just use the checkpointed value. So RAINFRAC is actually + ! an input of adrainout_so2. + !rainfrac = so2loss*rainfrac/so2s(i,j,l) + !rainfrac = max(rainfrac,0.d0) + else + !rainfrac = 0.d0 + endif + so2s(i,j,l) = so2s(i,j,l)*(1.d0-rainfrac) + SO2s_ADJ(i,j,l) = SO2s_ADJ(i,j,l) + & *(0.5d0+sign(0.5,so2s(i,j,l)-epsilon)) + + ! dkh debug + IF ( LPRINTFD .and. I == IFD .and. J == JFD .and. L == LFD ) + & print*, ' SO2s_ADJ 0: ', SO2s_ADJ(I,J,L), + & ' so2s (final) = ', so2s(I,J,L), + & ' adrainfrac (initial) = ', adrainfrac + + ! Only hold the local scalar value + !do ip3 = 1, 10 + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! so2s(ip1,ip2,ip3) = so2sh(ip1,ip2,ip3) + ! end do + ! end do + !end do + SO2s(I,J,L) = SO2sh + adrainfrac = adrainfrac-SO2s_ADJ(i,j,l)*so2s(i,j,l) + SO2s_ADJ(i,j,l) = SO2s_ADJ(i,j,l)*(1.d0-rainfrac) + IF ( LPRINTFD .and. I == IFD .and. J == JFD .and. L == LFD ) + & print*, ' SO2s_ADJ 1: ', SO2s_ADJ(I,J,L), + & ' adrainfrac (1) = ', adrainfrac + if (so2s(i,j,l) .gt. epsilon) then + h2o2s(i,j,l) = h2o2s(i,j,l)-so2s(i,j,l)*rainfrac + H2O2s_ADJ(i,j,l) = H2O2s_ADJ(i,j,l)*(0.5d0+sign(0.5,h2o2s(i,j,l) + $-epsilon)) + adrainfrac = adrainfrac-H2O2s_ADJ(i,j,l)*so2s(i,j,l) + SO2s_ADJ(i,j,l) = SO2s_ADJ(i,j,l)-H2O2s_ADJ(i,j,l)*rainfrac + IF ( LPRINTFD .and. I == IFD .and. J == JFD .and. L == LFD ) + & print*, ' SO2s_ADJ 2: ', SO2s_ADJ(I,J,L), + & ' adrainfrac (2) = ', adrainfrac + ! At this point rainfrac is already at its final value + ! so don't need to recalculate it. Also, rainfrach IS + ! the final value. + !rainfrac = rainfrach + !rainfrac = so2loss*rainfrac/so2s(i,j,l) + adrainfrac = adrainfrac*(0.5d0+sign(0.5d0,rainfrac-0.d0)) + ! Here we need the original RAINFRAC, so restore using RAINFRAC_0 + ! before rescaling because we didn't checkpt that. + !rainfrac = rainfrach + RAINFRAC = RAINFRAC_0(L) + adso2loss = adso2loss+adrainfrac*(rainfrac/so2s(i,j,l)) + SO2s_ADJ(i,j,l) = SO2s_ADJ(i,j,l)-adrainfrac*(so2loss*rainfrac/ + $(so2s(i,j,l)*so2s(i,j,l))) + + ! dkh debug + IF ( LPRINTFD .and. I == IFD .and. J == JFD .and. L == LFD ) + & print*, ' SO2s_ADJ 3: ', SO2s_ADJ(I,J,L), + & ' adrainfrac = ', adrainfrac, + & ' so2loss = ', so2loss, + & ' rainfrac = ', rainfrac, + & ' so2s^2 = ', so2s(I,J,L)*so2s(I,J,L), + & ' so2s = ', so2s(I,J,L) + + adrainfrac = adrainfrac*(so2loss/so2s(i,j,l)) + ! Only hold the local scalar value + !do ip3 = 1, 10 + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! h2o2s(ip1,ip2,ip3) = h2o2sh(ip1,ip2,ip3) + ! end do + ! end do + !end do + H2O2s(I,J,L) = H2O2sh + H2O2s_ADJ(i,j,l) = + &H2O2s_ADJ(i,j,l)+adso2loss*(0.5d0-sign(0.5d0,h2o2s(i, + $j,l)-so2s(i,j,l))) + SO2s_ADJ(i,j,l) = SO2s_ADJ(i,j,l) + &+adso2loss*(0.5d0+sign(0.5d0,h2o2s(i,j, + $l)-so2s(i,j,l))) + + ! dkh debug + IF ( LPRINTFD .and. I == IFD .and. J == JFD .and. L == LFD ) + & print*, ' SO2s_ADJ 4: ', SO2s_ADJ(I,J,L), + & ' adso2loss = ', adso2loss, + & ' so2s ', so2s(I,J,L), + & ' h2o2s ', h2o2s(I,J,L), + & ' adrainfrac ', adrainfrac + + adso2loss = 0.d0 + else + adrainfrac = 0.d0 + endif + + !end + END SUBROUTINE ADRAINOUT_SO2 + +C*************************************************************** + + ! We don't actually need to pass H2O2s and SO2s or their + ! adjoints as arguments because they're module variables. . +! subroutine adwashout_so2( i, j, l, washfrac, h2o2s, so2s, +! $adwashfrac, adh2o2s, adso2s ) + SUBROUTINE ADWASHOUT_SO2( I, J, L, + & WASHFRAC, ADWASHFRAC, + & WASHFRAC_0 ) +C*************************************************************** +C*************************************************************** +C** This routine was generated by the ** +C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 ** +! Modifications in CAPS by dkh. +! +! Notes: +! (1 ) Updated to GCv8 (dkh, 09/29/09) +! +C*************************************************************** +C*************************************************************** + ! References to f90 mofules + USE DAO_MOD, ONLY : T + USE WETSCAV_MOD, ONLY : H2O2s + USE WETSCAV_MOD, ONLY : SO2s + ! Now make this a local variable + !USE WETSCAV_MOD, ONLY : WASHFRAC_0 + USE WETSCAV_MOD, ONLY : EPSILON + + +C============================================== +C all entries are defined explicitly +C============================================== + implicit none + +# include "CMN_SIZE" ! LLPAR + +C============================================== +C define common blocks +C============================================== +C============================================== +C define arguments +C============================================== + ! Comment out those that are module variables. + !real*8 adh2o2s(10,10,10) + !real*8 adso2s(10,10,10) + real*8 adwashfrac + !real*8 h2o2s(10,10,10) + integer i + integer j + integer l + !real*8 so2s(10,10,10) + real*8 washfrac + + REAL*8 WASHFRAC_0(LLPAR) + +C============================================== +C define local variables +C============================================== + real*8 adso2loss + ! Epsilon is actually a module variable + !real*8 epsilon + ! Only save scalar of local value + !real*8 h2o2sh(10,10,10) + REAL*8 :: H2O2sh + ! Don't need TAMC's dummy indicies + !integer ip1 + !integer ip2 + !integer ip3 + real*8 so2loss + ! Only save scalar of local value + !real*8 so2sh(10,10,10) + REAL*8 :: SO2sh + real*8 tk + real*8 washfrach + +C---------------------------------------------- +C SAVE ARGUMENTS +C---------------------------------------------- + washfrach = washfrac + !do ip3 = 1, 10 + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! so2sh(ip1,ip2,ip3) = so2s(ip1,ip2,ip3) + ! end do + ! end do + !end do + SO2sh = SO2s(I,J,L) + !do ip3 = 1, 10 + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! h2o2sh(ip1,ip2,ip3) = h2o2s(ip1,ip2,ip3) + ! end do + ! end do + !end do + H2O2sh = H2O2s(I,J,L) + +C---------------------------------------------- +C RESET LOCAL ADJOINT VARIABLES +C---------------------------------------------- + adso2loss = 0.d0 + +C---------------------------------------------- +C ROUTINE BODY +C---------------------------------------------- + ! TK is Kelvin temperature + TK = T(I,J,L) + + if (tk .ge. 268.d0 .and. so2s(i,j,l) .gt. epsilon) then + so2loss = min(so2s(i,j,l),h2o2s(i,j,l)) + ! Rather than recalculate WASHFRAC, which would involve + ! first recalculating WASHFRAC_AEROSOL, we pass the final checkpted + ! value of WASHFRAC to this routine. + !washfrac = so2loss*washfrac/so2s(i,j,l) + !washfrac = max(washfrac,0.d0) + else + !washfrac = 0.d0 + endif + so2s(i,j,l) = so2s(i,j,l)*(1.d0-washfrac) + SO2s_ADJ(i,j,l) = SO2s_ADJ(i,j,l) + & *(0.5d0+sign(0.5d0,so2s(i,j,l)-epsilon)) + !do ip3 = 1, 10 + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! so2s(ip1,ip2,ip3) = so2sh(ip1,ip2,ip3) + ! end do + ! end do + !end do + SO2s(I,J,L) = SO2sh + adwashfrac = adwashfrac-SO2s_ADJ(i,j,l)*so2s(i,j,l) + SO2s_ADJ(i,j,l) = SO2s_ADJ(i,j,l)*(1.d0-washfrac) + if (tk .ge. 268.d0 .and. so2s(i,j,l) .gt. epsilon) then + !!! Upgrade to GCv8, no longer use this condition (dkh, 10/07/09) + !!!if (so2s(i,j,l) .lt. h2o2s(i,j,l)) then + !!! Upgrade to GCv8, now multiply so2s by final washfrac + !!!h2o2s(i,j,l) = h2o2s(i,j,l)-so2s(i,j,l) + h2o2s(i,j,l) = h2o2s(i,j,l)-so2s(i,j,l) * WASHFRAC + H2O2s_ADJ(i,j,l) = + &H2O2s_ADJ(i,j,l)*(0.5d0+sign(0.5d0,h2o2s(i,j,l)- + $epsilon)) + !!! Upgrade to GCv8, now multiply H2O2s_ADJ by WASHFRAC + !!!SO2s_ADJ(i,j,l) = SO2s_ADJ(i,j,l)-H2O2s_ADJ(i,j,l) + SO2s_ADJ(i,j,l) = SO2s_ADJ(i,j,l)-H2O2s_ADJ(i,j,l) * WASHFRAC + + !!! and add this line: + ADWASHFRAC = ADWASHFRAC-H2O2s_ADJ(i,j,l)*SO2s(i,j,l) + + !!!else + !!! H2O2s_ADJ(i,j,l) = 0.d0 + !!!endif + ! We don't need to recalculate the final WASHFRAC because + ! that value has been chekpted. + !washfrac = washfrach + !washfrac = so2loss*washfrac/so2s(i,j,l) + adwashfrac = adwashfrac*(0.5d0+sign(0.5d0,washfrac-0.d0)) + ! Here we need the original WASHFRAC, so restore using WASHFRAC_0 + !washfrac = washfrach + WASHFRAC = WASHFRAC_0(L) + adso2loss = adso2loss+adwashfrac*(washfrac/so2s(i,j,l)) + SO2s_ADJ(i,j,l) = SO2s_ADJ(i,j,l)-adwashfrac*(so2loss*washfrac/ + $(so2s(i,j,l)*so2s(i,j,l))) + adwashfrac = adwashfrac*(so2loss/so2s(i,j,l)) + !do ip3 = 1, 10 + ! do ip2 = 1, 10 + ! do ip1 = 1, 10 + ! h2o2s(ip1,ip2,ip3) = h2o2sh(ip1,ip2,ip3) + ! end do + ! end do + !end do + H2O2s(I,J,L) = H2O2sh + H2O2s_ADJ(i,j,l) = H2O2s_ADJ(i,j,l) + &+adso2loss*(0.5d0-sign(0.5d0,h2o2s(i, + $j,l)-so2s(i,j,l))) + SO2s_ADJ(i,j,l) = + &SO2s_ADJ(i,j,l)+adso2loss*(0.5d0+sign(0.5d0,h2o2s(i,j, + $l)-so2s(i,j,l))) + adso2loss = 0.d0 + else + adwashfrac = 0.d0 + endif + + !end + END SUBROUTINE ADWASHOUT_SO2 +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + +! +! SUBROUTINE RECALC_SOX_WETDEP( LS ) +!! +!!****************************************************************************** +!! ! Subroutine RECALC_SOX_WETDEP is a copy of WETDEP that only acts on +!! SO2 and SO4. See WETDEP for notes. We only need to recompute values +!! of these two species in order to do adjoint of wetdep for convective precip +!! of SO2. (dkh, 10/23/05) +!! +!! NOTEs +!! (1 ) Call GET_NN which returns the NN values for SO2 and SO4. (dkh, 10/23/05) +!! (2 ) Updated to v8-02-01, adj_group (dkh, ks, mak, cs 06/08/09) +!! +!!****************************************************************************** +!! +! ! References to F90 modules +! USE DAO_MOD, ONLY : BXHEIGHT +! USE DIAG_MOD, ONLY : AD16, AD17, AD18 +! USE DIAG_MOD, ONLY : CT16, CT17, CT18, AD39 +! USE ERROR_MOD, ONLY : GEOS_CHEM_STOP, IT_IS_NAN +! USE LOGICAL_MOD, ONLY : LDYNOCEAN +! USE OCEAN_MERCURY_MOD, ONLY : ADD_Hg2_WD +! USE TIME_MOD, ONLY : GET_TS_DYN +! USE TRACER_MOD, ONLY : ITS_A_MERCURY_SIM, STT +! USE TRACERID_MOD, ONLY : IDTSO2, IDTSO4, IS_Hg2 +! +! IMPLICIT NONE +! +!# include "CMN_SIZE" ! Size parameters +!# include "CMN_DIAG" ! Diagnostic arrays and switches +! +! ! Arguments +! LOGICAL, INTENT(IN) :: LS +! +! ! Local Variables +! LOGICAL, SAVE :: FIRST = .TRUE. +! LOGICAL :: IS_Hg +! LOGICAL :: AER +! +! INTEGER :: I, IDX, J, L, N, NN +! +! REAL*8 :: Q, QDOWN, DT, DT_OVER_TAU +! REAL*8 :: K, K_MIN, K_RAIN, RAINFRAC +! REAL*8 :: F, FTOP, F_PRIME, WASHFRAC +! REAL*8 :: LOST, GAINED, MASS_WASH, MASS_NOWASH +! REAL*8 :: ALPHA, ALPHA2, WETLOSS, TMP +! +! ! DSTT is the accumulator array of rained-out +! ! soluble tracer for a given (I,J) column +! REAL*8 :: DSTT(NSOL,LLPAR,IIPAR,JJPAR) +! +! !================================================================= +! ! WETDEP begins here! +! ! +! ! (1) I n i t i a l i z e V a r i a b l e s +! !================================================================= +! +! ! Is this a mercury simulation with dynamic online ocean? +! IS_Hg = ( ITS_A_MERCURY_SIM() .and. LDYNOCEAN ) +! +! ! Dynamic timestep [s] +! DT = GET_TS_DYN() * 60d0 +! +! ! Select index for diagnostic arrays -- will archive either +! ! large-scale or convective rainout/washout fractions +! IF ( LS ) THEN +! IDX = 1 +! ELSE +! IDX = 2 +! ENDIF +! +! !================================================================= +! ! (2) L o o p O v e r (I, J) S u r f a c e B o x e s +! ! +! ! Process rainout / washout by columns. +! !================================================================= +! +!#if !defined( SGI_MIPS ) +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, FTOP, ALPHA ) +!!$OMP+PRIVATE( ALPHA2, F, F_PRIME, GAINED, K_RAIN ) +!!$OMP+PRIVATE( LOST, MASS_NOWASH, MASS_WASH, RAINFRAC, WASHFRAC ) +!!$OMP+PRIVATE( WETLOSS, L, Q, NN, N ) +!!$OMP+PRIVATE( QDOWN, AER, TMP ) +!!$OMP+SCHEDULE( DYNAMIC ) +!#endif +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Zero FTOP +! FTOP = 0d0 +! +! ! Zero accumulator array +! DO L = 1, LLPAR +! DO NN = 1, NSOL +! DSTT(NN,L,I,J) = 0d0 +! ENDDO +! ENDDO +! +! !============================================================== +! ! (3) R a i n o u t F r o m T o p L a y e r (L = LLPAR) +! ! +! ! Assume that rainout is happening in the top layer if +! ! QQ(LLPAR,I,J) > 0. In other words, if any precipitation +! ! forms in grid box (I,J,LLPAR), assume that all of it falls +! ! down to lower levels. +! ! +! ! Soluble gases/aerosols are incorporated into the raindrops +! ! and are completely removed from grid box (I,J,LLPAR). There +! ! is no evaporation and "resuspension" of aerosols during a +! ! rainout event. +! ! +! ! For large-scale (a.k.a. stratiform) precipitation, the first +! ! order rate constant for rainout in the grid box (I,J,L=LLPAR) +! ! (cf. Eq. 12, Jacob et al, 2000) is given by: +! ! +! ! Q +! ! K_RAIN = K_MIN + ------- [units: s^-1] +! ! L + W +! ! +! ! and the areal fraction of grid box (I,J,L=LLPAR) that +! ! is actually experiencing large-scale precipitation +! ! (cf. Eq. 11, Jacob et al, 2000) is given by: +! ! +! ! Q +! ! F' = ------------------- [unitless] +! ! K_RAIN * ( L + W ) +! ! +! ! Where: +! ! +! ! K_MIN = minimum value for K_RAIN +! ! = 1.0e-4 [s^-1] +! ! +! ! L + W = condensed water content in cloud +! ! = 1.5e-6 [cm3 H2O/cm3 air] +! ! +! ! Q = QQ = rate of precipitation formation +! ! [ cm3 H2O / cm3 air / s ] +! ! +! ! For convective precipitation, K_RAIN = 5.0e-3 [s^-1], and the +! ! expression for F' (cf. Eq. 13, Jacob et al, 2000) becomes: +! ! +! ! { DT } +! ! FMAX * Q * MIN{ --- , 1.0 } +! ! { TAU } +! ! F' = ------------------------------------------------------ +! ! { DT } +! ! Q * MIN{ --- , 1.0 } + FMAX * K_RAIN * ( L + W ) +! ! { TAU } +! ! +! ! Where: +! ! +! ! Q = QQ = rate of precipitation formation +! ! [cm3 H2O/cm3 air/s] +! ! +! ! FMAX = maximum value for F' +! ! = 0.3 +! ! +! ! DT = dynamic time step from the CTM [s] +! ! +! ! TAU = duration of rainout event +! ! = 1800 s (30 min) +! ! +! ! L + W = condensed water content in cloud +! ! = 2.0e-6 [cm3 H2O/cm3 air] +! ! +! ! K_RAIN and F' are needed to compute the fraction of tracer +! ! in grid box (I,J,L=LLPAR) lost to rainout. This is done in +! ! module routine RAINOUT. +! !============================================================== +! +! ! Zero variables for this level +! ALPHA = 0d0 +! ALPHA2 = 0d0 +! F = 0d0 +! F_PRIME = 0d0 +! GAINED = 0d0 +! K_RAIN = 0d0 +! LOST = 0d0 +! Q = 0d0 +! QDOWN = 0d0 +! MASS_NOWASH = 0d0 +! MASS_WASH = 0d0 +! RAINFRAC = 0d0 +! WASHFRAC = 0d0 +! WETLOSS = 0d0 +! +! ! Start at the top of the atmosphere +! L = LLPAR +! +! ! If precip forms at (I,J,L), assume it all rains out +! IF ( QQ(L,I,J) > 0d0 ) THEN +! +! ! Q is the new precip that is forming within grid box (I,J,L) +! Q = QQ(L,I,J) +! +! ! Compute K_RAIN and F' for either large-scale or convective +! ! precipitation (cf. Eqs. 11-13, Jacob et al, 2000) +! IF ( LS ) THEN +! K_RAIN = LS_K_RAIN( Q ) +! F_PRIME = LS_F_PRIME( Q, K_RAIN ) +! ELSE +! K_RAIN = 1.5d-3 +! F_PRIME = CONV_F_PRIME( Q, K_RAIN, DT ) +! ENDIF +! +! ! Set F = F', since there is no FTOP at L = LLPAR +! F = F_PRIME +! +! ! Only compute rainout if F > 0. +! ! This helps to eliminate unnecessary CPU cycles. +! IF ( F > 0d0 ) THEN +! +! ! ND16 diagnostic...save LS and Conv fractions +! IF ( ND16 > 0 .and. L <= LD16 ) THEN +! AD16(I,J,L,IDX) = AD16(I,J,L,IDX) + F +! CT16(I,J,L,IDX) = CT16(I,J,L,IDX) + 1 +! ENDIF +! +! ! ND17 diagnostic...increment counter +! IF ( ND17 > 0 .and. L <= LD17 ) THEN +! CT17(I,J,L,IDX) = CT17(I,J,L,IDX) + 1 +! ENDIF +! +! ! Loop over soluble tracers and/or aerosol tracers +! !DO NN = 1, NSOL +! ! Loop over just SO2 then SO4. (dkh, 10/23/05) +! DO NNN = 1, 2 +! NN = GET_NN(NNN) +! N = IDWETD(NN) +! +! ! Call subroutine RAINOUT to compute the fraction +! ! of tracer lost to rainout in grid box (I,J,L=LLPAR) +! CALL RAINOUT( I, J, L, N, K_RAIN, DT, F, RAINFRAC ) +! +! ! WETLOSS is the amount of soluble tracer +! ! lost to rainout in grid box (I,J,L=LLPAR) +! WETLOSS = STT(I,J,L,N) * RAINFRAC +! +! ! Remove rainout losses in grid box (I,J,L=LLPAR) from STT +! STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS +! +! ! DSTT is an accumulator array for rained-out tracers. +! ! The tracers in DSTT are in the liquid phase and will +! ! precipitate to the levels below until a washout occurs. +! ! Initialize DSTT at (I,J,L=LLPAR) with WETLOSS. +! DSTT(NN,L,I,J) = WETLOSS +! +! ! ND17 diagnostic...LS and conv rainout fractions [unitless] +! IF ( ND17 > 0 .and. L <= LD17 ) THEN +! AD17(I,J,L,NN,IDX) = +! & AD17(I,J,L,NN,IDX) + RAINFRAC / F +! ENDIF +! +! ! ND39 diag - save rainout losses in [kg/s] +! IF ( ND39 > 0 .and. L <= LD39 ) THEN +! AD39(I,J,L,NN) = AD39(I,J,L,NN) + WETLOSS / DT +! ENDIF +! +! ! Negative tracer...call subroutine SAFETY +! IF ( STT(I,J,L,N) < 0d0 ) THEN +! CALL SAFETY( I, J, L, N, 3, +! & LS, PDOWN(L,I,J), +! & QQ(L,I,J), ALPHA, +! & ALPHA2, RAINFRAC, +! & WASHFRAC, MASS_WASH, +! & MASS_NOWASH, WETLOSS, +! & GAINED, LOST, +! & DSTT(NN,:,I,J), STT(I,J,:,N) ) +! ENDIF +! ENDDO +! ENDIF +! +! ! Save FTOP for the next lower level +! FTOP = F +! ENDIF +! +! !============================================================== +! ! (4) R a i n o u t i n t h e M i d d l e L e v e l s +! ! +! ! Rainout occurs when there is more precipitation in grid box +! ! (I,J,L) than in grid box (I,J,L+1). In other words, rainout +! ! occurs when the amount of rain falling through the bottom of +! ! grid box (I,J,L) is more than the amount of rain coming in +! ! through the top of grid box (I,J,L). +! ! +! ! Thus ( PDOWN(L,I,J) > 0 and QQ(L,I,J) > 0 ) is the +! ! criterion for Rainout. +! ! +! ! Soluble gases/aerosols are incorporated into the raindrops +! ! and are completely removed from grid box (I,J,L). There is +! ! no evaporation and "resuspension" of aerosols during a +! ! rainout event. +! ! +! ! Compute K_RAIN and F' for grid box (I,J,L) exactly as +! ! described above in Section (4). K_RAIN and F' depend on +! ! whether we have large-scale or convective precipitation. +! ! +! ! F' is the areal fraction of grid box (I,J,L) that is +! ! precipitating. However, the effective area of precipitation +! ! that layer L sees (cf. Eqs. 11-13, Jacob et al, 2000) is +! ! given by: +! ! +! ! F = MAX( F', FTOP ) +! ! +! ! where FTOP = F' at grid box (I,J,L+1), that is, for the grid +! ! box immediately above the current grid box. +! ! +! ! Therefore, the effective area of precipitation in grid box +! ! (I,J,L) depends on the area of precipitation in the grid +! ! boxes above it. +! ! +! ! Having computed K_RAIN and F for grid box (I,J,L), call +! ! routine RAINOUT to compute the fraction of tracer lost to +! ! rainout conditions. +! !============================================================== +! DO L = LLPAR-1, 2, -1 +! +! ! Zero variables for each level +! ALPHA = 0d0 +! ALPHA2 = 0d0 +! F = 0d0 +! F_PRIME = 0d0 +! GAINED = 0d0 +! K_RAIN = 0d0 +! LOST = 0d0 +! MASS_NOWASH = 0d0 +! MASS_WASH = 0d0 +! Q = 0d0 +! QDOWN = 0d0 +! RAINFRAC = 0d0 +! WASHFRAC = 0d0 +! WETLOSS = 0d0 +! +! ! Rainout criteria +! IF ( PDOWN(L,I,J) > 0d0 .and. QQ(L,I,J) > 0d0 ) THEN +! +! ! Q is the new precip that is forming within grid box (I,J,L) +! Q = QQ(L,I,J) +! +! ! Compute K_RAIN and F' for either large-scale or convective +! ! precipitation (cf. Eqs. 11-13, Jacob et al, 2000) +! IF ( LS ) THEN +! K_RAIN = LS_K_RAIN( Q ) +! F_PRIME = LS_F_PRIME( Q, K_RAIN ) +! ELSE +! K_RAIN = 1.5d-3 +! F_PRIME = CONV_F_PRIME( Q, K_RAIN, DT ) +! ENDIF +! +! ! F is the effective area of precip seen by grid box (I,J,L) +! F = MAX( F_PRIME, FTOP ) +! +! ! Only compute rainout if F > 0. +! ! This helps to eliminate unnecessary CPU cycles. +! IF ( F > 0d0 ) THEN +! +! ! ND16 diagnostic...save F +! IF ( ND16 > 0 .and. L <= LD16 ) THEN +! AD16(I,J,L,IDX) = AD16(I,J,L,IDX) + F +! CT16(I,J,L,IDX) = CT16(I,J,L,IDX) + 1 +! ENDIF +! +! ! ND17 diagnostic...increment counter +! IF ( ND17 > 0 .and. L <= LD17 ) THEN +! CT17(I,J,L,IDX) = CT17(I,J,L,IDX) + 1 +! ENDIF +! +! ! Loop over soluble tracers and/or aerosol tracers +! !DO NN = 1, NSOL +! ! Loop over just SO2 then SO4. (dkh, 10/23/05) +! DO NNN = 1, 2 +! NN = GET_NN(NNN) +! N = IDWETD(NN) +! +! ! Call subroutine RAINOUT to comptue the fraction +! ! of tracer lost to rainout in grid box (I,J,L) +! CALL RAINOUT( I, J, L, N, K_RAIN, DT, F, RAINFRAC ) +! +! ! WETLOSS is the amount of tracer in grid box +! ! (I,J,L) that is lost to rainout. +! WETLOSS = STT(I,J,L,N) * RAINFRAC +! +! ! For the mercury simulation, we need to archive the +! ! amt of Hg2 [kg] that is scavenged out of the column. +! ! Also for tagged Hg2. (sas, cdh, bmy, 1/6/06) +! IF ( IS_Hg .and. IS_Hg2( N ) ) THEN +! CALL ADD_Hg2_WD( I, J, N, WETLOSS ) +! ENDIF +! +! ! Subtract the rainout loss in grid box (I,J,L) from STT +! STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS +! +! ! Add to DSTT the tracer lost to rainout in grid box +! ! (I,J,L) plus the tracer lost to rainout from grid box +! ! (I,J,L+1), which has by now precipitated down into +! ! grid box (I,J,L). DSTT will continue to accumulate +! ! rained out tracer in this manner until a washout +! ! event occurs. +! DSTT(NN,L,I,J) = DSTT(NN,L+1,I,J) + WETLOSS +! +! ! ND17 diagnostic...rainout fractions [unitless] +! IF ( ND17 > 0 .and. L <= LD17 ) THEN +! AD17(I,J,L,NN,IDX) = +! & AD17(I,J,L,NN,IDX) + RAINFRAC / F +! ENDIF +! +! ! ND39 diag -- save rainout losses in [kg/s] +! IF ( ND39 > 0 .and. L <= LD39 ) THEN +! AD39(I,J,L,NN) = AD39(I,J,L,NN) + WETLOSS / DT +! ENDIF +! +! ! Negative tracer...call subroutine SAFETY +! IF ( STT(I,J,L,N) < 0d0 .or. +! & IT_IS_NAN( STT(I,J,L,N) ) ) THEN +! CALL SAFETY( I, J, L, N, 4, +! & LS, PDOWN(L,I,J), +! & QQ(L,I,J), ALPHA, +! & ALPHA2, RAINFRAC, +! & WASHFRAC, MASS_WASH, +! & MASS_NOWASH, WETLOSS, +! & GAINED, LOST, +! & DSTT(NN,:,I,J), STT(I,J,:,N) ) +! ENDIF +! ENDDO +! ENDIF +! +! ! Save FTOP for next level +! FTOP = F +! +! !============================================================== +! ! (5) W a s h o u t i n t h e m i d d l e l e v e l s +! ! +! ! Washout occurs when we have evaporation (or no precipitation +! ! at all) at grid box (I,J,L), but have rain coming down from +! ! grid box (I,J,L+1). +! ! +! ! Thus PDOWN(L,I,J) > 0 and QQ(L,I,J) <= 0 is the criterion +! ! for Washout. Also recall that QQ(L,I,J) < 0 denotes +! ! evaporation and not precipitation. +! ! +! ! A fraction ALPHA of the raindrops falling down from grid +! ! box (I,J,L+1) to grid box (I,J,L) will evaporate along the +! ! way. ALPHA is given by: +! ! +! ! precip leaving (I,J,L+1) - precip leaving (I,J,L) +! ! ALPHA = --------------------------------------------------- +! ! precip leaving (I,J,L+1) +! ! +! ! +! ! -QQ(L,I,J) * DZ(I,J,L) +! ! = -------------------------- +! ! PDOWN(L+1,I,J) +! ! +! ! We assume that a fraction ALPHA2 = 0.5 * ALPHA of the +! ! previously rained-out aerosols and HNO3 coming down from +! ! level (I,J,L+1) will evaporate and re-enter the atmosphere +! ! in the gas phase in grid box (I,J,L). This process is +! ! called "resuspension". +! ! +! ! For non-aerosol species, the amount of previously rained +! ! out mass coming down from grid box (I,J,L+1) to grid box +! ! (I,J,L) is figured into the total mass available for +! ! washout in grid box (I,J,L). We therefore do not have to +! ! use the fraction ALPHA2 to compute the resuspension. +! ! +! ! NOTE from Hongyu Liu about ALPHA (hyl, 2/29/00) +! ! ============================================================= +! ! If our QQ field was perfect, the evaporated amount in grid +! ! box (I,J,L) would be at most the total rain amount coming +! ! from above (i.e. PDOWN(I,J,L+1) ). But this is not true for +! ! the MOISTQ field we are using. Sometimes the evaporation in +! ! grid box (I,J,L) can be more than the rain amount from above. +! ! The reason is our "evaporation" also includes the effect of +! ! cloud detrainment. For now we cannot find a way to +! ! distinguish betweeen the two. We then decided to release +! ! aerosols in both the detrained air and the evaporated air. +! ! +! ! Therefore, we should use this term in the numerator: +! ! +! ! -QQ(I,J,L) * BXHEIGHT(I,J,L) +! ! +! ! instead of the term: +! ! +! ! PDOWN(L+1)-PDOWN(L) +! ! +! ! Recall that in make_qq.f we have restricted PDOWN to +! ! positive values, otherwise, QQ would be equal to +! ! PDOWN(L+1)-PDOWN(L). +! !============================================================== +! ELSE IF ( PDOWN(L,I,J) > 0d0 .and. QQ(L,I,J) <= 0d0 ) THEN +! +! ! QDOWN is the precip leaving thru the bottom of box (I,J,L) +! ! Q is the new precip that is forming within box (I,J,L) +! QDOWN = PDOWN(L,I,J) +! Q = QQ(L,I,J) +! +! ! Since no precipitation is forming within grid box (I,J,L), +! ! F' = 0, and F = MAX( F', FTOP ) reduces to F = FTOP. +! F = FTOP +! +! ! Only compute washout if F > 0. +! ! This helps to eliminate needless CPU cycles. +! IF ( F > 0d0 ) THEN +! +! ! ND16 diagnostic...save F (fraction of grid box raining) +! IF ( ND16 > 0d0 .and. L <= LD16 ) THEN +! AD16(I,J,L,IDX) = AD16(I,J,L,IDX) + F +! CT16(I,J,L,IDX) = CT16(I,J,L,IDX) + 1 +! ENDIF +! +! ! ND18 diagnostic...increment counter +! IF ( ND18 > 0 .and. L <= LD18 ) THEN +! CT18(I,J,L,IDX) = CT18(I,J,L,IDX) + 1 +! ENDIF +! +! ! Loop over soluble tracers and/or aerosol tracers +! !DO NN = 1, NSOL +! ! Loop over just SO2 then SO4. (dkh, 10/23/05) +! DO NNN = 1, 2 +! NN = GET_NN(NNN) +! N = IDWETD(NN) +! +! ! Call WASHOUT to compute the fraction of +! ! tracer lost to washout in grid box (I,J,L) +! CALL WASHOUT( I, J, L, N, +! & QDOWN, DT, F, WASHFRAC, AER ) +! +! !===================================================== +! ! Washout of aerosol tracers -- +! ! this is modeled as a kinetic process +! !===================================================== +! IF ( AER ) THEN +! +! ! ALPHA is the fraction of the raindrops that +! ! re-evaporate when falling from (I,J,L+1) to (I,J,L) +! ALPHA = ( ABS( Q ) * BXHEIGHT(I,J,L) * 100d0 ) / +! & PDOWN(L+1,I,J) +! +! ! ALPHA2 is the fraction of the rained-out aerosols +! ! that gets resuspended in grid box (I,J,L) +! ALPHA2 = 0.5d0 * ALPHA +! +! ! GAINED is the rained out aerosol coming down from +! ! grid box (I,J,L+1) that will evaporate and re-enter +! ! the atmosphere in the gas phase in grid box (I,J,L). +! GAINED = DSTT(NN,L+1,I,J) * ALPHA2 +! +! ! Amount of aerosol lost to washout in grid box +! ! (qli, bmy, 10/29/02) +! WETLOSS = STT(I,J,L,N) * WASHFRAC - GAINED +! +! ! Remove washout losses in grid box (I,J,L) from STT. +! ! Add the aerosol that was reevaporated in (I,J,L). +! ! SO2 in sulfate chemistry is wet-scavenged on the +! ! raindrop and converted to SO4 by aqeuous chem. +! ! If evaporation occurs then SO2 comes back as SO4 +! ! (rjp, bmy, 3/23/03) +! IF ( N == IDTSO2 ) THEN +! STT(I,J,L,IDTSO4) = STT(I,J,L,IDTSO4) +! & + GAINED * 96D0 / 64D0 +! +! STT(I,J,L,N) = STT(I,J,L,N) * +! & ( 1d0 - WASHFRAC ) +! ELSE +! STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS +! ENDIF +! +! ! LOST is the rained out aerosol coming down from +! ! grid box (I,J,L+1) that will remain in the liquid +! ! phase in grid box (I,J,L) and will NOT re-evaporate. +! LOST = DSTT(NN,L+1,I,J) - GAINED +! +! ! Add the washed out tracer from grid box (I,J,L) to +! ! DSTT. Also add the amount of tracer coming down +! ! from grid box (I,J,L+1) that does NOT re-evaporate. +! DSTT(NN,L,I,J) = DSTT(NN,L+1,I,J) + WETLOSS +! ! Maybe it should be this ???? +! !DSTT(NN,L,I,J) = LOST + WETLOSS +! +! ! ND18 diagnostic...divide washout fraction by F +! IF ( ND18 > 0 .and. L <= LD18 ) THEN +! AD18(I,J,L,NN,IDX) = +! & AD18(I,J,L,NN,IDX) + WASHFRAC / F +! ENDIF +! +! !===================================================== +! ! Washout of non-aerosol tracers +! ! This is modeled as an equilibrium process +! !===================================================== +! ELSE +! +! ! MASS_NOWASH is the amount of non-aerosol tracer in +! ! grid box (I,J,L) that is NOT available for washout. +! MASS_NOWASH = ( 1d0 - F ) * STT(I,J,L,N) +! +! ! MASS_WASH is the total amount of non-aerosol tracer +! ! that is available for washout in grid box (I,J,L). +! ! It consists of the mass in the precipitating +! ! part of box (I,J,L), plus the previously rained-out +! ! tracer coming down from grid box (I,J,L+1). +! ! (Eq. 15, Jacob et al, 2000). +! MASS_WASH = ( F*STT(I,J,L,N) ) +DSTT(NN,L+1,I,J) +! +! ! WETLOSS is the amount of tracer mass in +! ! grid box (I,J,L) that is lost to washout. +! ! (Eq. 16, Jacob et al, 2000) +! WETLOSS = MASS_WASH * WASHFRAC -DSTT(NN,L+1,I,J) +! +! ! The tracer left in grid box (I,J,L) is what was +! ! in originally in the non-precipitating fraction +! ! of the box, plus MASS_WASH, less WETLOSS. +! STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS +! +! ! Add washout losses in grid box (I,J,L) to DSTT +! DSTT(NN,L,I,J) = DSTT(NN,L+1,I,J) + WETLOSS +! +! ! For the mercury simulation, we need to archive the +! ! amt of Hg2 [kg] that is scavenged out of the column. +! ! Also for tagged Hg2. (sas, cdh, bmy, 1/6/06) +! IF ( IS_Hg .and. IS_Hg2( N ) ) THEN +! CALL ADD_Hg2_WD( I, J, N, WETLOSS ) +! ENDIF +! +! ! ND18 diagnostic...we don't have to divide the +! ! washout fraction by F since this is accounted for. +! IF ( ND18 > 0 .and. L <= LD18 ) THEN +! AD18(I,J,L,NN,IDX) = +! & AD18(I,J,L,NN,IDX) + WASHFRAC +! ENDIF +! ENDIF +! +! ! ND39 diag -- save rainout losses in [kg/s] +! IF ( ND39 > 0 .and. L <= LD39 ) THEN +! AD39(I,J,L,NN) = AD39(I,J,L,NN) + WETLOSS / DT +! ENDIF +! +! ! Negative tracer...call subroutine SAFETY +! IF ( STT(I,J,L,N) < 0d0 .or. +! & IT_IS_NAN( STT(I,J,L,N) ) ) THEN +! CALL SAFETY( I, J, L, N, 5, +! & LS, PDOWN(L,I,J), +! & QQ(L,I,J), ALPHA, +! & ALPHA2, RAINFRAC, +! & WASHFRAC, MASS_WASH, +! & MASS_NOWASH, WETLOSS, +! & GAINED, LOST, +! & DSTT(NN,:,I,J), STT(I,J,:,N) ) +! ENDIF +! ENDDO +! ENDIF +! +! ! Save FTOP for next level +! FTOP = F +! +! !=========================================================== +! ! (6) N o D o w n w a r d P r e c i p i t a t i o n +! ! +! ! If there is no precipitation leaving grid box (I,J,L), +! ! then set F, the effective area of precipitation in grid +! ! box (I,J,L), to zero. +! ! +! ! Also, all of the previously rained-out tracer that is now +! ! coming down from grid box (I,J,L+1) will evaporate and +! ! re-enter the atmosphere in the gas phase in grid box +! ! (I,J,L). This is called "resuspension". +! !=========================================================== +! ELSE IF ( ABS( PDOWN(L,I,J) ) < 1d-30 ) THEN +! +! ! No precipitation at grid box (I,J,L), thus F = 0 +! F = 0d0 +! +! ! Loop over soluble tracers and/or aerosol tracers +! !DO NN = 1, NSOL +! ! Loop over just SO2 then SO4. (dkh, 10/23/05) +! DO NNN = 1, 2 +! NN = GET_NN(NNN) +! N = IDWETD(NN) +! +! ! WETLOSS is the amount of tracer in grid box (I,J,L) +! ! that is lost to rainout. (qli, bmy, 10/29/02) +! WETLOSS = -DSTT(NN,L+1,I,J) +! +! ! For the mercury simulation, we need to archive the +! ! amt of Hg2 [kg] that is scavenged out of the column. +! ! Also for tagged Hg2. (sas, cdh, bmy, 1/6/06) +! IF ( IS_Hg .and. IS_Hg2( N ) ) THEN +! CALL ADD_Hg2_WD( I, J, N, WETLOSS ) +! ENDIF +! +! ! All of the rained-out tracer coming from grid box +! ! (I,J,L+1) goes back into the gas phase at (I,J,L) +! ! In evap, SO2 comes back as SO4 (rjp, bmy, 3/23/03) +! IF ( N == IDTSO2 ) THEN +! STT(I,J,L,IDTSO4) = STT(I,J,L,IDTSO4) +! & - ( WETLOSS * 96d0 / 64d0 ) +! ELSE +! STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS +! ENDIF +! +! ! There is nothing rained out/washed out in grid box +! ! (I,J,L), so set DSTT at grid box (I,J,L) to zero. +! DSTT(NN,L,I,J) = 0d0 +! +! ! ND39 diag -- save rainout losses in [kg/s] +! IF ( ND39 > 0 .and. L <= LD39 ) THEN +! AD39(I,J,L,NN) = AD39(I,J,L,NN) + WETLOSS / DT +! ENDIF +! +! ! Negative tracer...call subroutine SAFETY +! IF ( STT(I,J,L,N) < 0d0 ) THEN +! CALL SAFETY( I, J, L, N, 6, +! & LS, PDOWN(L,I,J), +! & QQ(L,I,J), ALPHA, +! & ALPHA2, RAINFRAC, +! & WASHFRAC, MASS_WASH, +! & MASS_NOWASH, WETLOSS, +! & GAINED, LOST, +! & DSTT(NN,:,I,J), STT(I,J,:,N) ) +! ENDIF +! ENDDO +! +! ! Save FTOP for next level +! FTOP = F +! ENDIF +! ENDDO +! +! !============================================================== +! ! (7) W a s h o u t i n L e v e l 1 +! ! +! ! Assume all of the tracer precipitating down from grid box +! ! (I,J,L=2) to grid box (I,J,L=1) gets washed out in grid box +! ! (I,J,L=1). +! !============================================================== +! +! ! Zero variables for this level +! ALPHA = 0d0 +! ALPHA2 = 0d0 +! F = 0d0 +! F_PRIME = 0d0 +! GAINED = 0d0 +! K_RAIN = 0d0 +! LOST = 0d0 +! MASS_NOWASH = 0d0 +! MASS_WASH = 0d0 +! Q = 0d0 +! QDOWN = 0d0 +! RAINFRAC = 0d0 +! WASHFRAC = 0d0 +! WETLOSS = 0d0 +! +! ! We are at the surface, set L = 1 +! L = 1 +! +! ! Washout at level 1 criteria +! IF ( PDOWN(L+1,I,J) > 0d0 ) THEN +! +! ! QDOWN is the precip leaving thru the bottom of box (I,J,L+1) +! QDOWN = PDOWN(L+1,I,J) +! +! ! Since no precipitation is forming within grid box (I,J,L), +! ! F' = 0, and F = MAX( F', FTOP ) reduces to F = FTOP. +! F = FTOP +! +! ! Only compute washout if F > 0. +! ! This helps to eliminate unnecessary CPU cycles. +! IF ( F > 0d0 ) THEN +! +! ! ND16 diagnostic...save F +! IF ( ND16 > 0 .and. L <= LD16 ) THEN +! AD16(I,J,L,IDX) = AD16(I,J,L,IDX) + F +! CT16(I,J,L,IDX) = CT16(I,J,L,IDX) + 1 +! ENDIF +! +! ! ND18 diagnostic...increment counter +! IF ( ND18 > 0 .and. L <= LD18 ) THEN +! CT18(I,J,L,IDX) = CT18(I,J,L,IDX) + 1 +! ENDIF +! +! ! Loop over soluble tracers and/or aerosol tracers +! !DO NN = 1, NSOL +! ! Loop over just SO2 then SO4. (dkh, 10/23/05) +! DO NNN = 1, 2 +! NN = GET_NN(NNN) +! N = IDWETD(NN) +! +! ! Call WASHOUT to compute the fraction of tracer +! ! in grid box (I,J,L) that is lost to washout. +! CALL WASHOUT( I, J, L, N, +! & QDOWN, DT, F, WASHFRAC, AER ) +! +! ! NOTE: for HNO3 and aerosols, there is an F factor +! ! already present in WASHFRAC. For other soluble +! ! gases, we need to multiply by the F (hyl, bmy, 10/27/00) +! IF ( AER ) THEN +! WETLOSS = STT(I,J,L,N) * WASHFRAC +! ELSE +! WETLOSS = STT(I,J,L,N) * WASHFRAC * F +! ENDIF +! +! ! Subtract WETLOSS from STT +! STT(I,J,L,N) = STT(I,J,L,N) - WETLOSS +! +! ! For the mercury simulation, we need to archive the +! ! amt of Hg2 [kg] that is scavenged out of the column. +! ! Also for tagged Hg2. (sas, cdh, bmy, 1/6/06) +! IF ( IS_Hg .and. IS_Hg2( N ) ) THEN +! CALL ADD_Hg2_WD( I, J, N, WETLOSS ) +! ENDIF +! +! ! ND18 diagnostic...LS and conv washout fractions [unitless] +! IF ( ND18 > 0 .and. L <= LD18 ) THEN +! +! ! Only divide WASHFRAC by F for aerosols, since +! ! for non-aerosols this is already accounted for +! IF ( AER ) THEN +! TMP = WASHFRAC / F +! ELSE +! TMP = WASHFRAC +! ENDIF +! +! AD18(I,J,L,NN,IDX) = AD18(I,J,L,NN,IDX) + TMP +! ENDIF +! +! ! ND39 diag -- save washout loss in [kg/s] +! IF ( ND39 > 0 .and. L <= LD39 ) THEN +! AD39(I,J,L,NN) = AD39(I,J,L,NN) + WETLOSS / DT +! ENDIF +! +! !----------------------------------------------------- +! ! Dirty kludge to prevent wet deposition from removing +! ! stuff from stratospheric boxes -- this can cause +! ! negative tracer (rvm, bmy, 6/21/00) +! ! +! IF ( STT(I,J,L,N) < 0d0 .and. L > 23 ) THEN +! WRITE ( 6, 101 ) I, J, L, N, 7 +! 101 FORMAT( 'WETDEP - STT < 0 at ', 3i4, +! & ' for tracer ', i4, 'in area ', i4 ) +! PRINT*, 'STT:', STT(I,J,:,N) +! STT(I,J,L,N) = 0d0 +! ENDIF +! !----------------------------------------------------- +! +! ! Negative tracer...call subroutine SAFETY +! IF ( STT(I,J,L,N) < 0d0 ) THEN +! CALL SAFETY( I, J, L, N, 7, +! & LS, PDOWN(L,I,J), +! & QQ(L,I,J), ALPHA, +! & ALPHA2, RAINFRAC, +! & WASHFRAC, MASS_WASH, +! & MASS_NOWASH, WETLOSS, +! & GAINED, LOST, +! & DSTT(NN,:,I,J), STT(I,J,:,N) ) +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! ENDDO +! ENDDO +!#if !defined( SGI_MIPS ) +!!$OMP END PARALLEL DO +!#endif +! +! ! Return to calling program +! END SUBROUTINE WETDEP +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_NN( NNN ) RESULT( NN ) +!! +!!****************************************************************************** +!! Function GET_NN returns the value of NN for SO2 or SO4. (dkh, 10/23/05) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) NNN (INTEGER) : Index of loop over SOX species +!! +!! Function value: +!! ============================================================================ +!! (2 ) NN (INTEGER) : Index of SOX species in IDWETD +!! +!! NOTES: +!! (1 ) Added by adj_group (dkh, ks, mak, cs 06/08/09) +!! +!!****************************************************************************** +!! +! ! Reference to f90 modules +! USE TRACERID_MOD, ONLY : IDTSO2, IDTSO4 +! +! ! Arguments +! INTEGER, INTENT(IN) :: NNN +! +! ! Function value +! INTEGER :: NN +! +! ! Local variables +! INTEGER :: N +! +! !================================================================== +! ! GET_NN begins here! +! !================================================================== +! +! SELECT CASE( NNN ) +! +! ! Look for NN coresponding to SO2 +! CASE ( 1 ) +! +! DO N = 1, NSOLMAX +! IF ( IDWETD( N ) == IDTSO2 ) THEN +! NN = N +! RETURN +! ENDIF +! ENDDO +! +! ! Look for NN coresponding to SO4 +! CASE ( 2 ) +! +! DO N = 1, NSOLMAX +! IF ( IDWETD( N ) == IDTSO4 ) THEN +! NN = N +! RETURN +! ENDIF +! ENDDO +! +! END SELECT +! +! ! Return +! END FUNCTION GET_NN +! +!!------------------------------------------------------------------------------ +! +! +! FUNCTION LS_K_RAIN( Q ) RESULT( K_RAIN ) +!! +!!****************************************************************************** +!! Function LS_K_RAIN computes K_RAIN, the first order rainout rate constant +!! for large-scale (a.k.a. stratiform) precipitation (bmy, 3/18/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) Q (REAL*8) : Rate of precip formation [cm3 H2O/cm3 air/s] +!! +!! Function value: +!! ============================================================================ +!! (2 ) K_RAIN (REAL*8) : 1st order rainout rate constant [s-1] +!! +!! NOTES: +!! (1 ) Now made into a MODULE routine since we cannot call internal routines +!! from w/in a parallel loop. Updated comments. (bmy, 3/18/04) +!!****************************************************************************** +!! +! ! Arguments +! REAL*8, INTENT(IN) :: Q +! +! ! Function value +! REAL*8 :: K_RAIN +! +! !================================================================== +! ! LS_K_RAIN begins here! +! !================================================================== +! +! ! Compute rainout rate constant K in s^-1 (Eq. 12, Jacob et al, 2000). +! ! 1.0d-4 = K_MIN, a minimum value for K_RAIN +! ! 1.5d-6 = L + W, the condensed water content (liq + ice) in the cloud +! K_RAIN = 1.0d-4 + ( Q / 1.5d-6 ) +! +! ! Return to WETDEP +! END FUNCTION LS_K_RAIN +! +!!------------------------------------------------------------------------------ +! +! FUNCTION LS_F_PRIME( Q, K_RAIN ) RESULT( F_PRIME ) +!! +!!****************************************************************************** +!! Function LS_F_PRIME computes F', the fraction of the grid box that is +!! precipitating during large scale (a.k.a. stratiform) precipitation. +!! (bmy, 3/18/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) Q (REAL*8) : Rate of precip formation [cm3 H2O/cm3 air/s] +!! (2 ) K_RAIN (REAL*8) : 1st order rainout rate constant [s-1] +!! +!! Function value: +!! ============================================================================ +!! (3 ) F_PRIME (REAL*8) : Fraction of grid box undergoing LS precip [unitless] +!! +!! NOTES: +!! (1 ) Now made into a MODULE routine since we cannot call internal routines +!! from w/in a parallel loop. Updated comments. (bmy, 3/18/04) +!!****************************************************************************** +!! +! ! Arguments +! REAL*8, INTENT(IN) :: Q, K_RAIN +! +! ! Function value +! REAL*8 :: F_PRIME +! +! !================================================================= +! ! LS_F_PRIME begins here! +! !================================================================= +! +! ! Compute F', the area of the grid box undergoing precipitation +! ! 1.5d-6 = L + W, the condensed water content [cm3 H2O/cm3 air] +! F_PRIME = Q / ( K_RAIN * 1.5d-6 ) +! +! ! Return to WETDEP +! END FUNCTION LS_F_PRIME +! +!!------------------------------------------------------------------------------ +! +! FUNCTION CONV_F_PRIME( Q, K_RAIN, DT ) RESULT( F_PRIME ) +!! +!!****************************************************************************** +!! Function CONV_F_PRIME computes F', the fraction of the grid box that is +!! precipitating during convective precipitation. (bmy, 3/18/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) Q (REAL*8) : Rate of precip formation [cm3 H2O/cm3 air/s] +!! (2 ) K_RAIN (REAL*8) : 1st order rainout rate constant [s-1] +!! (3 ) DT (REAL*8) : Wet deposition timestep [s] +!! +!! Function value: +!! ============================================================================ +!! (4 ) F_PRIME (REAL*8) : Frac. of grid box undergoing CONV precip [unitless] +!! +!! NOTES: +!! (1 ) Now made into a MODULE routine since we cannot call internal routines +!! from w/in a parallel loop. Updated comments. (bmy, 3/18/04) +!!****************************************************************************** +!! +! ! Arguments +! REAL*8, INTENT(IN) :: Q, K_RAIN, DT +! +! ! Local variables +! REAL*8 :: TIME +! +! ! Function value +! REAL*8 :: F_PRIME +! +! !================================================================= +! ! CONV_F_PRIME begins here! +! !================================================================= +! +! ! Assume the rainout event happens in 30 minutes (1800 s) +! ! Compute the minimum of DT / 1800s and 1.0 +! TIME = MIN( DT / 1800d0, 1d0 ) +! +! ! Compute F' for convective precipitation (Eq. 13, Jacob et al, 2000) +! ! 0.3 = FMAX, the maximum value of F' for convective precip +! ! 2d-6 = L + W, the condensed water content [cm3 H2O/cm3 air] +! F_PRIME = ( 0.3d0 * Q * TIME ) / +! & ( ( Q * TIME ) + ( 0.3d0 * K_RAIN * 2d-6 ) ) +! +! ! Return to WETDEP +! END FUNCTION CONV_F_PRIME +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE SAFETY( I, J, L, N, +! & A, LS, PDOWN, QQ, +! & ALPHA, ALPHA2, RAINFRAC, WASHFRAC, +! & MASS_WASH, MASS_NOWASH, WETLOSS, GAINED, +! & LOST, DSTT, STT ) +!! +!!****************************************************************************** +!! Subroutine SAFETY stops the run with debug output and an error message +!! if negative tracers are found. (bmy, 3/18/04) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) Q (REAL*8) : Rate of precip formation [cm3 H2O/cm3 air/s] +!! (2 ) K_RAIN (REAL*8) : 1st order rainout rate constant [s-1] +!! (3 ) DT (REAL*8) : Wet deposition timestep [s] +!! +!! Function value: +!! ============================================================================ +!! (4 ) F_PRIME (REAL*8) : Frac. of grid box undergoing CONV precip [unitless] +!! +!! NOTES: +!! (1 ) Now made into a MODULE routine since we cannot call internal routines +!! from w/in a parallel loop. Updated comments. (bmy, 3/18/04) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE ERROR_MOD, ONLY : GEOS_CHEM_STOP +! +!# include "CMN_SIZE" +! +! ! Arguments +! LOGICAL, INTENT(IN) :: LS +! INTEGER, INTENT(IN) :: I, J, L, N, A +! REAL*8, INTENT(IN) :: PDOWN, QQ, ALPHA, ALPHA2 +! REAL*8, INTENT(IN) :: RAINFRAC, WASHFRAC, MASS_WASH, MASS_NOWASH +! REAL*8, INTENT(IN) :: WETLOSS, GAINED, LOST, DSTT(LLPAR) +! REAL*8, INTENT(IN) :: STT(LLPAR) +! +! !================================================================= +! ! SAFETY begins here! +! !================================================================= +! +! ! Print line +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! +! ! Write error message and stop the run +! WRITE ( 6, 100 ) I, J, L, N, A +! 100 FORMAT( 'WETDEP - STT < 0 at ', 3i4, ' for tracer ', i4, +! & ' in area ', i4 ) +! +! PRINT*, 'LS : ', LS +! PRINT*, 'PDOWN : ', PDOWN +! PRINT*, 'QQ : ', QQ +! PRINT*, 'ALPHA : ', ALPHA +! PRINT*, 'ALPHA2 : ', ALPHA2 +! PRINT*, 'RAINFRAC : ', RAINFRAC +! PRINT*, 'WASHFRAC : ', WASHFRAC +! PRINT*, 'MASS_WASH : ', MASS_WASH +! PRINT*, 'MASS_NOWASH : ', MASS_NOWASH +! PRINT*, 'WETLOSS : ', WETLOSS +! PRINT*, 'GAINED : ', GAINED +! PRINT*, 'LOST : ', LOST +! PRINT*, 'DSTT(NN,:) : ', DSTT(:) +! PRINT*, 'STT(I,J,:N) : ', STT(:) +! +! ! Print line +! WRITE( 6, '(a)' ) REPEAT( '=', 79 ) +! +! ! Deallocate memory and stop +! CALL GEOS_CHEM_STOP +! +! ! Return to WETDEP +! END SUBROUTINE SAFETY +! +!!------------------------------------------------------------------------------ +! +! SUBROUTINE WETDEPID +!! +!!****************************************************************************** +!! Subroutine WETDEPID sets up the index array of soluble tracers used in +!! the WETDEP routine above (bmy, 11/8/02, 5/18/06) +!! +!! NOTES: +!! (1 ) Now references "tracerid_mod.f". Also references "CMN" in order to +!! pass variables NSRCX and NTRACE. (bmy, 11/8/02) +!! (2 ) Updated for carbon aerosol & dust tracers (rjp, bmy, 4/5/04) +!! (3 ) Updated for seasalt aerosol tracers. Also added fancy output. +!! (rjp, bec, bmy, 4/20/04) +!! (4 ) Updated for secondary organic aerosol tracers (bmy, 7/13/04) +!! (5 ) Now references N_TRACERS, TRACER_NAME, TRACER_MW_KG from +!! "tracer_mod.f". Removed reference to NSRCX. (bmy, 7/20/04) +!! (6 ) Updated for mercury aerosol tracers (eck, bmy, 12/9/04) +!! (7 ) Updated for AS, AHS, LET, NH4aq, SO4aq (cas, bmy, 12/20/04) +!! (8 ) Updated for SO4s, NITs (bec, bmy, 4/25/05) +!! (9 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!! (10) Now use IS_Hg2 and IS_HgP to determine if a tracer is a tagged Hg2 +!! or HgP tracer (bmy, 1/6/06) +!! (11) Now added SOG4 and SOA4 (dkh, bmy, 5/18/06) +!!****************************************************************************** +!! +! ! References To F90 modules +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE TRACER_MOD, ONLY : N_TRACERS, TRACER_NAME, TRACER_MW_G +! USE TRACERID_MOD, ONLY : IDTPB, IDTBE7, IDTHNO3, IDTH2O2 +! USE TRACERID_MOD, ONLY : IDTCH2O, IDTMP, IDTSO2, IDTSO4 +! USE TRACERID_MOD, ONLY : IDTSO4s, IDTSO4aq, IDTMSA, IDTNH3 +! USE TRACERID_MOD, ONLY : IDTNH4, IDTNH4aq, IDTNIT, IDTNITs +! USE TRACERID_MOD, ONLY : IDTAS, IDTAHS, IDTLET, IDTBCPI +! USE TRACERID_MOD, ONLY : IDTOCPI, IDTBCPO, IDTOCPO, IDTDST1 +! USE TRACERID_MOD, ONLY : IDTDST2, IDTDST3, IDTDST4, IDTSALA +! USE TRACERID_MOD, ONLY : IDTSALC, IDTALPH, IDTLIMO, IDTALCO +! USE TRACERID_MOD, ONLY : IDTSOG1, IDTSOG2, IDTSOG3, IDTSOG4 +! USE TRACERID_MOD, ONLY : IDTSOA1, IDTSOA2, IDTSOA3, IDTSOA4 +! USE TRACERID_MOD, ONLY : IS_Hg2, IS_HgP +! USE TRACERID_MOD, ONLY : IDTGLYX, IDTMGLY, IDTGLYC +! USE TRACERID_MOD, ONLY : IDTSOAG, IDTSOAM +! +!# include "CMN_SIZE" ! Size parameters +! +! ! Local variables +! INTEGER :: N, NN +! +! !================================================================= +! ! WETDEPID begins here! +! !================================================================= +! +! ! Zero NSOL +! NSOL = 0 +! +! ! Sort soluble tracers into IDWETD +! DO N = 1, N_TRACERS +! +! !----------------------------- +! ! Rn-Pb-Be tracers +! !----------------------------- +! IF ( N == IDTPB ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTPB +! +! ELSE IF ( N == IDTBE7 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTBE7 +! +! !----------------------------- +! ! Full chemistry tracers +! !----------------------------- +! ELSE IF ( N == IDTHNO3 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTHNO3 +! +! ELSE IF ( N == IDTH2O2 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTH2O2 +! +! ELSE IF ( N == IDTCH2O ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTCH2O +! +! ELSE IF ( N == IDTMP ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTMP +! +! ELSE IF ( N == IDTGLYX ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTGLYX +! +! ELSE IF ( N == IDTMGLY ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTMGLY +! +! ELSE IF ( N == IDTGLYC ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTGLYC +! +! !----------------------------- +! ! Sulfate aerosol tracers +! !----------------------------- +! ELSE IF ( N == IDTSO2 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSO2 +! +! ELSE IF ( N == IDTSO4 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSO4 +! +! ELSE IF ( N == IDTSO4s ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSO4s +! +! ELSE IF ( N == IDTMSA ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTMSA +! +! ELSE IF ( N == IDTNH3 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTNH3 +! +! ELSE IF ( N == IDTNH4 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTNH4 +! +! ELSE IF ( N == IDTNIT ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTNIT +! +! ELSE IF ( N == IDTNITs ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTNITs +! +! !----------------------------- +! ! Crystal & Aqueous aerosols +! !----------------------------- +! ELSE IF ( N == IDTAS ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTAS +! +! ELSE IF ( N == IDTAHS ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTAHS +! +! ELSE IF ( N == IDTLET ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTLET +! +! ELSE IF ( N == IDTNH4aq ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTNH4aq +! +! ELSE IF ( N == IDTSO4aq ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSO4aq +! +! !----------------------------- +! ! Carbon & SOA aerosol tracers +! !----------------------------- +! ELSE IF ( N == IDTBCPI ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTBCPI +! +! ELSE IF ( N == IDTOCPI ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTOCPI +! +! ELSE IF ( N == IDTBCPO ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTBCPO +! +! ELSE IF ( N == IDTOCPO ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTOCPO +! +! ELSE IF ( N == IDTALPH ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTALPH +! +! ELSE IF ( N == IDTLIMO ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTLIMO +! +! ELSE IF ( N == IDTALCO ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTALCO +! +! ELSE IF ( N == IDTSOG1 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSOG1 +! +! ELSE IF ( N == IDTSOG2 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSOG2 +! +! ELSE IF ( N == IDTSOG3 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSOG3 +! +! ELSE IF ( N == IDTSOG4 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSOG4 +! +! ELSE IF ( N == IDTSOA1 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSOA1 +! +! ELSE IF ( N == IDTSOA2 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSOA2 +! +! ELSE IF ( N == IDTSOA3 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSOA3 +! +! ELSE IF ( N == IDTSOA4 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSOA4 +! +! ELSE IF ( N == IDTSOAG ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSOAG +! +! ELSE IF ( N == IDTSOAM ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSOAM +! +! !----------------------------- +! ! Dust aerosol tracers +! !----------------------------- +! ELSE IF ( N == IDTDST1 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTDST1 +! +! ELSE IF ( N == IDTDST2 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTDST2 +! +! ELSE IF ( N == IDTDST3 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTDST3 +! +! ELSE IF ( N == IDTDST4 ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTDST4 +! +! !----------------------------- +! ! Seasalt aerosol tracers +! !----------------------------- +! ELSE IF ( N == IDTSALA ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSALA +! +! ELSE IF ( N == IDTSALC ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = IDTSALC +! +! !----------------------------- +! ! Total and tagged Hg tracers +! !----------------------------- +! ELSE IF ( IS_Hg2( N ) ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = N +! +! ELSE IF ( IS_HgP( N ) ) THEN +! NSOL = NSOL + 1 +! IDWETD(NSOL) = N +! +! ENDIF +! ENDDO +! +! ! Error check: Make sure that NSOL is less than NSOLMAX +! IF ( NSOL > NSOLMAX ) THEN +! CALL ERROR_STOP( 'NSOL > NSOLMAX!', 'WETDEPID (wetscav_mod.f)') +! ENDIF +! +! ! Also check to see if NSOL is larger than the maximum +! ! number of soluble tracers for a particular simulation +! IF ( NSOL > GET_WETDEP_NMAX() ) THEN +! CALL ERROR_STOP( 'NSOL > NMAX', 'WETDEPID (wetscav_mod.f)') +! ENDIF +! +! !================================================================= +! ! Echo list of soluble tracers to the screen +! !================================================================= +! WRITE( 6, '(/,a,/)' ) 'WETDEPID: List of soluble tracers: ' +! WRITE( 6, '(a) ' ) ' # Name Tracer Mol Wt' +! WRITE( 6, '(a)' ) ' Number g/mole' +! WRITE( 6, '(a)' ) REPEAT( '-', 36 ) +! +! DO NN = 1, NSOL +! N = IDWETD(NN) +! WRITE( 6, '(i3,3x,a14,3x,i3,3x,f6.1)' ) +! & NN, TRIM( TRACER_NAME(N) ), N, TRACER_MW_G(N) +! ENDDO +! +! ! Return to calling program +! END SUBROUTINE WETDEPID +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_WETDEP_NMAX() RESULT ( NMAX ) +!! +!!****************************************************************************** +!! Function GET_WETDEP_NMAX returns the maximum number of soluble tracers +!! for a given type of simulation. Primarily used for allocation of +!! diagnostic arrays. (bmy, 12/2/02, 5/18/06) +!! +!! NOTES: +!! (1 ) Modified to include carbon & dust aerosol tracers (rjp, bmy, 4/5/04) +!! (2 ) Modified to include seasalt aerosol tracers (rjp, bec, bmy, 4/20/04) +!! (3 ) Modified to include 2ndary organic aerosol tracers (rjp, bmy, 7/13/04) +!! (4 ) Now references ITS_A_FULLCHEM_SIM, ITS_AN_AEROSOL_SIM, and +!! ITS_A_RnPbBe_SIM from "tracer_mod.f". Now references LCARB, LDUST, +!! LSOA, LSSALT, LSULF from "logical_mod.f". (bmy, 7/20/04) +!! (5 ) Modified to include mercury aerosol tracers (eck, bmy, 12/14/04) +!! (6 ) Modified for AS, AHS, LET, NH4aq, SO4aq (cas, bmy, 12/20/04) +!! (7 ) Modified for SO4s, NITs (bec, bmy, 4/25/05) +!! (8 ) Modified for SOG4, SOA4 (dkh, bmy, 5/18/06) +!!****************************************************************************** +!! +! ! References to F90 modules +! USE LOGICAL_MOD, ONLY : LCARB, LDUST, LSOA +! USE LOGICAL_MOD, ONLY : LSSALT, LSULF, LSPLIT, LCRYST +! USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_AN_AEROSOL_SIM +! USE TRACER_MOD, ONLY : ITS_A_RnPbBe_SIM, ITS_A_MERCURY_SIM +! USE TRACERID_MOD, ONLY : IDTSOAG, IDTSOAM +! +!# include "CMN_SIZE" ! Size Parameters +! +! ! Function value +! INTEGER :: NMAX +! +! !================================================================= +! ! GET_WETDEP_NMAX begins here! +! ! +! ! NOTE: If you add tracers to a simulation, update as necessary +! !================================================================= +! IF ( ITS_A_FULLCHEM_SIM() ) THEN +! +! !----------------------- +! ! Fullchem simulation +! !----------------------- +! NMAX = 7 ! HNO3, H2O2, CH2O, MP, +! ! GLYX, MGLY, GLYC +! IF ( LSULF ) NMAX = NMAX + 8 ! SO2, SO4, MSA, NH3, NH4, NIT +! IF ( LDUST ) NMAX = NMAX + NDSTBIN ! plus # of dust bins +! IF ( LSSALT ) NMAX = NMAX + 2 ! plus 2 seasalts +! +! IF ( LSOA ) THEN +! IF ( LCARB ) NMAX = NMAX + 15 ! carbon + SOA aerosols +! IF ( IDTSOAG /= 0 ) NMAX = NMAX + 1 ! SOAG deposition +! IF ( IDTSOAM /= 0 ) NMAX = NMAX + 1 ! SOAM deposition +! ELSE +! IF ( LCARB ) NMAX = NMAX + 4 ! just carbon aerosols +! ENDIF +! +! ELSE IF ( ITS_AN_AEROSOL_SIM() ) THEN +! +! !----------------------- +! ! Offline simulation +! !----------------------- +! NMAX = 0 +! IF ( LSULF ) NMAX = NMAX + 9 ! add 9 sulfur species +! IF ( LCRYST ) NMAX = NMAX + 5 ! add 5 cryst & aq species +! IF ( LDUST ) NMAX = NMAX + NDSTBIN ! Add number of dust bins +! IF ( LSSALT ) NMAX = NMAX + 2 ! plus 2 seasalts +! +! IF ( LSOA ) THEN +! IF ( LCARB ) NMAX = NMAX + 15 ! carbon + SOA aerosols +! ELSE +! IF ( LCARB ) NMAX = NMAX + 4 ! just carbon aerosols +! ENDIF +! +! ELSE IF ( ITS_A_RnPbBe_SIM() ) THEN +! +! !----------------------- +! ! Rn-Pb-Be simulation +! !----------------------- +! NMAX = 2 ! 210Pb, 7Be +! +! ELSE IF ( ITS_A_MERCURY_SIM() ) THEN +! +! !----------------------- +! ! Mercury simulation +! !----------------------- +! NMAX = 2 ! Hg2, HgP +! IF ( LSPLIT ) NMAX = NMAX + 14 ! Tagged tracers +! +! ELSE +! +! !----------------------- +! ! Everything else +! !----------------------- +! NMAX = 0 +! +! ENDIF +! +! ! Return to calling program +! END FUNCTION GET_WETDEP_NMAX +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_WETDEP_NSOL() RESULT( N_SOLUBLE ) +!! +!!****************************************************************************** +!! Function GET_WETDEP_NSOL returns NSOL (# of soluble tracers) to a calling +!! program outside WETSCAV_MOD. This is so that we can keep NSOL declared +!! as a PRIVATE variable. (bmy, 1/10/03) +!! +!! NOTES: +!!****************************************************************************** +!! +! ! Function value +! INTEGER :: N_SOLUBLE +! +! !================================================================= +! ! GET_WETDEP_NSOL begins here! +! !================================================================= +! +! ! Get the # of soluble tracers +! N_SOLUBLE = NSOL +! +! ! Return to calling program +! END FUNCTION GET_WETDEP_NSOL +! +!!------------------------------------------------------------------------------ +! +! FUNCTION GET_WETDEP_IDWETD( NWET ) RESULT( N ) +!! +!!****************************************************************************** +!! Function GET_WETDEP_IDWETD returns the tracer number of wet deposition +!! species NWET. This is meant to be called outside of WETSCAV_MOD so that +!! IDWETD can be kept as a PRIVATE variable. (bmy, 1/10/03) +!! +!! Arguments as Input: +!! ============================================================================ +!! (1 ) NWET (INTEGER) : Wet deposition species N +!! +!! NOTES: +!!****************************************************************************** +!! +! ! References to F90 modules +! USE ERROR_MOD, ONLY : ERROR_STOP +! +! ! Arguments +! INTEGER, INTENT(IN) :: NWET +! +! ! Function value +! INTEGER :: N +! +! !================================================================= +! ! GET_WETDEP_IDWETD begins here! +! !================================================================= +! +! ! Make sure NWET is valid +! IF ( NWET < 1 .or. NWET > NSOLMAX ) THEN +! CALL ERROR_STOP( 'Invalid value of NWET!', +! & 'GET_N_WETDEP (wetscav_mod.f)' ) +! ENDIF +! +! ! Get the tracer # for wet deposition species N +! N = IDWETD(NWET) +! +! ! Return to calling program +! END FUNCTION GET_WETDEP_IDWETD +! +!!------------------------------------------------------------------------------ + + SUBROUTINE WETSCAV_ADJ_FORCE() +! +!****************************************************************************** +! Subroutine WETSCAV_ADJ_FORCE calculates adjoint forcing for sensitivity of +! wetdeposition. Also works for wetdep 4DVAR. (fp, dkh, 03/04/13) +! +! NOTES +! +!****************************************************************************** +! + + ! References to F90 modules + USE ADJ_ARRAYS_MOD, ONLY : TRACER_IND, NOBS, DEP_UNIT + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE ADJ_ARRAYS_MOD, ONLY : NHX_ADJ_FORCE + USE ADJ_ARRAYS_MOD, ONLY : GET_CF_REGION, ADJOINT_AREA_M2 + USE ADJ_ARRAYS_MOD, ONLY : NSPAN + USE ADJ_ARRAYS_MOD, ONLY : TRACER_IND + USE ADJ_ARRAYS_MOD, ONLY : TR_WDEP_CONV + USE TIME_MOD, ONLY : GET_TS_DYN + USE TRACER_MOD, ONLY : TRACER_MW_G, TRACER_NAME + USE TRACER_MOD, ONLY : N_TRACERS + USE GRID_MOD, ONLY : GET_AREA_M2 + + +# include "CMN_SIZE" ! Size parameters +# include "define_adj.h" ! Obs operators + + + INTEGER :: N, I, J, L, LL, NFORCE + REAL*8 :: ADD_STT_ADJ + REAL*8 :: ADJ_WET + REAL*8, SAVE :: NTSDYN + REAL*8, SAVE :: CONV_TIME + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! WETSCAV_ADJ_FORCE begins here! + !================================================================= + + IF ( FIRST ) THEN + + NTSDYN = NSPAN / ( GET_TS_DYN() / 60D0 ) + + !default is kg/s + !CONV_AREA = 1d0 + CONV_TIME = 1D0 / NTSDYN + + ! print tracer names (all steps fp 06/03/2013) + DO N = 1, NOBS + WRITE(*,*) 'Forcing ', TRACER_NAME(TRACER_IND(N)), + & ' in ls wetdep (' ,TRIM( DEP_UNIT ),')' + ENDDO + + FIRST = .FALSE. + + ENDIF + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, ADJ_WET, LL, NFORCE, ADD_STT_ADJ ) + DO N = 1, NOBS + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! weight is only used for sensitivity studies + IF ( GET_CF_REGION(I,J,L) .GT. 0 ) THEN + + NFORCE = TRACER_IND(N) + ADJ_WET = BOX_DEP(I,J,L,NFORCE) + + DO LL = 2, L - 1 + ADJ_WET = ADJ_WET * LOWER_DEP(I,J,LL,NFORCE) + ENDDO + + ADD_STT_ADJ = ADJ_WET + & * GET_CF_REGION(I,J,L) + & * CONV_TIME + & * TR_WDEP_CONV(J,NFORCE) + + ! default unit is kg/s + STT_ADJ(I,J,L,NFORCE) = STT_ADJ(I,J,L,NFORCE) + & + ADD_STT_ADJ + + ENDIF + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! return to calling routine + END SUBROUTINE WETSCAV_ADJ_FORCE +!---------------------------------------------------------------------- + + SUBROUTINE INIT_WETSCAV_ADJ +! +!****************************************************************************** +! Subroutine INIT_WETSCAV_ADJ initializes updraft velocity, cloud liquid water +! content, cloud ice content, and mixing ratio of water fields, which +! are used in the wet scavenging routines. (bmy, 2/23/00, 3/7/05) +! +! Need the forward arrays for recalculation. Also init adjoint arrays. (dkh, 09/30/09) +! +! NOTES: +! (1 ) References "e_ice.f" -- routine to compute Eice(T). +! (2 ) Vud, CLDLIQ, CLDICE, C_H2O are all independent of tracer, so we +! can compute them once per timestep, before calling the cloud +! convection and wet deposition routines. +! (3 ) Set C_H2O = 0 below -120 Celsius. E_ICE(T) has a lower limit of +! -120 Celsius, so temperatures lower than this will cause a stop +! with an error message. (bmy, 6/15/00) +! (4 ) Replace {IJL}GLOB with IIPAR,JJPAR,LLPAR. Also rename PW to P. +! Remove IREF, JREF, these are obsolete. Now reference IS_WATER +! from "dao_mod.f" to determine water boxes. +! (5 ) Removed obsolete code from 9/01. Updated comments and made +! cosmetic changes. (bmy, 10/24/01) +! (6 ) Now use routine GET_PCENTER from "pressure_mod.f" to compute the +! pressure at the midpoint of grid box (I,J,L). Also removed P and +! SIG from the argument list (dsa, bdf, bmy, 8/20/02) +! (7 ) Now reference T from "dao_mod.f". Updated comments. Now allocate +! Vud, C_H2O, CLDLIQ and CLDICE here on the first call. Now references +! ALLOC_ERR from "error_mod.f". Now set H2O2s and SO2s to the initial +! values from for the first call to COMPUTE_F . Now call WETDEPID +! on the first call to initialize the wetdep index array. (bmy, 1/27/03) +! (8 ) Now references STT from "tracer_mod.f". Also now we call WETDEPID +! from "input_mod.f" (bmy, 7/20/04) +! (9 ) Now references new function E_ICE, which is an analytic function of +! Kelvin temperature instead of Celsius. (bmy, 3/7/05) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : T, IS_WATER + USE ERROR_MOD, ONLY : ALLOC_ERR + USE LOGICAL_ADJ_MOD, ONLY : LADJ_WDEP_LS + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE TRACER_MOD, ONLY : STT + USE TRACERID_MOD, ONLY : IDTH2O2, IDTSO2 + USE TRACER_MOD, ONLY : N_TRACERS !fp wetdep ls + + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, AS + REAL*8 :: PL, TK + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! INIT_WETSCAV_ADJ begins here! + !================================================================= + IF ( FIRST ) THEN + +! ! Allocate Vud on first call +! ALLOCATE( Vud( IIPAR, JJPAR ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'Vud' ) +! Vud = 0d0 +! +! ! Allocate C_H2O on first call +! ALLOCATE( C_H2O( IIPAR, JJPAR, LLPAR ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'C_H2O' ) +! C_H2O = 0d0 +! +! ! Allocate CLDLIQ on first call +! ALLOCATE( CLDLIQ( IIPAR, JJPAR, LLPAR ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'CLDLIQ' ) +! CLDLIQ = 0d0 +! +! ! Allocate CLDICE on first call +! ALLOCATE( CLDICE( IIPAR, JJPAR, LLPAR ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'CLDICE' ) +! CLDICE = 0d0 +! +! ! Allocate H2O2s for wet deposition +! ALLOCATE( H2O2s( IIPAR, JJPAR, LLPAR ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'H2O2s' ) +! +! ! Set H2O2s to the initial H2O2 from STT, so that we will have +! ! nonzero values for the first call to COMPUTE_F (bmy, 1/14/03) +! IF ( IDTH2O2 > 0 ) THEN +! H2O2s = STT(:,:,:,IDTH2O2) +! ELSE +! H2O2s = 0d0 +! ENDIF +! +! ! Allocate SO2s for wet deposition +! ALLOCATE( SO2s( IIPAR, JJPAR, LLPAR ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO2s' ) +! +! ! Set SO2s to the initial SO2 from STT, so that we will have +! ! nonzero values for the first call to COMPUTE_F (bmy, 1/14/03) +! IF ( IDTSO2 > 0 ) THEN +! SO2s = STT(:,:,:,IDTSO2) +! ELSE +! SO2s = 0d0 +! ENDIF + + IF ( IDTSO2 > 0 ) THEN + ! Allocate SO2s_ADJ for wet deposition + ALLOCATE( SO2s_ADJ( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO2s_ADJ' ) + SO2s_ADJ = 0d0 + ENDIF + + IF ( IDTH2O2 > 0 ) THEN + ! Allocate H2O2s_ADJ for wet deposition + ALLOCATE( H2O2s_ADJ( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'H2O2s_ADJ' ) + H2O2s_ADJ = 0d0 + ENDIF + + IF ( LADJ_WDEP_LS ) THEN + + ALLOCATE( BOX_DEP( IIPAR, JJPAR, LLPAR, N_TRACERS), STAT=AS) + IF( AS/=0) CALL ALLOC_ERR('BOX_DEP') + BOX_DEP = 0d0 + + ALLOCATE( LOWER_DEP( IIPAR, JJPAR, LLPAR, N_TRACERS), + & STAT=AS) + IF( AS/=0) CALL ALLOC_ERR('LOWER_DEP') + LOWER_DEP = 1d0 + + ENDIF + + ! Reset flag + FIRST = .FALSE. + ENDIF + +! !================================================================= +! ! Compute Vud, CLDLIQ, CLDICE, C_H2O, following Jacob et al, 2000. +! !================================================================= +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( I, J, L, TK, PL ) +!!$OMP+SCHEDULE( DYNAMIC ) +! DO L = 1, LLPAR +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! +! ! Compute Temp [K] and Pressure [hPa] +! TK = T(I,J,L) +! PL = GET_PCENTER(I,J,L) +! +! !============================================================== +! ! Compute Vud -- 5 m/s over oceans, 10 m/s over land (or ice?) +! ! Assume Vud is the same at all altitudes; the array can be 2-D +! !============================================================== +! IF ( L == 1 ) THEN +! IF ( IS_WATER( I, J ) ) THEN +! Vud(I,J) = 5d0 +! ELSE +! Vud(I,J) = 10d0 +! ENDIF +! ENDIF +! +! !============================================================== +! ! CLDLIQ, the cloud liquid water content [cm3 H2O/cm3 air], +! ! is a function of the local Kelvin temperature: +! ! +! ! CLDLIQ = 2e-6 [ T >= 268 K ] +! ! CLDLIQ = 2e-6 * ((T - 248) / 20) [ 248 K < T < 268 K ] +! ! CLDLIQ = 0 [ T <= 248 K ] +! !============================================================== +! IF ( TK >= 268d0 ) THEN +! CLDLIQ(I,J,L) = 2d-6 +! +! ELSE IF ( TK > 248d0 .and. TK < 268d0 ) THEN +! CLDLIQ(I,J,L) = 2d-6 * ( ( TK - 248d0 ) / 20d0 ) +! +! ELSE +! CLDLIQ(I,J,L) = 0d0 +! +! ENDIF +! +! !============================================================= +! ! CLDICE, the cloud ice content [cm3 ice/cm3 air] is given by: +! ! +! ! CLDICE = 2e-6 - CLDLIQ +! !============================================================= +! CLDICE(I,J,L) = 2d-6 - CLDLIQ(I,J,L) +! +! !============================================================= +! ! C_H2O is given by Dalton's Law as: +! ! +! ! C_H2O = Eice( Tk(I,J,L) ) / P(I,J,L) +! ! +! ! where P(L) = pressure in grid box (I,J,L) +! ! +! ! and Tk(I,J,L) is the Kelvin temp. of grid box (I,J,L). +! ! +! ! and Eice( Tk(I,J,L) ) is the saturation vapor pressure +! ! of ice [hPa] at temperature Tk(I,J,L) -- computed in +! ! routine E_ICE above. +! !============================================================== +! C_H2O(I,J,L) = E_ICE( TK ) / PL +! +! ENDDO +! ENDDO +! ENDDO +!!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE INIT_WETSCAV_ADJ + +!------------------------------------------------------------------------------ + + + SUBROUTINE ADJ_INIT_WETSCAV( ) +! +!****************************************************************************** +! Subroutine ADJ_INIT_WETSCAV is the adjoint of INIT_WETSCAV, passing adjoint +! of H2O2s and SO2s (H2O2s_ADJ, SO2s_ADJ) to the total adjoint tracer array, +! STT_ADJ (dkh, 10/??/05) +! +! Module variables as Input: +! ============================================================================ +! (1 ) H2O2s_ADJ +! (2 ) SO2s_ADJ +! (3 ) STT_ADJ +! +! Module variables as Output: +! ============================================================================ +! (1 ) STT_ADJ +! +! NOTES: +! (1 ) Updated to GCv8 (dkh, 10/04/09) +!****************************************************************************** +! + ! Reference to f90 modules + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE TIME_MOD, ONLY : GET_NHMS, GET_NHMSb + USE TIME_MOD, ONLY : GET_NYMD, GET_NYMDb + USE TRACERID_MOD, ONLY : IDTSO2, IDTH2O2 + +# include "CMN_SIZE" ! Size params + + ! Local variables + INTEGER :: I, J, L + + !================================================================= + ! ADJ_INIT_WETSCAV begins here! + !================================================================= + + ! We only need to do this at the initial time step corresponding to + ! when H2O2s and SO2s were allocated and initialized. + IF ( GET_NHMSb() == GET_NHMS() .and. + & GET_NYMDb() == GET_NYMD() .and. + & IDTSO2 > 0 .and. + & IDTH2O2 > 0 ) THEN + + ! dkh debug + print*, ' do ADJ_INIT_WETSCAV ' + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + STT_ADJ(I,J,L,IDTH2O2) = STT_ADJ(I,J,L,IDTH2O2) + & + H2O2s_ADJ(I,J,L) + STT_ADJ(I,J,L,IDTSO2) = STT_ADJ(I,J,L,IDTSO2) + & + SO2s_ADJ(I,J,L) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! Return to calling program + END SUBROUTINE ADJ_INIT_WETSCAV + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_WETSCAV_ADJ + + !================================================================= + ! Subroutine CLEANUP_WETSCAV deallocates arrays for + ! wet scavenging / wet deposition + !================================================================= +! IF ( ALLOCATED( Vud ) ) DEALLOCATE( Vud ) +! IF ( ALLOCATED( C_H2O ) ) DEALLOCATE( C_H2O ) +! IF ( ALLOCATED( CLDLIQ ) ) DEALLOCATE( CLDLIQ ) +! IF ( ALLOCATED( CLDICE ) ) DEALLOCATE( CLDICE ) +! IF ( ALLOCATED( PDOWN ) ) DEALLOCATE( PDOWN ) +! IF ( ALLOCATED( QQ ) ) DEALLOCATE( QQ ) +! IF ( ALLOCATED( H2O2s ) ) DEALLOCATE( H2O2s ) +! IF ( ALLOCATED( SO2s ) ) DEALLOCATE( SO2s ) + IF ( ALLOCATED( SO2s_ADJ ) ) DEALLOCATE( SO2s_ADJ ) + IF ( ALLOCATED( H2O2s_ADJ ) ) DEALLOCATE( H2O2s_ADJ ) + IF ( ALLOCATED( BOX_DEP ) ) DEALLOCATE( BOX_DEP ) + IF ( ALLOCATED( LOWER_DEP ) ) DEALLOCATE( LOWER_DEP ) + + ! Return to calling program + END SUBROUTINE CLEANUP_WETSCAV_ADJ + +!----------------------------------------------------------------------------- + + ! End of module + END MODULE WETSCAV_ADJ_MOD