716 lines
29 KiB
Fortran
716 lines
29 KiB
Fortran
! $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
|