Sola/GEOS-Chem-adjoint-v35-note
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
389fdea5ae19f0bc6ba56683992d08d4ead79574
GEOS-Chem-adjoint-v35-note/code/mercury_mod.f
Xuesong (Steve) fa691eb0aa Add files via upload
2018-08-28 00:46:26 -04:00

2515 lines
93 KiB
Fortran
Raw Blame History

! $Id: mercury_mod.f,v 1.1 2009/06/09 21:51:53 daven Exp $
MODULE MERCURY_MOD
!
!******************************************************************************
! Module MERCURY_MOD contains variables and routines for the GEOS-CHEM
! mercury simulation. (eck, bmy, 12/14/04, 1/19/07)
!
! Module Variables:
! ============================================================================
! (1 ) AN_Hg0 (INTEGER) : Tracer index array for tagged anth Hg(0) regions
! (2 ) AN_Hg2 (INTEGER) : Tracer index array for tagged anth Hg(II) regions
! (3 ) AN_HgP (INTEGER) : Tracer index array for tagged anth HgP regions
! (4 ) COSZM (REAL*8 ) : Max daily value of COS( S. Z. Angle ) [unitless]
! (5 ) DRYHg2 (INTEGER) : Index for Hg2 in DEPSAV array (drydep freq)
! (6 ) DRYHgP (INTEGER) : Index for HgP in DEPSAV array (drydep freq)
! (7 ) EHg0_an (REAL*8 ) : Anthropogenic Hg0 emissions [kg/s]
! (8 ) EHg2_an (REAL*8 ) : Anthropogenic Hg2 emissions [kg/s]
! (9 ) EHgP_an (REAL*8 ) : Anthropogenic HgP emissions [kg/s]
! (10) EHg0_oc (REAL*8 ) : Hg0 emissions from oceans [kg/s]
! (11) EHg0_ln (REAL*8 ) : Re-emissions of Hg0 from land [kg/s]
! (12) EHg0_nt (REAL*8 ) : Hg0 emissions from natural land sources [kg/s]
! (13) TCOSZ (REAL*8 ) : Sum of COS( Solar Zenith Angle ) [unitless]
! (14) TTDAY (REAL*8 ) : Total daylight time at location (I,J) [minutes]
! (15) T44 (REAL*4 ) : Local array for drydep diagnostic
! (15) N_HgTAGS (INTEGER) : Number of tagged sources (1 or 8)
! (16) ZERO_DVEL(REAL*8 ) : Array with zero dry deposition velocity
! (17) ANTHRO_Hg_YEAR(INT): Anthropogenic Hg emissions year (1995 or 2000)
!
! Module Routines:
! ===========================================================================
! (1 ) CHEMMERCURY : Chemistry routine for Hg
! (2 ) CHEM_Hg0_Hg2 : Chemistry for Hg0, Hg2 and drydep of Hg2
! (3 ) RXN_Hg0_Hg2 : Conversion of Hg(0) --> Hg(II) via reduction rxn
! (4 ) RXN_Hg0 : Conversion of Hg(0) --> Hg(II) via oxidation rxns
! (5 ) RXN_Hg2_DRYD : Prod of Hg(II) from Hg(0); also Hg(II) drydep loss
! (6 ) RXN_Hg2 : Prod of Hg(II) from Hg(0)
! (7 ) CHEM_HGP : Chemistry (via drydep loss) for HgP
! (8 ) RXN_HgP_DRYD : Loss of HgP via drydep
! (9 ) EMISSMERCURY : Emissions for Hg
! (10) SRCHG0 : Applies emissions of Hg0
! (11) SRCHG2 : Applies emissions of Hg2
! (12) SRCHGP : Applies emissions of HgP
! (13) MERCURY_READYR : Reads mercury emissions and converts to [kg/s]
! (14) GET_LWC : Computes liquid water content as a function of T
! (15) GET_VCLDF : Computes volume cloud fraction
! (16) GET_O3 : Returns monthly mean O3 field
! (17) GET_OH : Returns monthly mean OH field (w/ diurnal scaling)
! (18) OHNO3TIME : Computes diurnal scaling for monthly mean OH
! (19) DEFINE_TAGGED_Hg : Defines tracer number for tagged Hg tracers
! (20) INIT_MERCURY : Allocates and zeroes module arrays
! (21) CLEANUP_MERCURY : Deallocates module arrays
!
! GEOS-CHEM modules referenced by mercury_mod.f
! ============================================================================
! (1 ) bpch2_mod.f : Module w/ routines for binary pch file I/O
! (2 ) comode_mod.f : Module w/ SMVGEAR allocatable arrays
! (3 ) dao_mod.f : Module w/ arrays for DAO met fields
! (4 ) diag_mod.f : Module w/ GEOS-CHEM diagnostic arrays
! (5 ) drydep_mod.f : Module w/ GEOS-CHEM dry deposition routines
! (6 ) error_mod.f : Module w/ NaN, other error check routines
! (7 ) global_o3_mod.f : Module w/ routines to read 3-D O3 field
! (8 ) global_oh_mod.f : Module w/ routines to read 3-D OH field
! (9 ) grid_mod.f : Module w/ horizontal grid information
! (10) logical_mod.f : Module w/ GEOS-CHEM logical switches
! (11) pbl_mix_mod.f : Module w/ routines for PBL height & mixing
! (12) pressure_mod.f : Module w/ routines to compute P(I,J,L)
! (13) regrid_1x1_mod.f : Module w/ routines to regrid 1x1 data
! (13) time_mod.f : Module w/ routines to compute date & time
! (14) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc.
! (15) tracerid_mod.f : Module w/ pointers to tracers & emissions
! (16) transfer_mod.f : Module w/ routines to cast & resize arrays
!
! Nomenclature:
! ============================================================================
! (1 ) Hg(0) a.k.a. Hg0 : Elemental mercury
! (2 ) Hg(II) a.k.a. Hg2 : Divalent mercury
! (3 ) HgP : Particulate mercury
!
! Mercury Tracers (1-3 are always defined; 4-21 are defined for tagged runs)
! ============================================================================
! (1 ) Hg(0) : Hg(0) - total tracer
! (2 ) Hg(II) : Hg(II) - total tracer
! (3 ) HgP : HgP - total tracer
! ------------------------+---------------------------------------------------
! (4 ) Hg(0)_an : Hg(0) - North American anthropogenic
! (5 ) Hg(0)_ae : Hg(0) - European Anthropogenic
! (6 ) Hg(0)_aa : Hg(0) - Asian anthropogenic
! (7 ) Hg(0)_ar : Hg(0) - Rest of World Anthropogenic
! (8 ) Hg(0)_oc : Hg(0) - Ocean emission
! (9 ) Hg(0)_ln : Hg(0) - Land reemission
! (10) Hg(0)_nt : Hg(0) - Land natural emission
! ------------------------+---------------------------------------------------
! (11) Hg(II)_an : Hg(II) - North American anthropogenic
! (12) Hg(II)_ae : Hg(II) - European Anthropogenic
! (13) Hg(II)_aa : Hg(II) - Asian anthropogenic
! (14) Hg(II)_ar : Hg(II) - Rest of World Anthropogenic
! (15) Hg(II)_oc : Hg(II) - Ocean emission
! (16) Hg(II)_ln : Hg(II) - Land reemission
! (17) Hg(II)_nt : Hg(II) - Land natural emission
! ------------------------+---------------------------------------------------
! (18) HgP_an : HgP - North American anthropogenic
! (19) HgP_ae : HgP - European anthropogenic
! (20) HgP_aa : HgP - Asian anthropogenic
! (21) HgP_ar : HgP - Rest of world anthropogenic
! ------------------------+---------------------------------------------------
! (22) HgP_oc : HgP - Ocean emission (FOR FUTURE USE)
! (23) HgP_ln : HgP - Land reemission (FOR FUTURE USE)
! (24) HgP_nt : HgP - Land natural emission (FOR FUTURE USE)
!
! References:
! ============================================================================
! (1 ) Hall, B. (1995). "The gas phase oxidation of elemental mercury by
! ozone.", Water, Air, and Soil Pollution 80: 301-315.
! (2 ) Sommar, J., et al. (2001). "A kinetic study of the gas-phase
! reaction between the hydroxyl radical and atomic mercury."
! Atmospheric Environment 35: 3049-3054.
!
! NOTES:
! (1 ) Updated for reduction rxn and online Hg0 ocean flux. Now use
! diagnostic arrays from "diag03_mod.f". (eck, sas, bmy, 1/21/05)
! (2 ) Now references "pbl_mix_mod.f". Remove FEMIS array and routine
! COMPUTE_FEMIS. (bmy, 2/15/05)
! (3 ) Now can 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)
! (5 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05)
! (6 ) Various updates added for tagged Hg sim. (eck, sas, cdh, bmy, 4/6/06)
! (7 ) Updated IF statement in GET_LWC (cdh, bmy, 12/1/06)
! (8 ) Modified GET_O3 to read trop+strat O3 at all levels (phs, 1/19/07)
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE PRIVATE DECLARATIONS -- keep certain internal variables
! and routines from being seen outside "mercury_mod.f"
!=================================================================
! Make everything PRIVATE ...
PRIVATE
! ... except these routines
PUBLIC :: CHEMMERCURY
PUBLIC :: CLEANUP_MERCURY
PUBLIC :: INIT_MERCURY
PUBLIC :: EMISSMERCURY
!=================================================================
! MODULE VARIABLES
!=================================================================
! Scalars
INTEGER :: ANTHRO_Hg_YEAR
INTEGER :: DRYHg2
INTEGER :: DRYHgP
! Parameters
REAL*8, PARAMETER :: SMALLNUM = 1d-32
! Arrays
INTEGER, ALLOCATABLE :: AN_Hg0(:,:)
INTEGER, ALLOCATABLE :: AN_Hg2(:,:)
INTEGER, ALLOCATABLE :: AN_HgP(:,:)
REAL*8, ALLOCATABLE :: COSZM(:,:)
REAL*8, ALLOCATABLE :: EHg0_an(:,:)
REAL*8, ALLOCATABLE :: EHg2_an(:,:)
REAL*8, ALLOCATABLE :: EHgP_an(:,:)
REAL*8, ALLOCATABLE :: EHg0_oc(:,:,:)
REAL*8, ALLOCATABLE :: EHg0_ln(:,:)
REAL*8, ALLOCATABLE :: EHg0_nt(:,:)
REAL*4, ALLOCATABLE :: T44(:,:,:,:)
REAL*8, ALLOCATABLE :: TCOSZ(:,:)
REAL*8, ALLOCATABLE :: TTDAY(:,:)
REAL*8, ALLOCATABLE :: ZERO_DVEL(:,:)
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE CHEMMERCURY
!
!******************************************************************************
! Subroutine CHEMMERCURY is the driver routine for mercury chemistry
! in the GEOS-CHEM module. (eck, bmy, 12/6/04, 4/6/06)
!
! NOTES:
! (1 ) Now references routine GET_PBL_MAX_L from "pbl_mix_mod.f". Now
! references AD44 from "diag_mod.f". Now sum the levels from T44 into
! the AD44 array. Now references N_TRACERS from "tracer_mod.f".
! (bmy, 2/24/05)
! (2 ) Bug fix: Set T44 to 0e0 for single precision. Now allow for zero
! dry deposition velocity. Now call INIT_MERCURY from "input_mod.f"
! (bmy, 4/6/06)
!******************************************************************************
!
! References to F90 modules
USE DIAG_MOD, ONLY : AD44
USE DRYDEP_MOD, ONLY : DEPSAV
USE ERROR_MOD, ONLY : DEBUG_MSG
USE GLOBAL_O3_MOD, ONLY : GET_GLOBAL_O3
USE GLOBAL_OH_MOD, ONLY : GET_GLOBAL_OH
USE PBL_MIX_MOD, ONLY : GET_PBL_MAX_L
USE LOGICAL_MOD, ONLY : LPRT
USE TIME_MOD, ONLY : GET_MONTH, ITS_A_NEW_MONTH
USE TRACER_MOD, ONLY : N_TRACERS
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! ND44
! Local variables
LOGICAL, SAVE :: FIRST = .TRUE.
INTEGER :: I, J, L, MONTH, N, PBL_MAX
!=================================================================
! CHEMMERCURY begins here!
!
! Read monthly mean OH and O3 fields
!=================================================================
IF ( ITS_A_NEW_MONTH() ) THEN
! Get the current month
MONTH = GET_MONTH()
! Read monthly mean OH and O3 from disk
CALL GET_GLOBAL_OH( MONTH )
IF ( LPRT ) CALL DEBUG_MSG( '### CHEMMERC: a GET_GLOBAL_OH' )
CALL GET_GLOBAL_O3( MONTH )
IF ( LPRT ) CALL DEBUG_MSG( '### CHEMMERC: a GET_GLOBAL_O3' )
ENDIF
!=================================================================
! Perform chemistry on Hg tracers
!=================================================================
! Compute diurnal scaling for OH
CALL OHNO3TIME
IF ( LPRT ) CALL DEBUG_MSG( 'CHEMMERCURY: a OHNO3TIME' )
! Zero dry deposition tmp array
IF ( ND44 > 0 ) THEN
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, N )
DO N = 1, N_TRACERS
DO L = 1, LLTROP
DO J = 1, JJPAR
DO I = 1, IIPAR
T44(I,J,L,N) = 0e0
ENDDO
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
ENDIF
!-------------------------
! Hg0 and Hg2 chemistry
!-------------------------
IF ( DRYHg2 > 0 ) THEN
! If DRYHG2 > 0 then drydep is active;
! pass drydep frequency to CHEM_Hg0_Hg2
CALL CHEM_Hg0_Hg2( DEPSAV(:,:,DRYHg2) )
IF ( LPRT ) CALL DEBUG_MSG( 'CHEMMERCURY: a CHEM_Hg0_Hg2' )
ELSE
! Otherwise pass zero drydep frequency
CALL CHEM_Hg0_Hg2( ZERO_DVEL )
IF ( LPRT ) CALL DEBUG_MSG( 'CHEMMERCURY: a CHEM_Hg0_Hg2' )
ENDIF
!--------------------------
! HgP chemistry
!--------------------------
IF ( DRYHgP > 0 ) THEN
! If DRYHgP > 0, then drydep is active;
! Pass drydep frequency to CHEM_HgP
CALL CHEM_HgP( DEPSAV(:,:,DRYHgP) )
IF ( LPRT ) CALL DEBUG_MSG( 'CHEMMERCURY: a CHEM_HgP' )
ELSE
! Otherwise pass zero drydep frequency
CALL CHEM_HgP( ZERO_DVEL )
IF ( LPRT ) CALL DEBUG_MSG( 'CHEMMERCURY: a CHEM_HgP' )
ENDIF
! Archive drydep fluxes into ND44
IF ( ND44 > 0 ) THEN
! Model layers where the PBL top occurs
PBL_MAX = GET_PBL_MAX_L()
! Sum levels into AD44
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, N )
DO N = 1, N_TRACERS
DO J = 1, JJPAR
DO I = 1, IIPAR
DO L = 1, PBL_MAX
AD44(I,J,N,1) = AD44(I,J,N,1) + T44(I,J,L,N)
ENDDO
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
ENDIF
! Return to calling program
END SUBROUTINE CHEMMERCURY
!------------------------------------------------------------------------------
SUBROUTINE CHEM_Hg0_Hg2( V_DEP_Hg2 )
!
!******************************************************************************
! Subroutine CHEM_Hg0_Hg2 is the chemistry subroutine for the oxidation/
! reduction of Hg0/Hg(II). For tracers with dry deposition, the loss rate
! of dry dep is combined in the chemistry loss term.
! (eck, bmy, 12/6/04, 1/9/06)
!
! Arguments as Input:
! ============================================================================
! (1 ) V_DEP_Hg2 (REAL*8) : Dry deposition velocity for Hg(II) [cm/s]
!
! Description of the chemistry mechanism:
! ============================================================================
! (1 ) Conversion from Hg(0) to Hg(II): Oxidation by O3 and OH
!
! Hg(0)(g)+ O3(g) --> Hg(II) , k = 3.0e-20 cm3 molec-1 s-1
! Source: Hall, 1995
!
! Hg(0)(g)+ OH(g) --> Hg(II) , k = 8.7e-14 cm3 s-1
! Source: Sommar et al. 2001
!
! (2 ) Aqueous-phase photochemical reduction of Hg(II) is included based
! on estimate of rate constant and scaled to OH concentrations.
!
! (3 ) Hg(II) is dry-deposited, kd = Dvel/DELZ (sec-1)
!
! NOTES:
! (1 ) Updated for reduction reaction. Now use diagnostic arrays from
! "diag03_mod.f" (eck, bmy, 1/21/05)
! (2 ) Now references GET_FRAC_UNDER_PBLTOP from "pbl_mix_mod.f". Now
! performs drydep for all levels in the PBL. Changed Kred to 2.1e-10
! on advice of Noelle Eckley Selin. (bmy, 2/24/05)
! (3 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05)
! (4 ) Now prevent divide-by-zero error. Now use ID_Hg0 and ID_Hg2 index
! arrays from "tracerid_mod.f". Also modified for updated ocean
! mercury module. Updated some constants. Also saves out diagnostic
! of Hg2 lost to rxn w/ seasalt. (eck, cdh, sas, bmy, 4/6/06)
!******************************************************************************
!
! References to F90 modules
USE DAO_MOD, ONLY : T, AD
USE DIAG03_MOD, ONLY : AD03_Hg2_Hg0, AD03_Hg2_O3, AD03_Hg2_OH
USE DIAG03_MOD, ONLY : AD03_Hg2_SS, LD03, ND03
USE LOGICAL_MOD, ONLY : LSPLIT
USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP
USE TIME_MOD, ONLY : GET_TS_CHEM
USE TRACER_MOD, ONLY : STT, XNUMOL
USE TRACERID_MOD, ONLY : ID_Hg0, ID_Hg2, ID_Hg_tot, N_Hg_CATS
# include "CMN_SIZE" ! Size parameters
! Arguments
REAL*8, INTENT(IN) :: V_DEP_Hg2(IIPAR,JJPAR)
! Local variables
INTEGER :: I, J, L, N, NN
REAL*8 :: AREA_CM2, C_O3, C_OH
REAL*8 :: DRYDEP, DTCHEM, E_RKT
REAL*8 :: E_K1, E_K2, FA
REAL*8 :: FC, K1, K2
REAL*8 :: Ko, Kr, Kt
REAL*8 :: Kr_Kt, NK1, NK2
REAL*8 :: LOST_Hg0_O3, LOST_Hg0_OH, LWC
REAL*8 :: F_UNDER_TOP, RKT, E_SALT
REAL*8 :: LOST_Hg0(N_Hg_CATS)
REAL*8 :: LOST_SS(N_Hg_CATS)
REAL*8 :: Ox_Hg0(N_Hg_CATS)
! K for reaction Hg0 + O3 in cm3 molec-1 s-1 (Source: Hall '95)
REAL*8, PARAMETER :: K = 3.0d-20
! K for reaction Hg2 + OH in cm3 s-1
REAL*8, PARAMETER :: K_HG_OH = 8.7d-14
! Henry's Law constant for Hg2
REAL*8, PARAMETER :: HL = 1.4d6
! Gas constant??
REAL*8, PARAMETER :: R = 8.2d-2
! K for reduction (scaled to budget and OH conc)
REAL*8, PARAMETER :: Kred = 8.4d-10
! K for sea salt (eck, bmy, 4/6/06)
REAL*8, PARAMETER :: KSalt = 3.8d-5
! External functions
REAL*8, EXTERNAL :: BOXVL
!=================================================================
! CHEM_Hg0_Hg2 begins here!
!=================================================================
! Chemistry timestep [s]
DTCHEM = GET_TS_CHEM() * 60d0
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, NN, LOST_Hg0 )
!$OMP+PRIVATE( F_UNDER_TOP, C_O3, C_OH, FC, LWC )
!$OMP+PRIVATE( FA, K1, K2, Ko, Kr )
!$OMP+PRIVATE( Kt, Kr_Kt, RKT, E_RKT, E_K1 )
!$OMP+PRIVATE( E_K2, E_SALT, LOST_Hg0_O3, LOST_Hg0_OH, LOST_SS )
!$OMP+PRIVATE( Ox_Hg0 )
DO L = 1, LLPAR
DO J = 1, JJPAR
DO I = 1, IIPAR
! Initialize LOST_Hg0, Ox_Hg0 arrays
DO NN = 1, N_Hg_CATS
LOST_Hg0(NN) = 0d0
LOST_SS(NN) = 0d0
Ox_Hg0(NN) = 0d0
ENDDO
! Also initialize for ND03 diag
LOST_Hg0_O3 = 0d0
LOST_Hg0_OH = 0d0
! Fraction of box (I,J,L) underneath the PBL top [unitless]
F_UNDER_TOP = GET_FRAC_UNDER_PBLTOP( I, J, L )
! Monthly mean O3 and OH concentrations [molec/cm3]
C_O3 = GET_O3( I, J, L )
C_OH = GET_OH( I, J, L )
! Get fraction of cloud in the gridbox [unitless]
FC = GET_VCLDF( I, J, L )
! Get liquid water content in cloudy area of gridbox (m3/m3)
LWC = GET_LWC( T(I,J,L) ) * FC
! Define fraction of Hg(II) which is in air
FA = ( HL * R * T(I,J,L) * LWC )
FA = FA / ( 1d0 + FA )
! Define K's for the oxidation reactions
K1 = K * C_O3
K2 = K_HG_OH * C_OH
Ko = K1 + K2
! Define K for the reduction reaction. Include the fraction of
! Hg(II) in air within the Kreduction & scale to OH concentration
Kr = Kred * FA * C_OH
! Total rate constant: Oxidation + Reduction
Kt = Ko + Kr
! Ratio of Kr / Kt
IF ( Kt > SMALLNUM ) THEN
Kr_Kt = Kr / Kt
ELSE
Kr_Kt = SMALLNUM
ENDIF
! Kt * timestep (i.e. the argument for EXP) [unitless]
RKT = Kt * DTCHEM
! Compute the exponential terms for use below
E_RKT = EXP( -RKT )
E_K1 = EXP( -K1 * DTCHEM )
E_K2 = EXP( -K2 * DTCHEM )
E_SALT = EXP( -Ksalt * DTCHEM )
!==============================================================
! Hg(0) Chemistry: Conversion from Hg(0) to Hg(II)
!
! CASE 1: REDUCTION REACTION
! -------------------------------------------------------------
! Aqueous chem occurs if Kr>0, it's cloudy, and T > -15 C.
! In this case we have the reaction:
!
! New Hg(0) = { ( Old Hg(0) * EXP( -Kt * DT ) ) } +
! { ( Old Hg(0) + Old Hg(II) ) * Kr/Kt *
! ( 1 - EXP( -Kt * DT ) ) }
!
! where: Kr = K of the reduction rxn
! Kt = K of the total rxn (oxidation + reduction)
! DT = Chemistry timestep [s]
! Old Hg(0) = Hg(0) at start of this timestep
! Old Hg(II) = Hg(II) as start of this timestep
!
! The amount of Hg(0) lost in this rxn becomes Hg(II):
!
! Hg(0) converted to Hg(II) = Old Hg(0) - New Hg(0)
!
! CASE 2: OXIDATION REACTIONS
! -------------------------------------------------------------
! If aqueous chemistry does not happen, then Hg(0) is converted
! to Hg(II) via the oxidation rxns with rate constants K1, K2:
!
! New Hg(0) = Old_Hg(0) * EXP( -K1 * DT ) * EXP( -K2 * DT )
!
! The amt of Hg(0) lost in these rxns rxn becomes Hg(II):
!
! Hg(0) converted to Hg(II) = Old Hg(0) - New Hg(0)
!==============================================================
IF ( Kr > 0d0 .and. FC > 0d0 .and. T(I,J,L) > 258d0 ) THEN
!--------------------------------------------
! CASE 1: Total Hg(II) tracer, aq chem
!--------------------------------------------
! Loop over all Hg0 tracers
DO NN = 1, N_Hg_CATS
! Conversion of total Hg(0) --> Hg(II)
CALL RXN_Hg0_Hg2( I, J, L,
& ID_Hg0(NN), ID_Hg2(NN), RKT,
& E_RKT, Kr_Kt, Kt,
& Ko, Kr, DTCHEM,
& LOST_Hg0(NN), Ox_Hg0(NN) )
ENDDO
ELSE
!--------------------------------------------
! CASE 2: Total Hg(II) tracer, non-aq chem
!--------------------------------------------
! Loop over all Hg0 tracers
DO NN = 1, N_Hg_CATS
! Total Hg(0) loss by oxidation rxn
CALL RXN_Hg0( I, J, L,
& ID_Hg0(NN), E_K1, E_K2, LOST_Hg0(NN) )
! Gross oxidation flux Hg(0) -> Hg(II)
Ox_Hg0(NN) = LOST_Hg0(NN)
ENDDO
ENDIF
!==============================================================
! Compute Hg(II) production from OH and O3 rxns for diagnostic
!
! This is for the diagnostics OH and O3 prod of Hg(II).
! They are messed up a little since adding the reduction
! reaction haven't fixed them yet. (eck, 12/7/04)
!==============================================================
IF ( Ox_Hg0(ID_Hg_tot) > 0d0 ) THEN
! Avoid division by zero
IF ( ( K1 + K2 ) > 0d0 ) THEN
! Production of Hg(II) from O3 rxn [kg]
LOST_Hg0_O3 = ( K1 / ( K1 + K2 ) ) * Ox_Hg0(ID_Hg_tot)
! Production of Hg(II) from OH rxn [kg]
LOST_Hg0_OH = ( K2 / ( K1 + K2 ) ) * Ox_Hg0(ID_Hg_tot)
ENDIF
ENDIF
!==============================================================
! Hg(II) chemistry: Conversion from Hg(0) and drydep loss
!
! CASE 1: WITHIN THE PLANETARY BOUNDARY LAYER (PBL)
! -------------------------------------------------------------
! At the surface we have both dry deposition of Hg(II) plus
! conversion of Hg(0) into Hg(II). In this case we use the
! following rxns:
!
! CASE 1a: If Conv Hg(0) > 0:
! ---------------------------
! New Hg(II) = ( Old Hg(II) * EXP( -RKT ) ) +
! ( Conv Hg(0)/RKT * ( 1 - EXP( -RKT ) )
!
!
! CASE 1b: If Conv Hg(0) <= 0:
! ----------------------------
! New Hg(II) = ( Old Hg(II) + Conv Hg(0) ) * EXP( -RKT )
!
! Where: RKT = DTCHEM * Drydep Vel of Hg(II)
! "Conv Hg(0)" = Amt of Hg(0) that became Hg(II), which
! is archived from the Hg(0) rxns above
!
! CASE 2: OUTSIDE THE PLANETARY BOUNDARY LAYER (PBL)
! -------------------------------------------------------------
! At levels higher than the surface, we do not have drydep.
! Therefore we only have conversion of Hg(0) into Hg(II), and
! we use this rxn:
!
! New Hg(II) = Old Hg(II) + Conv Hg(0)
!
!
! NOTE: ND44 diagnostics are archived in RXN_Hg2_DRYD.
!==============================================================
! If we are in the PBL and there is nonzero drydep velocity ...
IF ( F_UNDER_TOP > 0d0 .and. V_DEP_Hg2(I,J) > 0d0 ) THEN
! Hg2 drydep frequency [1/s] -- F_UNDER_TOP accounts for the
! fraction of box (I,J,L) that is located beneath the PBL top
RKT = V_DEP_Hg2(I,J) * DTCHEM * F_UNDER_TOP
! Pre-compute exponential term
E_RKT = EXP( -RKT )
!-----------------------------------------------
! CASE 1: Total Hg(II) tracer, in PBL
!-----------------------------------------------
! Loop over all Hg2 tracers
DO NN = 1, N_Hg_CATS
! Compute new Hg(II) concentration in PBL
! Also return Hg2 lost to sea salt (eck, bmy, 4/6/06)
CALL RXN_Hg2_DRYD( I, J, L,
& ID_Hg2(NN), RKT, E_RKT,
& E_SALT, LOST_Hg0(NN), DTCHEM,
& LOST_SS(NN) )
ENDDO
ELSE
!--------------------------------------------
! CASE 2: Total Hg(II) tracer, outside PBL
!--------------------------------------------
! Loop over all Hg2 tracers
DO NN = 1, N_Hg_CATS
! Compute new concentration of total Hg(II) outside PBL [kg]
CALL RXN_Hg2( I, J, L, ID_Hg2(NN), LOST_Hg0(NN) )
ENDDO
ENDIF
!==============================================================
! ND03 diagnostic: Hg(II) production [kg]
!==============================================================
IF ( ND03 > 0 .and. L <= LD03 ) THEN
NN = ID_Hg_tot
AD03_Hg2_Hg0(I,J,L) = AD03_Hg2_Hg0(I,J,L) + LOST_Hg0(NN)
AD03_Hg2_OH(I,J,L) = AD03_Hg2_OH(I,J,L) + LOST_Hg0_OH
AD03_Hg2_O3(I,J,L) = AD03_Hg2_O3(I,J,L) + LOST_Hg0_O3
! Sea salt diagnostic is 2-D
IF ( L == 1 ) THEN
AD03_Hg2_SS(I,J,NN) = AD03_Hg2_SS(I,J,NN) + LOST_SS(NN)
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE CHEM_Hg0_Hg2
!------------------------------------------------------------------------------
SUBROUTINE RXN_Hg0_Hg2( I, J, L, N_Hg0, N_Hg2,
& RKT, E_RKT, Kr_Kt, Kt, Ko,
& Kr, DTCHEM, LOST_Hg0, Ox_Hg0 )
!
!******************************************************************************
! Subroutine RXN_Hg0_Hg2 computes the conversion of Hg(0) to Hg(II) via
! an aqueous chemistry reduction reaction. The formula used below is a s
! solution of the 2-box model equation. (eck, bmy, 12/14/04, 4/6/06)
!
! Arguments as Input:
! ============================================================================
! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt grid box indices
! (4 ) N_Hg0 (INTEGER) : Index for Hg(0) total or tagged tracers
! (5 ) N_Hg2 (INTEGER) : Index for Hg(II) total or tagged tracers
! (6 ) RKT (REAL*8 ) : Value of R * k * Temp for this rxn [unitless]
! (7 ) E_RKT (REAL*8 ) : Value of EXP( - RKT ) [unitless]
! (8 ) Kr_Kt (REAL*8 ) : Ratio of Kr / Kt (redux K / total K) [unitless]
!
! Arguments as Output:
! ============================================================================
! (9 ) LOST_Hg0 (REAL*8 ) : Loss term: Hg(0) before - Hg(0) after [kg]
!
! NOTES:
! (1 ) Changed equation to reflect reduction rxn. Also modified to output
! the gross oxidation flux. (eck, cdh, bmy, 4/6/06)
!******************************************************************************
!
! References to F90 modules
USE TRACER_MOD, ONLY : STT
! Arguments
INTEGER, INTENT(IN) :: I, J, L, N_Hg0, N_Hg2
REAL*8, INTENT(IN) :: RKT, E_RKT, Kr_Kt, Kt, Kr
REAL*8, INTENT(IN) :: Ko, DTCHEM
REAL*8, INTENT(OUT) :: LOST_Hg0, Ox_Hg0
! Local variables
REAL*8 :: OLD_Hg0, OLD_Hg2, NEW_Hg0
!=================================================================
! RXN_Hg0_Hg2 begins here!
!=================================================================
! Error check tracer number
IF ( N_Hg0 < 1 .or. N_Hg2 < 1 ) RETURN
! Initial concentrations of Hg(0) and Hg(II) [kg]
OLD_Hg0 = MAX( STT(I,J,L,N_Hg0), SMALLNUM )
OLD_Hg2 = MAX( STT(I,J,L,N_Hg2), SMALLNUM )
! New concentration of Hg(0) [kg]
NEW_Hg0 = ( OLD_Hg0 * E_RKT ) +
& ((( OLD_Hg2 + OLD_Hg0 ) * Kr_Kt ) * ( 1d0 - E_RKT ) )
! Gross oxidation flux Hg(0) -> Hg(II)
Ox_Hg0 = ( Kt - Kr ) / Kt**2 *
& ( ( OLD_Hg0 + OLD_Hg2 ) * Kr *
& ( E_RKT - 1d0 + Kt * DTCHEM )
& + OLD_Hg0 * Kt * ( 1d0 -E_RKT ) )
! Set a floor of zero
OX_Hg0 = MAX( OX_Hg0, 0d0 )
! Save back into STT array [kg]
NEW_Hg0 = MAX( NEW_Hg0, SMALLNUM )
STT(I,J,L,N_Hg0) = NEW_Hg0
! Compute amount of Hg(0) which has now become Hg(II) [kg]
LOST_Hg0 = OLD_Hg0 - NEW_Hg0
! Return to calling program
END SUBROUTINE RXN_Hg0_Hg2
!------------------------------------------------------------------------------
SUBROUTINE RXN_Hg0( I, J, L, N, E_K1, E_K2, LOST_Hg0 )
!
!******************************************************************************
! Subroutine RXN_Hg0 computes the loss of Hg(0) by oxidation reactions with
! rate constants K1 and K2. (eck, bmy, 12/14/04)
!
! Arguments as Input:
! ============================================================================
! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt grid box indices
! (4 ) N (INTEGER) : Index for Hg(0) total or tagged tracers
! (5 ) E_K1 (REAL*8 ) : Value of EXP( -K1 ) [unitless]
! (6 ) E_K2 (REAL*8 ) : Value of EXP( -K2 ) [unitless]
!
! Arguments as Output:
! ============================================================================
! (7 ) LOST_Hg0 (REAL*8 ) : Loss term: Hg(0) before - Hg(0) after [kg]
!
! NOTES:
!******************************************************************************
!
! References to F90 modules
USE TRACER_MOD, ONLY : STT
! Arguments
INTEGER, INTENT(IN) :: I, J, L, N
REAL*8, INTENT(IN) :: E_K1, E_K2
REAL*8, INTENT(OUT) :: LOST_Hg0
! Local variables
REAL*8 :: OLD_Hg0, NEW_Hg0
!=================================================================
! RXN_Hg0 begins here!
!=================================================================
! Error check tracer number
IF ( N < 1 ) RETURN
! Initial concentration of Hg(0) [kg]
OLD_Hg0 = MAX( STT(I,J,L,N), SMALLNUM )
! New concentration of Hg0 after oxidation rxns [kg]
NEW_Hg0 = MAX( ( OLD_Hg0 * E_K1 * E_K2 ), SMALLNUM )
! Save back into STT array [kg]
STT(I,J,L,N) = NEW_Hg0
! Compute amount of Hg(0) which has been oxidized into Hg(II) [kg]
LOST_Hg0 = OLD_Hg0 - NEW_Hg0
! Return to calling program
END SUBROUTINE RXN_Hg0
!------------------------------------------------------------------------------
SUBROUTINE RXN_Hg2_DRYD( I, J, L,
& N, RKT, E_RKT,
& E_SALT, LOST_Hg0, DTCHEM, LOST_SS )
!
!******************************************************************************
! Subroutine RXN_Hg2_DRYD computes the new concentration of Hg(II) from the
! converted Hg(0) plus the drydep of Hg(II). (eck, bmy, 12/14/04, 4/6/06)
!
! Arguments as Input:
! ============================================================================
! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt grid box indices
! (4 ) N (INTEGER) : Index for Hg(II) total or tagged tracers
! (5 ) RKT (REAL*8 ) : Value of R * k * Temp for drydep [unitless]
! (6 ) E_RKT (REAL*8 ) : Value of EXP( - RKT ) [unitless]
! (7 ) E_SALT (REAL*8 ) : Value of EXP( -KSALT * DTCHEM )
! (8 ) LOST_Hg0 (REAL*8 ) : Amount of Hg(0) that became Hg(II) [kg]
! (9 ) DTCHEM (INTEGER) : Chemistry timestep [s]
!
! Arguments as Output:
! ============================================================================
! (10 ) LOST_SS (REAL*8 ) : Hg2 lost to sea salt rxn [kg]
!
! NOTES:
! (1 ) Now use 2 different solutions, depending on whether or not LOST_Hg0
! (amt of converted Hg0 -> Hg2) is positive. Also now archive the
! amount of total Hg(II) tracer lost to drydep for the ocean flux
! routines in "ocean_mercury_mod.f". (sas, bmy, 1/19/05)
! (2 ) Remove references to "diag_mod.f" and "CMN_DIAG". Now save drydep
! fluxes into T44 array. (bmy, 2/24/05)
! (3 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05)
! (4 ) Now add E_SALT to account for uptake by sea salt. Now references
! IS_WATER from "dao_mod.f". Now uses ID_Hg2 and ID_Hg_tot from
! "tracerid_mod.f". Now references LDYNOCEAN from "logical_mod.f".
! Now do not call ADD_Hg2_DD if we are not using the dynamic ocean
! module. Now also return LOST_SS. (eck, cdh, bmy, 4/6/06)
!******************************************************************************
!
! References to F90 modules
USE DAO_MOD, ONLY : IS_WATER
USE GRID_MOD, ONLY : GET_AREA_CM2
USE LOGICAL_MOD, ONLY : LDYNOCEAN
USE OCEAN_MERCURY_MOD, ONLY : ADD_Hg2_DD
USE TRACER_MOD, ONLY : STT, XNUMOL
USE TRACERID_MOD, ONLY : IS_Hg2
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! ND44
! Arguments
INTEGER, INTENT(IN) :: I, J, L, N
REAL*8, INTENT(IN) :: RKT, E_RKT, E_SALT, LOST_Hg0, DTCHEM
REAL*8, INTENT(OUT) :: LOST_SS
! Local variables
INTEGER :: NN
REAL*8 :: AREA_CM2, DRYDEP, OLD_Hg2
REAL*8 :: NEW_Hg2, TEMP_Hg2
!=================================================================
! RXN_Hg2_DRYD begins here!
!=================================================================
! Error check tracer number
IF ( N < 1 ) RETURN
! Initial concentration of Hg(II) [kg]
OLD_Hg2 = MAX( STT(I,J,L,N), SMALLNUM )
IF ( LOST_Hg0 > 0d0 ) THEN
!--------------------------------------------------------------
! CASE 1a: Amt of Hg(0) converted to Hg(II) is positive
! Use Solution #1 of the differential equation
!--------------------------------------------------------------
! Concentration of Hg(II) after drydep [kg]
! Factor in drydep at this time
NEW_Hg2 = ( OLD_Hg2 * E_RKT ) +
& ( LOST_Hg0/RKT * ( 1d0 - E_RKT ) )
ELSE
!--------------------------------------------------------------
! CASE 1b: Amt of Hg(0) converted to Hg(II) is negative or zero
! Use Solution #2 of the differential equation
!--------------------------------------------------------------
! New concentration of Hg(II) [kg]
! Assume drydep takes place after chemistry
NEW_Hg2 = ( OLD_Hg2 + LOST_Hg0 ) * E_RKT
ENDIF
! Also account for uptake of Hg(II) by sea salt aerosol
IF ( IS_WATER( I, J ) ) THEN
TEMP_Hg2 = NEW_Hg2 * E_SALT
ELSE
TEMP_Hg2 = NEW_Hg2
ENDIF
! Amount of Hg2 lost to sea salt
LOST_SS = MAX( NEW_Hg2 - TEMP_Hg2, SMALLNUM )
! Reset
NEW_Hg2 = TEMP_Hg2
! Save back into STT array [kg]
NEW_Hg2 = MAX( NEW_Hg2, SMALLNUM )
STT(I,J,L,N) = NEW_Hg2
!=================================================================
! Compute amount of Hg(II) lost to drydep
!=================================================================
! Amount of Hg(II) lost to dry deposition [kg]
DRYDEP = ( OLD_Hg2 - NEW_Hg2 ) + LOST_Hg0
! Archive Hg(II) lost to drydep [kg] for the ocean mercury flux routines
! in "ocean_mercury_mod.f" if necessary. Do not call ADD_Hg2_DD if the
IF ( IS_Hg2(N) .and. LDYNOCEAN ) THEN
CALL ADD_Hg2_DD( I, J, N, DRYDEP )
ENDIF
!=================================================================
! ND44 diagnostic: drydep flux of Hg(II) [molec/cm2/s]
!=================================================================
IF ( ND44 > 0 ) THEN
! Grid box surface area [cm2]
AREA_CM2 = GET_AREA_CM2( J )
! Amt of Hg(II) lost to drydep [molec/cm2/s]
DRYDEP = DRYDEP * XNUMOL(N) / ( AREA_CM2 * DTCHEM )
! Archive Hg(II) drydep flux in T44 array [molec/cm2/s]
T44(I,J,L,N) = T44(I,J,L,N) + DRYDEP
ENDIF
! Return to calling program
END SUBROUTINE RXN_Hg2_DRYD
!------------------------------------------------------------------------------
SUBROUTINE RXN_Hg2( I, J, L, N, LOST_Hg0 )
!
!******************************************************************************
! Subroutine RXN_Hg2 computes the new concentration of Hg(II) which is the
! old concentration plus the amount of converted Hg(0) (eck, bmy, 12/14/04)
!
! Arguments as Input:
! ============================================================================
! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt grid box indices
! (4 ) N (INTEGER) : Index for Hg(II) total or tagged tracers
! (5 ) LOST_Hg0 (REAL*8 ) : Amount of Hg(0) that has become Hg(II) [kg]
!
! NOTES:
!******************************************************************************
!
! References to F90 modules
USE TRACER_MOD, ONLY : STT
! Arguments
INTEGER, INTENT(IN) :: I, J, L, N
REAL*8, INTENT(IN) :: LOST_Hg0
! Local variables
REAL*8 :: OLD_Hg2, NEW_Hg2
!=================================================================
! RXN_Hg2 begins here!
!=================================================================
! Error check tracer number
IF ( N < 1 ) RETURN
! Initial concentration of Hg(II) [kg]
OLD_Hg2 = MAX( STT(I,J,L,N), SMALLNUM )
! New concentration of Hg(II) is the old concentration
! plus the amount of Hg(0) which was converted to Hg(II) [kg]
NEW_Hg2 = MAX( ( OLD_Hg2 + LOST_Hg0 ), SMALLNUM )
! Save new concentration of Hg(II) to STT array [kg]
STT(I,J,L,N) = NEW_Hg2
! Return to calling program
END SUBROUTINE RXN_Hg2
!------------------------------------------------------------------------------
SUBROUTINE CHEM_HgP( V_DEP_HgP )
!
!******************************************************************************
! Subroutine CHEM_HgP is the chemistry subroutine for HgP (particulate
! mercury. HgP is lost via dry deposition. (eck, bmy, 12/7/04, 4/6/06)
!
! Arguments as Input:
! ============================================================================
! (1 ) V_DEP_HgP (REAL*8) : Dry deposition velocity for Hg(II) [cm/s]
!
! NOTES:
! (1 ) Removed references to AD44 and "CMN_DIAG". Now compute drydep for all
! levels within the PBL. Now references ND03, LD03 from "diag03_mod.f".
! (bmy, 2/24/05)
! (2 ) Now references XNUMOL & XNUMOLAIR from "tracer_mod.f" (bmy, 10/25/05)
! (3 ) Now use ID_HgP index array from "tracerid_mod.f". (cdh, bmy, 1/9/06)
!******************************************************************************
!
! Refernces to F90 modules
USE DIAG03_MOD, ONLY : ND03, LD03
USE GRID_MOD, ONLY : GET_AREA_CM2
USE LOGICAL_MOD, ONLY : LSPLIT
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, XNUMOL
USE TRACERID_MOD, ONLY : ID_HgP, N_Hg_CATS
# include "CMN_SIZE" ! Size parameters
! Arguments
REAL*8, INTENT(IN) :: V_DEP_HgP(IIPAR,JJPAR)
! Local variables
INTEGER :: I, J, L, NN, PBL_MAX
REAL*8 :: DTCHEM, E_KT, F_UNDER_TOP
!=================================================================
! CHEM_HgP begins here!
!=================================================================
! Chemistry timestep [s]
DTCHEM = GET_TS_CHEM() * 60d0
! Maximum extent of the PBL
PBL_MAX = GET_PBL_MAX_L()
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, F_UNDER_TOP, E_KT, NN )
!$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 )
! If we are in the PBL and there is nonzero drydep vel ...
IF ( F_UNDER_TOP > 0d0 .and. V_DEP_HgP(I,J) > 0d0 ) THEN
! Pre-compute the exponential term for use below [unitless]
E_KT = EXP( -V_DEP_HgP(I,J) * DTCHEM * F_UNDER_TOP )
! Compute new conc of HgP tracers after drydep [kg]
DO NN = 1, N_Hg_CATS
! Do dry deposition (skip undefined HgP tagged tracers)
IF ( ID_HgP(NN) > 0 ) THEN
CALL RXN_HgP_DRYD( I, J, L, ID_HgP(NN), E_KT, DTCHEM )
ENDIF
ENDDO
ENDIF
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to callwing program
END SUBROUTINE CHEM_HgP
!------------------------------------------------------------------------------
SUBROUTINE RXN_HgP_DRYD( I, J, L, N, E_KT, DTCHEM )
!
!******************************************************************************
! Subroutine RXN_Hg0_DRYD computes the new concentration of HgP
! after dry deposition. ND44 diagnostics are also archived.
! (eck, bmy, 12/14/04, 4/6/06)
!
! Arguments as Input:
! ============================================================================
! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt grid box indices
! (4 ) N (INTEGER) : Index for HgP total or tagged tracers
! (5 ) E_KT (REAL*8 ) : Value of EXP( -KT ) for drydep rxn [unitless]
! (6 ) DTCHEM (INTEGER) : Chemistry timestep [s]
!
! NOTES:
! (1 ) Remove references to "diag_mod.f" and "CMN_DIAG". Now save drydep
! fluxes into T44 array. (bmy, 2/24/05)
! (2 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05)
! (3 ) Now uses ID_HgP and ID_Hg_tot from "tracerid_mod.f" (cdh, bmy,4/6/06)
!******************************************************************************
!
! References to F90 modules
USE GRID_MOD, ONLY : GET_AREA_CM2
USE TRACER_MOD, ONLY : STT, XNUMOL
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! ND44
! Arguments
INTEGER, INTENT(IN) :: I, J, L, N
REAL*8, INTENT(IN) :: DTCHEM, E_KT
! Local variables
INTEGER :: NN
REAL*8 :: AREA_CM2, DRYDEP, OLD_HgP, NEW_HgP
!=================================================================
! RXN_HgP_DRYD begins here!
!=================================================================
! Error check tracer number
IF ( N < 1 ) RETURN
! Initial concentration of HgP [kg]
OLD_HgP = MAX( STT(I,J,L,N), SMALLNUM )
! New concentration of HgP after drydep [kg]
NEW_HgP = MAX( ( OLD_HgP * E_KT ), SMALLNUM )
! Save new concentration of HgP in STT [kg]
STT(I,J,L,N) = NEW_HgP
!=================================================================
! ND44 diagnostic: drydep flux of Hg(II) [molec/cm2/s]
!=================================================================
IF ( ND44 > 0 ) THEN
! Grid box surface area [cm2]
AREA_CM2 = GET_AREA_CM2( J )
! Amt of Hg(II) lost to drydep [molec/cm2/s]
DRYDEP = OLD_HgP - NEW_HgP
DRYDEP = ( DRYDEP * XNUMOL(N) ) / ( AREA_CM2 * DTCHEM )
! Archive Hg(II) drydep flux in T44 array [molec/cm2/s]
T44(I,J,L,N) = T44(I,J,L,N) + DRYDEP
ENDIF
! Return to calling program
END SUBROUTINE RXN_HgP_DRYD
!------------------------------------------------------------------------------
SUBROUTINE EMISSMERCURY
!
!******************************************************************************
! Subroutine EMISSMERCURY is the driver routine for mercury emissions.
! (eck, bmy, 12/7/04, 4/6/06)
!
! NOTES:
! (1 ) Now call OCEAN_MERCURY_FLUX from "ocean_mercury_mod.f" to compute
! the emissions of Hg0 from the ocean instead of reading it from disk.
! (sas, bmy, 1/20/05)
! (2 ) Now no longer call COMPUTE_FEMIS, since we can get the same information
! from routine GET_FRAC_OF_PBL in "pbl_mix_mod.f" (bmy, 2/22/05)
! (3 ) Now modified for new ocean mercury module. (cdh, sas, bmy, 4/6/06)
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : DEBUG_MSG
USE LOGICAL_MOD, ONLY : LPRT, LDYNOCEAN
USE OCEAN_MERCURY_MOD, ONLY : OCEAN_MERCURY_FLUX
USE TIME_MOD, ONLY : GET_MONTH
USE TRACER_MOD, ONLY : STT
# include "CMN_SIZE" ! Size parameters
! Local variables
LOGICAL, SAVE :: FIRST = .TRUE.
INTEGER :: THISMONTH
!=================================================================
! EMISSMERCURY begins here!
!=================================================================
! First-time initialization
IF ( FIRST ) THEN
! Read anthro, ocean, land emissions of Hg from disk
CALL MERCURY_READYR
! Reset first-time flag
FIRST = .FALSE.
ENDIF
!=================================================================
! Call emission routines for Hg(0), Hg(II), and Hg(P)
!=================================================================
! Ocean flux of Hg(0)
IF ( LDYNOCEAN ) THEN
CALL OCEAN_MERCURY_FLUX( EHg0_oc )
IF ( LPRT ) CALL DEBUG_MSG( '### EMISSMERCURY: a OCEAN_FLUX' )
ENDIF
! Add Hg(0) source into STT [kg]
CALL SRCHg0
IF ( LPRT ) CALL DEBUG_MSG( '### EMISSMERCURY: a SRCHg0' )
! Add Hg(II) source into STT [kg]
CALL SRCHg2
IF ( LPRT ) CALL DEBUG_MSG( '### EMISSMERCURY: a SRCHg2' )
! Add HgP source into STT [kg]
CALL SRCHgP
IF ( LPRT ) CALL DEBUG_MSG( '### EMISSMERCURY: a SRCHgP' )
! Return to calling program
END SUBROUTINE EMISSMERCURY
!------------------------------------------------------------------------------
SUBROUTINE SRCHg0
!
!******************************************************************************
! Subroutine SRCHg0 is the subroutine for Hg(0) emissions.
! Emissions of Hg(0) will be distributed throughout the boundary layer.
! (eck, cdh, bmy, 1/21/05, 4/6/06)
!
! Arguments as Input/Output:
! ============================================================================
! (1 ) TC (REAL*8) : Tracer concentration of Hg(0) [kg]
!
! NOTES:
! (1 ) Now use diagnostic arrays from "diag03_mod.f" (bmy, 1/21/05)
! (2 ) Now references GET_FRAC_OF_PBL and GET_PBL_MAX_L from "pbl_mix_mod.f".
! Remove reference to FEMIS. (bmy, 2/22/05)
! (3 ) EHg0_an is now a 2-D array. Modified for new ocean mercury module.
! Now use ID_Hg0 index array from "tracerid_mod.f". Now make sure
! STT does not underflow. (cdh, bmy, 4/6/06)
!******************************************************************************
!
! Reference to diagnostic arrays
USE DIAG03_MOD, ONLY : AD03, ND03
USE ERROR_MOD, ONLY : ERROR_STOP
USE LOGICAL_MOD, ONLY : LSPLIT
USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_MAX_L
USE TIME_MOD, ONLY : GET_TS_EMIS
USE TRACER_MOD, ONLY : STT
USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_Hg_na, ID_Hg_eu, ID_Hg_as
USE TRACERID_MOD, ONLY : ID_Hg_rw, ID_Hg_oc, ID_Hg_ln, ID_Hg_nt
USE TRACERID_MOD, ONLY : ID_Hg0
# include "CMN_SIZE" ! Size parameters
! Local variables
INTEGER :: I, J, L, N, PBL_MAX
REAL*8 :: DTSRCE, E_Hg, F_OF_PBL, T_Hg, T_Hg_An
!=================================================================
! SRCHg0 begins here!
!=================================================================
! Emission timestep [s]
DTSRCE = GET_TS_EMIS() * 60d0
! Maximum extent of the PBL [model levels]
PBL_MAX = GET_PBL_MAX_L()
! Loop over grid boxes
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, N, T_Hg_An, T_Hg, F_OF_PBL, E_Hg )
DO J = 1, JJPAR
DO I = 1, IIPAR
! Compute total anthropogenic Hg(0) emissions
T_Hg_An = EHg0_an(I,J)
! Compute total Hg(0) emissions (anthro+oceans+land+natural)
T_Hg = T_Hg_An + EHg0_oc(I,J,ID_Hg_tot) +
& EHg0_ln(I,J) + EHg0_nt(I,J)
!==============================================================
! Partition Hg0 throughout PBL; store into STT [kg]
! Now make sure STT does not underflow (cdh, bmy, 4/6/06)
!==============================================================
! Loop up to max PBL level
DO L = 1, PBL_MAX
! Fraction of box (I,J,L) w/in the PBL [unitless]
F_OF_PBL = GET_FRAC_OF_PBL( I, J, L )
!-----------------
! Total Hg tracer
!-----------------
N = ID_Hg0(ID_Hg_tot)
E_Hg = F_OF_PBL * T_Hg
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
!-----------------
! Tagged tracers
!-----------------
IF ( LSPLIT ) THEN
!--------------------
! Primary emissions
!--------------------
! Anthro Hg0 by region
N = AN_Hg0(I,J)
E_Hg = F_OF_PBL * T_Hg_an
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
! Land re-emissions of Hg0
N = ID_Hg0(ID_Hg_ln)
E_Hg = F_OF_PBL * EHg0_ln(I,J)
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
! Natural land sources of Hg0
N = ID_Hg0(ID_Hg_nt)
E_Hg = F_OF_PBL * EHg0_nt(I,J)
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
!--------------------
! Ocean re-emissions
!--------------------
! Anthro re-emission from ocean in N. AMERICA
N = ID_Hg0(ID_Hg_na)
E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_na)
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
! Anthro re-emission from ocean in EUROPE
N = ID_Hg0(ID_Hg_eu)
E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_eu)
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
! Anthro re-emission from ocean in ASIA
N = ID_Hg0(ID_Hg_as)
E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_as)
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
! Anthro re-emission from ocean in REST OF WORLD
N = ID_Hg0(ID_Hg_rw)
E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_rw)
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
! Re-emission from ocean in OCEAN
N = ID_Hg0(ID_Hg_oc)
E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_oc)
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
! Re-emission from ocean in LAND REEMISSION
N = ID_Hg0(ID_Hg_ln)
E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_ln)
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
! Re-emission from ocean in NATURAL
N = ID_Hg0(ID_Hg_nt)
E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_nt)
STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE )
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
ENDIF
ENDDO
!==============================================================
! ND03 diagnostic: Total Hg(0) emissions [kg]
! 1=anthro; 3=from ocean; 4=land re-emission; 5=natural src
!==============================================================
IF ( ND03 > 0 ) THEN
N = ID_Hg_tot
AD03(I,J,1) = AD03(I,J,1) + ( T_Hg_An * DTSRCE )
AD03(I,J,3) = AD03(I,J,3) + ( EHg0_oc(I,J,N) * DTSRCE )
AD03(I,J,4) = AD03(I,J,4) + ( EHg0_ln(I,J) * DTSRCE )
AD03(I,J,5) = AD03(I,J,5) + ( EHg0_nt(I,J) * DTSRCE )
ENDIF
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE SRCHg0
!-----------------------------------------------------------------------------
SUBROUTINE SRCHg2
!
!******************************************************************************
! Subroutine SRCHg2 is the subroutine for Hg(II) emissions.
! Emissions of Hg(II) will be distributed throughout the boundary layer.
! (eck, bmy, 12/7/04, 4/6/06)
!
! Arguments as Input/Output:
! ============================================================================
! (1 ) TC (REAL*8) : Tracer concentration of Hg(II) [kg]
!
! NOTES:
! (1 ) Now use diagnostic arrays from "diag03_mod.f" (bmy, 1/21/05)
! (2 ) Now references GET_FRAC_OF_PBL and GET_PBL_MAX_L from "pbl_mix_mod.f".
! Remove reference to FEMIS. (bmy, 2/22/05)
! (3 ) EHg2_an is now a 2-D array. Now use ID_Hg2 index array from
! "tracerid_mod.f". Now make sure STT does not underflow.
! (eck, cdh, bmy, 4/6/06)
!******************************************************************************
!
! Reference to F90 modules
USE DIAG03_MOD, ONLY : AD03, ND03
USE ERROR_MOD, ONLY : ERROR_STOP
USE LOGICAL_MOD, ONLY : LSPLIT
USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_MAX_L
USE TIME_MOD, ONLY : GET_TS_EMIS
USE TRACER_MOD, ONLY : STT
USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_Hg2
# include "CMN_SIZE" ! Size parameters
! Local variables
INTEGER :: I, J, L, N, PBL_MAX
REAL*8 :: DTSRCE, F_OF_PBL, E_Hg
!=================================================================
! SRCHg2 begins here!
!=================================================================
! Emission timestep [s]
DTSRCE = GET_TS_EMIS() * 60d0
! Maximum extent of the PBL [model levels]
PBL_MAX = GET_PBL_MAX_L()
! Loop over grid boxes
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, F_OF_PBL, E_Hg, N )
DO J = 1, JJPAR
DO I = 1, IIPAR
! Loop up to the max PBL layer
DO L = 1, PBL_MAX
! Fraction of box (I,J,L) w/in the PBL [unitless]
F_OF_PBL = GET_FRAC_OF_PBL( I, J, L )
! Partition total Hg2 into box (I,J,L) [kg]
E_Hg = F_OF_PBL * EHg2_an(I,J) * DTSRCE
!---------------------------
! Total anthro Hg(II) [kg]
!---------------------------
N = ID_Hg2(ID_Hg_tot)
STT(I,J,L,N) = STT(I,J,L,N) + E_Hg
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
!---------------------------
! Tagged anthro Hg(II) [kg]
!---------------------------
IF ( LSPLIT ) THEN
N = AN_Hg2(I,J)
STT(I,J,L,N) = STT(I,J,L,N) + E_Hg
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
ENDIF
ENDDO
!-------------------------------
! ND03 diag: Anthro Hg(II) [kg]
!-------------------------------
IF ( ND03 > 0 ) THEN
AD03(I,J,6) = AD03(I,J,6) + ( EHg2_an(I,J) * DTSRCE )
ENDIF
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE SRCHg2
!-----------------------------------------------------------------------------
SUBROUTINE SRCHgP
!
!******************************************************************************
! Subroutine SRCHgP is the subroutine for HgP emissions.
! Emissions of HgP will be distributed throughout the boundary layer.
! (eck, bmy, 12/7/04, 4/6/06)
!
! Arguments as Input/Output:
! ============================================================================
! (1 ) TC (REAL*8) : Tracer concentration of Hg(II) [kg]
!
! NOTES:
! (1 ) Now use diagnostic arrays from "diag03_mod.f" (bmy, 1/21/05)
! (2 ) Now references GET_FRAC_OF_PBL and GET_PBL_MAX_L from "pbl_mix_mod.f".
! Remove reference to FEMIS. (bmy, 2/22/05)
! (3 ) EHgP_an is now a 2-D array. Now use ID_HgP index array from
! "tracerid_mod.f". Now make sure STT does not underflow.
! (eck, cdh, bmy, 4/6/06)
!******************************************************************************
!
! Reference to diagnostic arrays
USE DIAG03_MOD, ONLY : AD03, ND03
USE ERROR_MOD, ONLY : ERROR_STOP
USE LOGICAL_MOD, ONLY : LSPLIT
USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_MAX_L
USE TIME_MOD, ONLY : GET_TS_EMIS
USE TRACER_MOD, ONLY : STT
USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_HgP
# include "CMN_SIZE" ! Size paramters
! Local variables
INTEGER :: I, J, L, N, PBL_MAX
REAL*8 :: DTSRCE, F_OF_PBL, E_Hg
!=================================================================
! SRCHgP begins here!
!=================================================================
! Chemistry timestep [s]
DTSRCE = GET_TS_EMIS() * 60d0
! Maximum extent of the PBL [model levels]
PBL_MAX = GET_PBL_MAX_L()
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, F_OF_PBL, E_Hg, N )
DO J = 1, JJPAR
DO I = 1, IIPAR
! Loop up to PBL top layer
DO L = 1, PBL_MAX
! Fraction of box (I,J,L) w/in the PBL [unitless]
F_OF_PBL = GET_FRAC_OF_PBL( I, J, L )
! Partition HgP into box (I,J,L) [kg]
E_Hg = F_OF_PBL * EHgP_an(I,J) * DTSRCE
!------------------------
! Total anthro HgP [kg]
!------------------------
N = ID_HgP(ID_Hg_tot)
STT(I,J,L,N) = STT(I,J,L,N) + E_Hg
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
!------------------------
! Tagged anthro HgP [kg]
!------------------------
IF ( LSPLIT ) THEN
N = AN_HgP(I,J)
STT(I,J,L,N) = STT(I,J,L,N) + E_Hg
STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM )
ENDIF
ENDDO
!----------------------------
! ND03 diag: Anthro HgP [kg]
!----------------------------
IF ( ND03 > 0 ) THEN
AD03(I,J,9) = AD03(I,J,9) + ( EHgP_an(I,J) * DTSRCE )
ENDIF
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE SRCHgP
!------------------------------------------------------------------------------
SUBROUTINE MERCURY_READYR
!
!******************************************************************************
! Subroutine MERCURY_READYR reads the year-invariant emissions for Mercury
! from anthropogenic, ocean, and land sources. (eck, bmy, 12/6/04, 4/6/06)
!
! NOTES:
! (1 ) Now read data from mercury_200501 subdirectory. Now compute oceanic
! Hg(0) emissions w/ ocean flux module instead of reading them from
! disk. Now use 1985 TAU values. (sas, bmy, 1/20/05)
! (2 ) Now can read data for both GEOS and GCAP grids (bmy, 8/16/05)
! (3 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (4 ) Now read anthro emissions on GEOS 1x1 grid in DATA_1x1_DIR. Also
! keep 2x25 and 4x5 files together in DATA_1x1_DIR. Also now use new
! land re-emissions files from Noelle Selin. (eck, bmy, 4/6/06)
!******************************************************************************
!
! 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_1x1
USE LOGICAL_MOD, ONLY : LDYNOCEAN
USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1
USE TIME_MOD, ONLY : EXPAND_DATE
USE TRANSFER_MOD, ONLY : TRANSFER_2D
# include "CMN_SIZE" ! Size parameters
! Local variables
INTEGER :: NYMD
REAL*4 :: ARRAY(IGLOB,JGLOB,1)
REAL*4 :: ARRAY1(I1x1,J1x1,1)
REAL*8 :: XTAU
REAL*8, PARAMETER :: SEC_PER_YR = 365.25d0 * 86400d0
CHARACTER(LEN=255) :: FILENAME
!=================================================================
! MERCURY_READYR begins here!
!
! Read annual anthropogenic mercury emissions [kg/s]
!=================================================================
! Mercury data is either for 1995 or 2000
NYMD = ( ANTHRO_Hg_YEAR * 10000 ) + 0101
XTAU = GET_TAU0( 1, 1, ANTHRO_Hg_YEAR )
!---------------------------
! Hg(0) emissions [kg/s]
!---------------------------
! Filename for anthropogenic mercury source
FILENAME = TRIM( DATA_DIR_1x1 ) //
& 'mercury_200511/GEIA_Hg0.geos.1x1.YYYY'
! Add year to the filename
CALL EXPAND_DATE( FILENAME, NYMD, 000000 )
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( ' - MERCURY_READYR: Reading ', a )
! Read data in [kg/yr]
CALL READ_BPCH2( FILENAME, 'HG-SRCE', 1,
& XTAU, I1x1, J1x1,
& 1, ARRAY1, QUIET=.TRUE. )
! Regrid from 1x1 to the current grid
CALL DO_REGRID_1x1( 'kg', ARRAY1, EHg0_an )
! Convert from [kg/yr] to [kg/s]
EHg0_an = EHg0_an / SEC_PER_YR
!---------------------------
! Hg(II) emissions [kg/s]
!---------------------------
! Filename for anthropogenic mercury source
FILENAME = TRIM( DATA_DIR_1x1 ) //
& 'mercury_200511/GEIA_Hg2.geos.1x1.YYYY'
! Add year to the filename
CALL EXPAND_DATE( FILENAME, NYMD, 000000 )
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME )
! Read data in [kg/yr]
CALL READ_BPCH2( FILENAME, 'HG-SRCE', 6,
& XTAU, I1x1, J1x1,
& 1, ARRAY1, QUIET=.TRUE. )
! Regrid from 1x1 to the current grid
CALL DO_REGRID_1x1( 'kg', ARRAY1, EHg2_an )
! Convert from [kg/yr] to [kg/s]
EHg2_an = EHg2_an / SEC_PER_YR
!---------------------------
! HgP emissions [kg/s]
!---------------------------
! Filename for anthropogenic mercury source
FILENAME = TRIM( DATA_DIR_1x1 ) //
& 'mercury_200511/GEIA_HgP.geos.1x1.YYYY'
! Add year to the filename
CALL EXPAND_DATE( FILENAME, NYMD, 000000 )
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME )
! Read data in [kg/yr]
CALL READ_BPCH2( FILENAME, 'HG-SRCE', 9,
& XTAU, I1x1, J1x1,
& 1, ARRAY1, QUIET=.TRUE. )
! Regrid from 1x1 to the current grid
CALL DO_REGRID_1x1( 'kg', ARRAY1, EHgP_an )
! Convert from [kg/yr] to [kg/s]
EHgP_an = EHgP_an / SEC_PER_YR
!=================================================================
! Read annual emissions of anthropogenic Hg(0) which is
! re-emitted from the land [kg/s]
!=================================================================
! Use "generic" year 1985 for TAU values
XTAU = GET_TAU0( 1, 1, 1985 )
! Filename for re-emitted anthropogenic mercury
FILENAME = TRIM( DATA_DIR_1x1 ) //
& 'mercury_200511/Hg_land_reemission.' //
& GET_NAME_EXT_2D() // '.' // GET_RES_EXT()
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME )
! Read data in [kg/yr]
CALL READ_BPCH2( FILENAME, 'HG-SRCE', 4,
& XTAU, IGLOB, JGLOB,
& 1, ARRAY(:,:,1), QUIET=.TRUE. )
! Cast to REAL*8 and resize
CALL TRANSFER_2D( ARRAY(:,:,1), EHg0_ln )
! Convert from [Mg/yr] to [kg/s]
EHg0_ln = EHg0_ln * 1000d0 / SEC_PER_YR
!=================================================================
! Read annual emissions of Hg(0) from natural land sources [kg/s]
!=================================================================
! Use "generic" year 1985 for TAU values
XTAU = GET_TAU0( 1, 1, 1985 )
! Filename for natural land-source mercury
FILENAME = TRIM( DATA_DIR_1x1 ) //
& 'mercury_200511/Hg_natural.' // GET_NAME_EXT_2D() //
& '.' // GET_RES_EXT()
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME )
! TAU value corresponding to the data
XTAU = GET_TAU0( 1, 1, 1995 )
! Read data in [kg/yr]
CALL READ_BPCH2( FILENAME, 'HG-SRCE', 5,
& XTAU, IGLOB, JGLOB,
& 1, ARRAY(:,:,1), QUIET=.TRUE. )
! Cast to REAL*8 and resize
CALL TRANSFER_2D( ARRAY(:,:,1), EHg0_nt )
! Convert from [kg/yr] to [kg/s]
EHg0_nt = EHg0_nt / SEC_PER_YR
!=================================================================
! Read offline ocean Hg0 emissions (if LDYNOCEAN = .FALSE.)
!=================================================================
IF ( .not. LDYNOCEAN ) THEN
! File name
FILENAME = TRIM( DATA_DIR_1x1 ) //
& 'mercury_200511/Hg_ocean.geos.' // GET_RES_EXT()
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME )
! TAU value corresponding to the data
XTAU = GET_TAU0( 1, 1, 1985 )
! Read data in [kg/yr]
CALL READ_BPCH2( FILENAME, 'HG-SRCE', 3,
& XTAU, IGLOB, JGLOB,
& 1, ARRAY(:,:,1), QUIET=.TRUE. )
! Cast to REAL*8 and resize
CALL TRANSFER_2D( ARRAY(:,:,1), EHg0_oc(:,:,1) )
! Convert from [kg/yr] to [kg/s]
EHg0_oc = EHg0_oc / SEC_PER_YR
ENDIF
!=================================================================
! Print totals to the screen in [Gg/yr]
!=================================================================
WRITE( 6, '(a)' ) REPEAT( '=', 79 )
WRITE( 6, 110 )
WRITE( 6, '(a)' )
WRITE( 6, 111 ) SUM( EHg0_an ) * SEC_PER_YR * 1d-6
WRITE( 6, 113 ) SUM( EHg0_ln ) * SEC_PER_YR * 1d-6
WRITE( 6, 114 ) SUM( EHg0_nt ) * SEC_PER_YR * 1d-6
! Only write ocean total if we are doing offline ocean
IF ( .not. LDYNOCEAN ) THEN
WRITE( 6, 117 ) SUM( EHg0_oc ) * SEC_PER_YR * 1d-6
ENDIF
WRITE( 6, 115 ) SUM( EHg2_an ) * SEC_PER_YR * 1d-6
WRITE( 6, 116 ) SUM( EHgP_an ) * SEC_PER_YR * 1d-6
WRITE( 6, '(a)' ) REPEAT( '=', 79 )
! FORMAT strings
110 FORMAT( 'M E R C U R Y E M I S S I O N S' )
111 FORMAT( 'Total Anthro Hg(0) : ', f7.3, ' [Gg/yr]' )
113 FORMAT( 'Total Re-Emitted Hg(0) : ', f7.3, ' [Gg/yr]' )
114 FORMAT( 'Total Natural Hg(0) : ', f7.3, ' [Gg/yr]' )
115 FORMAT( 'Total Anthro Hg(II) : ', f7.3, ' [Gg/yr]' )
116 FORMAT( 'Total Anthro HgP : ', f7.3, ' [Gg/yr]' )
117 FORMAT( 'Total Ocean Hg(0) : ', f7.3, ' [Gg/yr]' )
! Return to calling program
END SUBROUTINE MERCURY_READYR
!------------------------------------------------------------------------------
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, 12/1/06)
!
! Arguments as Input:
! ============================================================================
! (1 ) T (REAL*8) : Temperature value at a GEOS-CHEM grid box [K]
!
! NOTES:
! (1 ) Now also add a case for T > 293 to the IF statement (cdh, bmy, 12/1/06)
!******************************************************************************
!
! 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
!------------------------------------------------------------------------------
FUNCTION GET_VCLDF( I, J, L ) RESULT( VCLDF )
!
!******************************************************************************
! Subroutine GET_VCLDF computes the volume cloud fraction for Hg0 and Hg2
! chemistry. (eck, bmy, 12/6/04)
!
! Arguments as Input:
! ============================================================================
! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt indices
!
! References:
! ============================================================================
! (1 ) Sundqvist et al. [1989]
!
! NOTES:
! (1 ) Copied from "sulfate_mod.f" but was made into a function since we are
! already looping over (I,J,L) in CHEM_Hg0_Hg2 (eck, bmy, 12/6/04)
!******************************************************************************
!
! References to F90 modules
USE DAO_MOD, ONLY : RH
USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE
! Arguments
INTEGER, INTENT(IN) :: I, J, L
! Local variables
REAL*8 :: PRES, PSFC, RH2, R0, B0
REAL*8, PARAMETER :: ZRT = 0.60d0, ZRS = 0.99d0
! Function value
REAL*8 :: VCLDF
!=================================================================
! GET_VCLDF begins here!
!=================================================================
! Surface pressure
PSFC = GET_PEDGE(I,J,1)
! Pressure at center of grid box L
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 = 1d0 - SQRT( 1d0 - B0 )
! Return to calling program
END FUNCTION GET_VCLDF
!------------------------------------------------------------------------------
FUNCTION GET_O3( I, J, L ) RESULT( O3_MOLEC_CM3 )
!
!******************************************************************************
! Function GET_O3 returns monthly mean O3 for offline sulfate aerosol
! simulations. (bmy, 12/16/02, 1/19/07)
!
! 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 also read stratospheric O3 (phs, 1/19/07)
!******************************************************************************
!
! References to F90 modules
USE DAO_MOD, ONLY : AD
USE GLOBAL_O3_MOD, ONLY : O3
# include "CMN_SIZE" ! Size parameters
! Arguments
INTEGER, INTENT(IN) :: I, J, L
! Local variables
REAL*8 :: O3_MOLEC_CM3
! External functions
REAL*8, EXTERNAL :: BOXVL
!=================================================================
! GET_O3 begins here!
!=================================================================
! Get O3 [v/v] for this gridbox & month & convert to [molec/cm3]
O3_MOLEC_CM3 = O3(I,J,L) * ( 6.022d23 / 28.97d-3 ) *
& AD(I,J,L) / BOXVL(I,J,L)
! Return to calling program
END FUNCTION GET_O3
!------------------------------------------------------------------------------
FUNCTION GET_OH( I, J, L ) RESULT( OH_MOLEC_CM3 )
!
!******************************************************************************
! Function GET_OH returns monthly mean OH and imposes a diurnal variation.
! (eck, bmy, 12/7/04)
!
! Arguments as Input:
! ============================================================================
! (1-3) I, J, L (INTEGER) : Grid box indices for lon, lat, vertical level
!
! NOTES:
!******************************************************************************
!
! References to F90 modules
USE DAO_MOD, ONLY : SUNCOS
USE GLOBAL_OH_MOD, ONLY : OH
USE TIME_MOD, ONLY : GET_TS_CHEM
# 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!
!=================================================================
! 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
! Return to calling program
END FUNCTION GET_OH
!------------------------------------------------------------------------------
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, 12/8/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)
! (4 ) Also added parallel loop over grid boxes (eck, bmy, 12/8/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" ! Physical constants
! 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
! Loop over surface grid boxes
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, YMID_R, IJLOOP, TIMLOC, AHR )
DO J = 1, JJPAR
! Grid box latitude center [radians]
YMID_R = GET_YMID_R( J )
DO I = 1, IIPAR
! Increment IJLOOP
IJLOOP = ( (J-1) * IIPAR ) + I
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
!$OMP END PARALLEL DO
! 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 DEFINE_TAGGED_Hg
!
!******************************************************************************
! Subroutine DEFINE_TAGGED_Hg defines the tagged tracer numbers for
! anthropogenic (by geographic region) Hg0, Hg2, and HgP. The position of
! Hg2 and HgP in the DEPSAV array is also computed for future use. This
! routine only has to be called once at the start of the simulation.
! (eck, cdh, bmy, 12/15/04, 4/6/06)
!
! NOTES:
! (1 ) Now only define AN_Hg0, AN_Hg2, AN_HgP. Now use ID_Hg0, ID_Hg2, and
! ID_HgP index arrays from "tracerid_mod.f". (eck, cdh, bmy, 4/6/06)
!******************************************************************************
!
! References to F90 modules
USE GRID_MOD, ONLY : GET_XMID, GET_YMID
USE ERROR_MOD, ONLY : ERROR_STOP
USE TRACER_MOD, ONLY : N_TRACERS
USE TRACERID_MOD, ONLY : ID_Hg0, ID_Hg2, ID_HgP
USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_Hg_na, ID_Hg_eu, ID_Hg_as
USE TRACERID_MOD, ONLY : ID_Hg_rw, ID_Hg_oc, ID_Hg_ln, ID_Hg_nt
# include "CMN_SIZE" ! Size parameters
! Local variables
INTEGER :: I, J
REAL*8 :: X, Y
CHARACTER(LEN=255) :: LOCATION
!=================================================================
! DEFINE_TAGGED_Hg begins here!
!=================================================================
! Location string for ERROR_STOP
LOCATION = 'DEFINE_TAGGED_Hg ("mercury_mod.f")'
!---------------------------------
! Anthropogenic tracer indices
!---------------------------------
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, X, Y )
! Loop over latitudes
DO J = 1, JJPAR
! Grid-box latitude [degrees]
Y = GET_YMID( J )
! Loop over longitudes
DO I = 1, IIPAR
! Grid box longitude [degrees]
X = GET_XMID( I )
! North American Anthro Hg
IF ( ( X >= -172.5 .and. X < -17.5 ) .and.
& ( Y >= 24.0 .and. Y < 88.0 ) ) THEN
AN_Hg0(I,J) = ID_Hg0(ID_Hg_na)
AN_Hg2(I,J) = ID_Hg2(ID_Hg_na)
AN_HgP(I,J) = ID_HgP(ID_Hg_na)
! European Anthro Hg (1st sub-box)
ELSE IF ( ( X >= -17.5 .and. X < 72.5 ) .and.
& ( Y >= 36.0 .and. Y < 45.0 ) ) THEN
AN_Hg0(I,J) = ID_Hg0(ID_Hg_eu)
AN_Hg2(I,J) = ID_Hg2(ID_Hg_eu)
AN_HgP(I,J) = ID_HgP(ID_Hg_eu)
! European Anthro Hg (2nd sub-box)
ELSE IF ( ( X >= -17.5 .and. X < 172.5 ) .and.
& ( Y >= 45.0 .and. Y < 88.0 ) ) THEN
AN_Hg0(I,J) = ID_Hg0(ID_Hg_eu)
AN_Hg2(I,J) = ID_Hg2(ID_Hg_eu)
AN_HgP(I,J) = ID_HgP(ID_Hg_eu)
! Asian Anthro Hg
ELSE IF ( ( X >= 70.0 .and. X < 152.5 ) .and.
& ( Y >= 8.0 .and. Y < 45.0 ) ) THEN
AN_Hg0(I,J) = ID_Hg0(ID_Hg_as)
AN_Hg2(I,J) = ID_Hg2(ID_Hg_as)
AN_HgP(I,J) = ID_HgP(ID_Hg_as)
! Rest-of-world Anthro Hg
ELSE
AN_Hg0(I,J) = ID_Hg0(ID_Hg_rw)
AN_Hg2(I,J) = ID_Hg2(ID_Hg_rw)
AN_HgP(I,J) = ID_HgP(ID_Hg_rw)
ENDIF
ENDDO
ENDDO
!$OMP END PARALLEL DO
!=================================================================
! Error check tracers: make sure they are not zero
! since this can cause array-out-of-bounds errors
!=================================================================
! Tagged Hg0
IF ( ANY( AN_Hg0 == 0 ) ) THEN
CALL ERROR_STOP( 'AN_Hg0 tracers are undefined!', LOCATION )
ENDIF
! Tagged Hg2
IF ( ANY( AN_Hg2 == 0 ) ) THEN
CALL ERROR_STOP( 'AN_Hg2 tracers are undefined!', LOCATION )
ENDIF
! Tagged Hg2
IF ( ANY( AN_HgP == 0 ) ) THEN
CALL ERROR_STOP( 'AN_HgP tracer are undefined!', LOCATION )
ENDIF
!---------------------------------
! Error check # of tracers
!---------------------------------
IF ( N_TRACERS < 21 ) THEN
CALL ERROR_STOP( 'Too few Hg tagged tracers!',
& 'DEFINE_TAGGED_Hg ("mercury_mod.f")' )
ENDIF
! Return to calling program
END SUBROUTINE DEFINE_TAGGED_Hg
!------------------------------------------------------------------------------
SUBROUTINE INIT_MERCURY( THIS_ANTHRO_Hg_YEAR )
!
!******************************************************************************
! Subroutine INIT_MERCURY allocates and zeroes all module arrays.
! (eck, cdh, sas, bmy, 12/2/04, 4/6/06)
!
! NOTES:
! (1 ) Removed reference to FEMIS array. Now also allocates and zeroes
! the T44 array. Added reference to CMN_DIAG. Now references
! N_TRACERS from "tracer_mod.f". (bmy, 2/24/05)
! (2 ) EHg0_an, EHg2_an, EHgP_an are now 2-D arrays. Now modified for
! updated ocean mercury module. (eck, cdh, sas, bmy, 4/6/06)
!******************************************************************************
!
! References to F90 modules
USE DRYDEP_MOD, ONLY : DEPNAME, NUMDEP
USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP
USE LOGICAL_MOD, ONLY : LSPLIT, LDRYD
USE TRACER_MOD, ONLY : N_TRACERS
USE TRACERID_MOD, ONLY : N_Hg_CATS
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! ND44
! Arguments
INTEGER, INTENT(IN) :: THIS_ANTHRO_Hg_YEAR
! Local variables
LOGICAL, SAVE :: IS_INIT = .FALSE.
INTEGER :: AS, N
CHARACTER(LEN=255) :: LOCATION
!=================================================================
! INIT_MERCURY begins here!
!=================================================================
! Return if we have already allocated arrays
IF ( IS_INIT ) RETURN
! Anthropogenic Hg emissions year
ANTHRO_Hg_YEAR = THIS_ANTHRO_Hg_YEAR
! Location string for ERROR_STOP
LOCATION = 'DEFINE_TAGGED_Hg ("mercury_mod.f")'
!=================================================================
! Allocate arrays
!=================================================================
ALLOCATE( COSZM( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'COSZM' )
COSZM = 0d0
ALLOCATE( EHg0_an( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHg0_an' )
EHg0_an = 0d0
ALLOCATE( EHg2_an( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHg2_an' )
EHg2_an = 0d0
ALLOCATE( EHgP_an( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHgP_an' )
EHgP_an = 0d0
ALLOCATE( EHg0_oc( IIPAR, JJPAR, N_Hg_CATS ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHg0_oc' )
EHg0_oc = 0d0
ALLOCATE( EHg0_ln( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHg0_ln' )
EHg0_ln = 0d0
ALLOCATE( EHg0_nt( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHg0_nt' )
EHg0_nt = 0d0
ALLOCATE( TCOSZ( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'TCOSZ' )
TCOSZ = 0d0
ALLOCATE( TTDAY( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'TTDAY' )
TTDAY = 0d0
! Allocate ZERO_DVEL if drydep is turned off
IF ( .not. LDRYD ) THEN
ALLOCATE( ZERO_DVEL( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'ZERO_DVEL' )
ZERO_DVEL = 0d0
ENDIF
!=================================================================
! Allocate & initialize arrays for tagged tracer indices
!=================================================================
IF ( LSPLIT ) THEN
! Tracer indices for tagged anthro regions
ALLOCATE( AN_Hg0( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'AN_Hg0' )
AN_Hg0 = 0d0
ALLOCATE( AN_Hg2( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'AN_Hg2' )
AN_Hg2 = 0d0
ALLOCATE( AN_HgP( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'AN_HgP' )
AN_HgP = 0d0
! Define the tagged tracer indices
CALL DEFINE_TAGGED_Hg
ENDIF
!=================================================================
! Locate the drydep species w/in the DEPSAV array (for ND44)
!=================================================================
! Initialize flags
DRYHg2 = 0d0
DRYHgP = 0d0
! If drydep is turned on ...
IF ( LDRYD ) THEN
! Loop over drydep species
DO N = 1, NUMDEP
! Locate by DEPNAME
SELECT CASE ( TRIM( DEPNAME(N) ) )
CASE( 'Hg2' )
DRYHg2 = N
CASE( 'HgP' )
DRYHgP = N
CASE DEFAULT
! nothing
END SELECT
ENDDO
! Temporary array for ND44 diagnostic
!----------------------------------------------------------------
! Prior to 4/6/06:
! For now, comment this out so that MERCURY MENU can be placed
! above the DIAGNOSTIC MENU in "input.geos" (bmy, 2/27/06)
!IF ( ND44 > 0 ) THEN
!----------------------------------------------------------------
ALLOCATE( T44( IIPAR, JJPAR, LLTROP, N_TRACERS ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'T44' )
T44 = 0e0
!----------------------------------------------------------------
! Prior to 4/6/06:
! For now, comment this out so that MERCURY MENU can be placed
! above the DIAGNOSTIC MENU in "input.geos" (bmy, 2/27/06)
!ENDIF
!----------------------------------------------------------------
ENDIF
! Reset IS_INIT, since we have already allocated arrays
IS_INIT = .TRUE.
! Return to calling program
END SUBROUTINE INIT_MERCURY
!------------------------------------------------------------------------------
SUBROUTINE CLEANUP_MERCURY
!
!******************************************************************************
! Subroutine CLEANUP_MERCURY deallocates all module arrays.
! (eck, bmy, 12/6/04, 2/24/05)
!
! NOTES:
! (1 ) Now deallocate MLD, NPP, RAD (sas, bmy, 1/18/05)
! (2 ) Now deallocate T44 (bmy, 2/24/05)
!******************************************************************************
!
!=================================================================
! CLEANUP_MERCURY begins here!
!=================================================================
IF ( ALLOCATED( AN_Hg0 ) ) DEALLOCATE( AN_Hg0 )
IF ( ALLOCATED( AN_Hg2 ) ) DEALLOCATE( AN_Hg2 )
IF ( ALLOCATED( AN_HgP ) ) DEALLOCATE( AN_HgP )
IF ( ALLOCATED( COSZM ) ) DEALLOCATE( COSZM )
IF ( ALLOCATED( EHg0_an ) ) DEALLOCATE( EHg0_an )
IF ( ALLOCATED( EHg2_an ) ) DEALLOCATE( EHg2_an )
IF ( ALLOCATED( EHgP_an ) ) DEALLOCATE( EHgP_an )
IF ( ALLOCATED( EHg0_oc ) ) DEALLOCATE( EHg0_oc )
IF ( ALLOCATED( EHg0_ln ) ) DEALLOCATE( EHg0_ln )
IF ( ALLOCATED( EHg0_nt ) ) DEALLOCATE( EHg0_nt )
IF ( ALLOCATED( TCOSZ ) ) DEALLOCATE( TCOSZ )
IF ( ALLOCATED( T44 ) ) DEALLOCATE( T44 )
IF ( ALLOCATED( TTDAY ) ) DEALLOCATE( TTDAY )
! Return to calling program
END SUBROUTINE CLEANUP_MERCURY
!------------------------------------------------------------------------------
! End of module
END MODULE MERCURY_MOD
Reference in New Issue View Git Blame Copy Permalink