From 1862319b87c7a0b973c8d40dd84946324ed68f1c Mon Sep 17 00:00:00 2001 From: Balwinder Singh Date: Fri, 30 Oct 2015 17:08:55 -0700 Subject: [PATCH 1/2] Add bc and pom in the coarse mode of the MAM3/MAM4 chem pkgs This commit adds BC and POM in the 3rd mode (coarse) of MAM3 and MAM4 chemistry packages. To run the model is this configuration, user has to configure the model using "rain_evap_to_coarse_aero" option. This option will act as a CPP directive where turning this on would add BC and POM into the coarse mode of MAM3 or MAM4 chemistry packages. This commit also fixes a bug in the chemistry preprocessor. [BFB] --- components/cam/bld/build-namelist | 172 ++-- .../cam/bld/config_files/definition.xml | 3 + components/cam/bld/configure | 14 + .../namelist_files/master_aer_drydep_list.xml | 1 + .../namelist_files/master_aer_wetdep_list.xml | 1 + .../cam/chem_proc/src/cam_chempp/eqrep.f | 9 +- .../cam/src/chemistry/aerosol/wetdep.F90 | 843 +++++++++++++++--- .../src/chemistry/modal_aero/aero_model.F90 | 738 +++++++++++---- .../modal_aero/modal_aero_convproc.F90 | 451 +++++++++- .../chemistry/modal_aero/modal_aero_data.F90 | 25 + .../modal_aero/modal_aero_initialize_data.F90 | 13 +- .../cam/src/chemistry/mozart/chemistry.F90 | 8 +- .../src/dynamics/se/share/prim_state_mod.F90 | 2 +- components/cam/src/physics/cam/gw_drag.F90 | 2 +- .../cam/src/physics/cam/phys_control.F90 | 7 +- 15 files changed, 1866 insertions(+), 423 deletions(-) diff --git a/components/cam/bld/build-namelist b/components/cam/bld/build-namelist index d786553702e1..4fa66c24923b 100755 --- a/components/cam/bld/build-namelist +++ b/components/cam/bld/build-namelist @@ -685,6 +685,10 @@ add_default($nl, 'atm_cpl_dt', 'val'=>$nl->get_value('dtime')); # Change default to using a single file. add_default($nl, 'profile_single_file', 'val'=>'.true.'); +#BSINGH - Get the value of RAIN_EVAP_TO_COARSE_AERO variable +my $rain_evap_to_coarse_aero = $cfg->get('rain_evap_to_coarse_aero'); #BSINGH - See if rain_evap_to_coarse_aero option is selected +if ($print>=1) { print "Running model with rain_evap_to_coarse_aero (1-YES, 0-NO)?: $rain_evap_to_coarse_aero $eol"; } + #----------------------------------------------------------------------------------------------- # Add defaults for the CAM component @@ -1068,37 +1072,73 @@ if ($aer_model eq 'mam' ) { @mode_types = qw(accum aitken coarse); @mode_num = qw(num_a1 num_a2 num_a3); @mode_num_cw = qw(num_c1 num_c2 num_c3); - @mode_spec = ( - [qw(so4_a1 pom_a1 soa_a1 bc_a1 dst_a1 ncl_a1)], - [qw(so4_a2 soa_a2 ncl_a2)], - [qw(dst_a3 ncl_a3 so4_a3)], - ); - @mode_spec_type = ( - [qw(sulfate p-organic s-organic black-c dust seasalt)], - [qw(sulfate s-organic seasalt)], - [qw(dust seasalt sulfate)], - ); - @mode_spec_cw = ( - [qw(so4_c1 pom_c1 soa_c1 bc_c1 dst_c1 ncl_c1)], - [qw(so4_c2 soa_c2 ncl_c2)], - [qw(dst_c3 ncl_c3 so4_c3)], - ); - + if ($rain_evap_to_coarse_aero == 0) { #default + @mode_spec = ( + [qw(so4_a1 pom_a1 soa_a1 bc_a1 dst_a1 ncl_a1)], + [qw(so4_a2 soa_a2 ncl_a2)], + [qw(dst_a3 ncl_a3 so4_a3)], + ); + @mode_spec_type = ( + [qw(sulfate p-organic s-organic black-c dust seasalt)], + [qw(sulfate s-organic seasalt)], + [qw(dust seasalt sulfate)], + ); + @mode_spec_cw = ( + [qw(so4_c1 pom_c1 soa_c1 bc_c1 dst_c1 ncl_c1)], + [qw(so4_c2 soa_c2 ncl_c2)], + [qw(dst_c3 ncl_c3 so4_c3)], + ); + } + else{ + @mode_spec = ( + [qw(so4_a1 pom_a1 soa_a1 bc_a1 dst_a1 ncl_a1)], + [qw(so4_a2 soa_a2 ncl_a2)], + [qw(dst_a3 ncl_a3 so4_a3 bc_a3 pom_a3 soa_a3)], + ); + @mode_spec_type = ( + [qw(sulfate p-organic s-organic black-c dust seasalt)], + [qw(sulfate s-organic seasalt)], + [qw(dust seasalt sulfate black-c p-organic s-organic)], + ); + @mode_spec_cw = ( + [qw(so4_c1 pom_c1 soa_c1 bc_c1 dst_c1 ncl_c1)], + [qw(so4_c2 soa_c2 ncl_c2)], + [qw(dst_c3 ncl_c3 so4_c3 bc_c3 pom_c3 soa_c3)], + ); + } if ($chem =~ /_mam3/) { @mode_num_src = qw(A A A); - @mode_spec_src = ( - [qw(A A A A A A)], - [qw(A A A)], - [qw(A A A)], - ); + if ($rain_evap_to_coarse_aero == 0) { #default + @mode_spec_src = ( + [qw(A A A A A A)], + [qw(A A A)], + [qw(A A A)], + ); + } + else{ + @mode_spec_src = ( + [qw(A A A A A A)], + [qw(A A A)], + [qw(A A A A A A)], + ); + } } else { @mode_num_src = qw(N N N); - @mode_spec_src = ( - [qw(N N N N N N)], - [qw(N N N)], - [qw(N N N)], - ); + if ($rain_evap_to_coarse_aero == 0) { #default + @mode_spec_src = ( + [qw(N N N N N N)], + [qw(N N N)], + [qw(N N N)], + ); + } + else{ + @mode_spec_src = ( + [qw(N N N N N N)], + [qw(N N N)], + [qw(N N N N N N)], + ); + } } } elsif($aero_modes eq '4mode') { # For 4 modes @@ -1113,32 +1153,62 @@ if ($aer_model eq 'mam' ) { @mode_types = qw(accum aitken coarse primary_carbon); @mode_num = qw(num_a1 num_a2 num_a3 num_a4); @mode_num_cw = qw(num_c1 num_c2 num_c3 num_c4); - @mode_spec = ( - [qw(so4_a1 pom_a1 soa_a1 bc_a1 dst_a1 ncl_a1)], - [qw(so4_a2 soa_a2 ncl_a2)], - [qw(dst_a3 ncl_a3 so4_a3)], - [qw(pom_a4 bc_a4)], - ); - @mode_spec_type = ( - [qw(sulfate p-organic s-organic black-c dust seasalt)], - [qw(sulfate s-organic seasalt)], - [qw(dust seasalt sulfate)], - [qw(p-organic black-c)], - ); - @mode_spec_cw = ( - [qw(so4_c1 pom_c1 soa_c1 bc_c1 dst_c1 ncl_c1)], - [qw(so4_c2 soa_c2 ncl_c2)], - [qw(dst_c3 ncl_c3 so4_c3)], - [qw(pom_c4 bc_c4)], - ); + if ($rain_evap_to_coarse_aero == 0) { #default + @mode_spec = ( + [qw(so4_a1 pom_a1 soa_a1 bc_a1 dst_a1 ncl_a1)], + [qw(so4_a2 soa_a2 ncl_a2)], + [qw(dst_a3 ncl_a3 so4_a3)], + [qw(pom_a4 bc_a4)], + ); + @mode_spec_type = ( + [qw(sulfate p-organic s-organic black-c dust seasalt)], + [qw(sulfate s-organic seasalt)], + [qw(dust seasalt sulfate)], + [qw(p-organic black-c)], + ); + @mode_spec_cw = ( + [qw(so4_c1 pom_c1 soa_c1 bc_c1 dst_c1 ncl_c1)], + [qw(so4_c2 soa_c2 ncl_c2)], + [qw(dst_c3 ncl_c3 so4_c3)], + [qw(pom_c4 bc_c4)], + ); - @mode_num_src = qw(A A A A); - @mode_spec_src = ( - [qw(A A A A A A)], - [qw(A A A)], - [qw(A A A)], - [qw(A A)], - ); + @mode_num_src = qw(A A A A); + @mode_spec_src = ( + [qw(A A A A A A)], + [qw(A A A)], + [qw(A A A)], + [qw(A A)], + ); + } + else{ + @mode_spec = ( + [qw(so4_a1 pom_a1 soa_a1 bc_a1 dst_a1 ncl_a1)], + [qw(so4_a2 soa_a2 ncl_a2)], + [qw(dst_a3 ncl_a3 so4_a3 bc_a3 pom_a3 soa_a3)], + [qw(pom_a4 bc_a4)], + ); + @mode_spec_type = ( + [qw(sulfate p-organic s-organic black-c dust seasalt)], + [qw(sulfate s-organic seasalt)], + [qw(dust seasalt sulfate black-c p-organic s-organic)], + [qw(p-organic black-c)], + ); + @mode_spec_cw = ( + [qw(so4_c1 pom_c1 soa_c1 bc_c1 dst_c1 ncl_c1)], + [qw(so4_c2 soa_c2 ncl_c2)], + [qw(dst_c3 ncl_c3 so4_c3 bc_c3 pom_c3 soa_c3)], + [qw(pom_c4 bc_c4)], + ); + + @mode_num_src = qw(A A A A); + @mode_spec_src = ( + [qw(A A A A A A)], + [qw(A A A)], + [qw(A A A A A A)], + [qw(A A)], + ); + } } elsif($aero_modes eq '7mode') { diff --git a/components/cam/bld/config_files/definition.xml b/components/cam/bld/config_files/definition.xml index b78c1641975a..15f47d980161 100644 --- a/components/cam/bld/config_files/definition.xml +++ b/components/cam/bld/config_files/definition.xml @@ -208,6 +208,9 @@ User specified Fortran compiler overrides Makefile default. Type of Fortran compiler. Used when -fc specifies a generic wrapper script such as mpif90 or ftn. + +Switch to enable extra species (BC, POM and SOA) in coarse mode for MAM3 and MAM4 simulations: 0=off, 1=on. + Switch to enable debugging options for Fortran compiler: 0=off, 1=on. diff --git a/components/cam/bld/configure b/components/cam/bld/configure index c094e60b695d..fb468195abe1 100755 --- a/components/cam/bld/configure +++ b/components/cam/bld/configure @@ -218,6 +218,7 @@ OPTIONS Makefile defaults. -cosp Enable the COSP simulator. -debug Switch to turn on building CAM with debugging compiler options. + -rain_evap_to_coarse_aero Switch to turn on BC, POM and SOA in the MAM3 and MAM4 coarse mode (mam mode 3) -defaults Specify a configuration file which will be used to supply defaults instead of one of the config_files/defaults_*.xml files. This file is used to specify model configuration parameters only. Parameters relating to the build which @@ -317,6 +318,7 @@ GetOptions( "cosp" => \$opts{'cosp'}, "cppdefs=s" => \$opts{'cppdefs'}, "debug" => \$opts{'debug'}, + "rain_evap_to_coarse_aero" => \$opts{'rain_evap_to_coarse_aero'}, "defaults=s" => \$opts{'defaults'}, "dyn=s" => \$opts{'dyn'}, "edit_chem_mech" => \$opts{'edit_chem_mech'}, @@ -823,6 +825,14 @@ if (defined $opts{'waccmx'}) { } my $waccmx = $cfg_ref->get('waccmx'); +# Use "rain_evap_to_coarse_aero" in MAM3 or MAM4? [BSINGH - For extra coarse mode species for BC, POM and SOA] +my $rain_evap_to_coarse_aero_opt = (defined $opts{'rain_evap_to_coarse_aero'}) ? 1 : 0; +$cfg_ref->set('rain_evap_to_coarse_aero', $rain_evap_to_coarse_aero_opt); +my $rain_evap_to_coarse_aero = $rain_evap_to_coarse_aero_opt ? 1:0; + +if ($print>=2) { print "Is rain_evap_to_coarse_aero active (0-NO; 1-YES)?: $rain_evap_to_coarse_aero$eol"; } + + #----------------------------------------------------------------------------------------------- # Prognostic species package(s) @@ -1324,6 +1334,10 @@ if ($chem_pkg =~ '_mam3') { $chem_cppdefs = ' -DMODAL_AERO -DMODAL_AERO_7MODE '; } +if ($rain_evap_to_coarse_aero == 1 && ($chem_pkg =~ '_mam3' || $chem_pkg =~ '_mam4')) { + $chem_cppdefs = "$chem_cppdefs -DRAIN_EVAP_TO_COARSE_AERO " +} + my $carma_nadv = 0; my $carma_cppdefs = ''; diff --git a/components/cam/bld/namelist_files/master_aer_drydep_list.xml b/components/cam/bld/namelist_files/master_aer_drydep_list.xml index bb8653588f0b..a350ffe7c56e 100644 --- a/components/cam/bld/namelist_files/master_aer_drydep_list.xml +++ b/components/cam/bld/namelist_files/master_aer_drydep_list.xml @@ -27,6 +27,7 @@ so4_a3 pom_a3 bc_a3 + soa_a3 num_a3 ncl_a4 so4_a4 diff --git a/components/cam/bld/namelist_files/master_aer_wetdep_list.xml b/components/cam/bld/namelist_files/master_aer_wetdep_list.xml index adc5b75c1299..c59b85753fe9 100644 --- a/components/cam/bld/namelist_files/master_aer_wetdep_list.xml +++ b/components/cam/bld/namelist_files/master_aer_wetdep_list.xml @@ -32,6 +32,7 @@ so4_a3 pom_a3 bc_a3 + soa_a3 num_a3 ncl_a4 so4_a4 diff --git a/components/cam/chem_proc/src/cam_chempp/eqrep.f b/components/cam/chem_proc/src/cam_chempp/eqrep.f index 7869f8540ef1..f8add5f2f33d 100644 --- a/components/cam/chem_proc/src/cam_chempp/eqrep.f +++ b/components/cam/chem_proc/src/cam_chempp/eqrep.f @@ -162,7 +162,11 @@ subroutine EQUATION_REP( & end if production = .true. rxno = rxmap(j,1,i) - if( coeff_ind(rxno) /= 0 .and. coeffs(k-(i+1),coeff_ind(rxno)) /= 1.e0 ) then +!BSINGH(12/20/2013): Original line: if( coeff_ind(rxno) /= 0 .and. coeffs(k-(i+1),coeff_ind(rxno)) /= 1.e0 ) then +!BSINGH(12/20/2013): Mods start (first check if coeff_ind(rxno) is non zero before using it as an index of coeffs array) + if( coeff_ind(rxno) /= 0) then + if( coeffs(k-(i+1),coeff_ind(rxno)) /= 1.e0 ) then +!BSINGH -ENDS call NUMCON( eq_piece(buf_pos:), coeffs(k-(i+1),coeff_ind(rxno)), 'l' ) buf_pos = LEN_TRIM( eq_piece ) + 1 if( rxno > phtcnt ) then @@ -179,6 +183,9 @@ subroutine EQUATION_REP( & end if buf_pos = buf_pos + 1 end if +!BSINGH(12/20/2013): Mods start + endif +!BSINGH -ENDS if( rxno > phtcnt ) then call NUMCON( eq_piece(buf_pos:), REAL(rxno-phtcnt), 'l' ) else diff --git a/components/cam/src/chemistry/aerosol/wetdep.F90 b/components/cam/src/chemistry/aerosol/wetdep.F90 index 7bed3ceca0b1..973efe6fdc65 100644 --- a/components/cam/src/chemistry/aerosol/wetdep.F90 +++ b/components/cam/src/chemistry/aerosol/wetdep.F90 @@ -20,6 +20,7 @@ module wetdep public :: wetdepa_v2 ! scavenging codes for very soluble aerosols -- CAM5 version public :: wetdepg ! scavenging of gas phase constituents by henry's law public :: clddiag ! calc of cloudy volume and rain mixing ratio +public :: faer_resusp_vs_fprec_evap_mpln public :: wetdep_inputs_t public :: wetdep_init @@ -272,16 +273,36 @@ end subroutine clddiag !============================================================================== -! This is the CAM5 version of wetdepa. - -subroutine wetdepa_v2( t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, conicw, precs, conds, & - evaps, cwat, tracer, deltat, & - scavt, iscavt, cldv, cldvcu, cldvst, dlf, fracis, sol_fact, ncol, & - scavcoef, is_strat_cloudborne, rate1ord_cw2pr_st, qqcw, f_act_conv, & - icscavt, isscavt, bcscavt, bsscavt, rcscavt, rsscavt, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in,resus_fix ) +! REASTER 08/05/2015 +! changed arguments +! put them in a more logical order +! optional arguments are now mandatory, and commented out: +! all "if ( present(xx) )" tests +! any code for ".not. present(xx)" cases +! eliminated the sol_fact**_in - now just use sol_fact** + +! old argument order +! ubroutine wetdepa_v2( t, p, q, pdel, & +! cldt, cldc, cmfdqr, evapc, conicw, precs, conds, & +! evaps, cwat, tracer, deltat, & +! scavt, iscavt, cldv, cldvcu, cldvst, dlf, fracis, sol_fact, ncol, & +! scavcoef, is_strat_cloudborne, rate1ord_cw2pr_st, qqcw, f_act_conv, & +! icscavt, isscavt, bcscavt, bsscavt, rcscavt, rsscavt, & +! sol_facti_in, sol_factbi_in, sol_factii_in, & +! sol_factic_in, sol_factiic_in, resus_fix ) +! note - p, q, cldv not needed + +! new argument order +subroutine wetdepa_v2( ncol, deltat, & + t, p, q, pdel, & + cmfdqr, evapc, dlf, conicw, & + precs, conds, evaps, cwat, & + cldt, cldc, cldv, cldvcu, cldvst, & + sol_factb, sol_factbi, sol_facti, sol_factii, sol_factic, sol_factiic, & + mam_prevap_resusp_optcc, is_strat_cloudborne, scavcoef, rate1ord_cw2pr_st, f_act_conv, & + tracer, qqcw, & + fracis, scavt, iscavt, & + icscavt, isscavt, bcscavt, bsscavt, rcscavt, rsscavt ) !----------------------------------------------------------------------- ! Purpose: @@ -296,68 +317,72 @@ subroutine wetdepa_v2( t, p, q, pdel, & implicit none + integer, intent(in) :: ncol + real(r8), intent(in) ::& + deltat, &! time step t(pcols,pver), &! temperature p(pcols,pver), &! pressure q(pcols,pver), &! moisture pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction cmfdqr(pcols,pver), &! rate of production of convective precip ! Sungsu evapc(pcols,pver), &! Evaporation rate of convective precipitation + dlf(pcols,pver), &! Detrainment of convective condensate [kg/kg/s] ! Sungsu conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount precs(pcols,pver), &! rate of production of stratiform precip conds(pcols,pver), &! rate of production of condensate evaps(pcols,pver), &! rate of evaporation of precip + cwat(pcols,pver), &! cloud water amount + cldt(pcols,pver), &! total cloud fraction + cldc(pcols,pver), &! convective cloud fraction cldv(pcols,pver), &! total cloud fraction ! Sungsu cldvcu(pcols,pver), &! Convective precipitation area at the top interface of each layer cldvst(pcols,pver), &! Stratiform precipitation area at the top interface of each layer - dlf(pcols,pver), &! Detrainment of convective condensate [kg/kg/s] ! Sungsu - deltat, &! time step tracer(pcols,pver) ! trace species ! If subroutine is called with just sol_fact: ! sol_fact is used for both in- and below-cloud scavenging ! If subroutine is called with optional argument sol_facti_in: ! sol_fact is used for below cloud scavenging ! sol_facti is used for in cloud scavenging - real(r8), intent(in) :: sol_fact ! solubility factor (fraction of aer scavenged below & in, or just below or sol_facti_in is provided) - integer, intent(in) :: ncol - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged - logical, intent(in),optional :: resus_fix - ! rce 2010/05/01 - ! is_strat_cloudborne = .true. if tracer is stratiform-cloudborne aerosol; else .false. - logical, intent(in), optional :: is_strat_cloudborne - ! rate1ord_cw2pr_st = 1st order rate for strat cw to precip (1/s) - real(r8), intent(in), optional :: rate1ord_cw2pr_st(pcols,pver) - ! qqcw = strat-cloudborne aerosol corresponding to tracer when is_strat_cloudborne==.false.; else 0.0 - real(r8), intent(in), optional :: qqcw(pcols,pver) - ! f_act_conv = conv-cloud activation fraction when is_strat_cloudborne==.false.; else 0.0 - real(r8), intent(in), optional :: f_act_conv(pcols,pver) - ! end rce 2010/05/01 - real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factbi_in ! solubility factor (frac of aerosol scavenged below cloud by ice) - real(r8), intent(in), optional :: sol_factii_in ! solubility factor (frac of aerosol scavenged in cloud by ice) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds + integer, intent(in) :: mam_prevap_resusp_optcc + +! logical, intent(in) :: resus_fix + ! rce 2010/05/01 + ! is_strat_cloudborne = .true. if tracer is stratiform-cloudborne aerosol; else .false. + logical, intent(in) :: is_strat_cloudborne + real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) + ! rate1ord_cw2pr_st = 1st order rate for strat cw to precip (1/s) + real(r8), intent(in) :: rate1ord_cw2pr_st(pcols,pver) + ! qqcw = strat-cloudborne aerosol corresponding to tracer when is_strat_cloudborne==.false.; else 0.0 + ! f_act_conv = conv-cloud activation fraction when is_strat_cloudborne==.false.; else 0.0 + real(r8), intent(in) :: f_act_conv(pcols,pver) + + real(r8), intent(in) :: qqcw(pcols,pver) + ! end rce 2010/05/01 + +! real(r8), intent(in) :: sol_fact ! solubility factor (fraction of aer scavenged below & in, or just below or sol_facti is provided) + real(r8), intent(in) :: sol_factb ! solubility factor (frac of aerosol scavenged below cloud) + real(r8), intent(in) :: sol_factbi ! solubility factor (frac of aerosol scavenged below cloud by ice) + real(r8), intent(in) :: sol_facti ! solubility factor (frac of aerosol scavenged in cloud) + real(r8), intent(in) :: sol_factii ! solubility factor (frac of aerosol scavenged in cloud by ice) + real(r8), intent(in) :: sol_factic(pcols,pver) ! sol_facti for convective clouds + real(r8), intent(in) :: sol_factiic ! sol_factii for convective clouds + real(r8), intent(out) :: fracis(pcols,pver) ! fraction of species not scavenged + real(r8), intent(out) :: scavt(pcols,pver) ! scavenging tend + real(r8), intent(out) :: iscavt(pcols,pver) ! incloud scavenging tends - real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective - real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform - - real(r8), intent(out), optional :: rcscavt(pcols,pver) ! resuspension, convective - real(r8), intent(out), optional :: rsscavt(pcols,pver) ! resuspension, stratiform + real(r8), intent(out) :: icscavt(pcols,pver) ! incloud, convective + real(r8), intent(out) :: isscavt(pcols,pver) ! incloud, stratiform + real(r8), intent(out) :: bcscavt(pcols,pver) ! below cloud, convective + real(r8), intent(out) :: bsscavt(pcols,pver) ! below cloud, stratiform + real(r8), intent(out) :: rcscavt(pcols,pver) ! resuspension, convective + real(r8), intent(out) :: rsscavt(pcols,pver) ! resuspension, stratiform ! local variables @@ -416,17 +441,45 @@ subroutine wetdepa_v2( t, p, q, pdel, & ! End by Sungsu - real(r8) sol_facti, sol_factb ! in cloud and below cloud fraction of aerosol scavenged - real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice - real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds - real(r8) sol_factiic ! sol_factii for convective clouds +! real(r8) sol_facti, sol_factb ! in cloud and below cloud fraction of aerosol scavenged +! real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice +! real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds +! real(r8) sol_factiic ! sol_factii for convective clouds ! sol_factic & solfact_iic added for MODAL_AERO. ! For stratiform cloud, cloudborne aerosol is treated explicitly, ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. ! For convective cloud, cloudborne aerosol is not treated explicitly, ! and sol_factic is 1.0 for both cloudborne and interstitial. - ! ------------------------------------------------------------------------ + integer jstrcnv + + real(r8), parameter :: prec_smallaa = 1.0e-30_r8 ! 1e-30 kg/m2/s (or mm/s) = 3.2e-23 mm/yr + real(r8), parameter :: x_smallaa = 1.0e-30_r8 + + real(r8) arainx + real(r8) evapx + real(r8) pprdx + real(r8) precabc_base(pcols) ! conv precip at an effective cloud base for calculations in a particular layer + real(r8) precabs_base(pcols) ! strat precip at an effective cloud base for calculations in a particular layer + real(r8) precabx_old, precabx_tmp, precabx_new + real(r8) precabx_base_old, precabx_base_tmp, precabx_base_new + real(r8) precnums_base(pcols) ! stratiform precip number flux at the bottom of a particular layer + real(r8) precnumc_base(pcols) ! convective precip number flux at the bottom of a particular layer + real(r8) precnumx_base_old, precnumx_base_tmp, precnumx_base_new + real(r8) resusp_c ! aerosol mass re-suspension in a particular layer from convective rain + real(r8) resusp_s ! aerosol mass re-suspension in a particular layer from stratiform rain + + real(r8) resusp_x + real(r8) resusp_c_sv(pcols) + real(r8) resusp_s_sv(pcols) + real(r8) scavabx_old, scavabx_tmp, scavabx_new + real(r8) srcx + real(r8) tmpa, tmpb + real(r8) u_old, u_tmp + real(r8) x_old, x_tmp, x_ratio + + +! ------------------------------------------------------------------------ ! omsm = 1.-1.e-10 ! used to prevent roundoff errors below zero omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero precmin = 0.1_r8/8.64e4_r8 ! set critical value to 0.1 mm/day in kg/m2/s @@ -437,19 +490,24 @@ subroutine wetdepa_v2( t, p, q, pdel, & ! vfall = 4. ! default (if other sol_facts aren't in call, set all to required sol_fact - sol_facti = sol_fact - sol_factb = sol_fact - sol_factii = sol_fact - sol_factbi = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - if ( present(sol_factii_in) ) sol_factii = sol_factii_in - if ( present(sol_factbi_in) ) sol_factbi = sol_factbi_in - - sol_factic = sol_facti - sol_factiic = sol_factii - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - if ( present(sol_factiic_in) ) sol_factiic = sol_factiic_in +! sol_facti = sol_fact +! sol_factb = sol_fact +! sol_factii = sol_fact +! sol_factbi = sol_fact + +! if ( present(sol_facti_in) ) sol_facti = sol_facti_in +! if ( present(sol_factii_in) ) sol_factii = sol_factii_in +! if ( present(sol_factbi_in) ) sol_factbi = sol_factbi_in +! sol_facti = sol_facti_in +! sol_factii = sol_factii_in +! sol_factbi = sol_factbi_in + +! sol_factic = sol_facti +! sol_factiic = sol_factii +! if ( present(sol_factic_in ) ) sol_factic = sol_factic_in +! if ( present(sol_factiic_in) ) sol_factiic = sol_factiic_in +! sol_factic = sol_factic_in +! sol_factiic = sol_factiic_in ! this section of code is for highly soluble aerosols, ! the assumption is that within the cloud that @@ -458,7 +516,6 @@ subroutine wetdepa_v2( t, p, q, pdel, & ! for both convective and stratiform clouds, ! the fraction of cloud water converted to precip defines ! the amount of tracer which is pulled out. - ! do i = 1,pcols precabs(i) = 0 @@ -469,6 +526,13 @@ subroutine wetdepa_v2( t, p, q, pdel, & cldmabs(i) = 0 cldmabc(i) = 0 + precabs_base(i) = 0.0_r8 + precabc_base(i) = 0.0_r8 + precnums_base(i) = 0.0_r8 + precnumc_base(i) = 0.0_r8 + resusp_c_sv(i) = 0.0_r8 + resusp_s_sv(i) = 0.0_r8 + ! Jan.16. Sungsu ! I added below to compute vertically projected cumulus and stratus fractions from the top to the ! current model layer by assuming a simple independent maximum overlapping assumption for @@ -479,7 +543,9 @@ subroutine wetdepa_v2( t, p, q, pdel, & end do +main_k_loop: & do k = 1,pver +main_i_loop: & do i = 1,ncol tc = t(i,k) - tmelt weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice @@ -500,6 +566,12 @@ subroutine wetdepa_v2( t, p, q, pdel, & fracev_cu(i) = evapc(i,k)*pdel(i,k)/gravit/max(1.e-12_r8,precabc(i)) fracev_cu(i) = max(0._r8,min(1._r8,fracev_cu(i))) ! Sungsu + + if (mam_prevap_resusp_optcc <= 0) then + fracev(i) = 0.0_r8 + fracev_cu(i) = 0.0_r8 + endif + ! ****************** Convection *************************** ! now do the convective scavenging @@ -539,7 +611,7 @@ subroutine wetdepa_v2( t, p, q, pdel, & ! srcs1 = 0. ! Jan.02.2010. Sungsu : cldt --> cldc below. ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi, 2011/03/29 +! if (present(is_strat_cloudborne)) then ! Tianyi, 2011/03/29 if ( is_strat_cloudborne ) then ! only strat in-cloud removal affects strat-cloudborne aerosol srcs1 = 0._r8 @@ -549,10 +621,10 @@ subroutine wetdepa_v2( t, p, q, pdel, & srcs1 = sol_factic(i,k)*cldc(i,k)*fracp*tracer_incu*(1._r8-weight)/deltat & ! Liquid + sol_factiic *cldc(i,k)*fracp*tracer_incu*(weight)/deltat ! Ice end if - else - srcs1 = sol_factic(i,k)*cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factiic*cldc(i,k)*fracp*tracer(i,k)*(weight)/deltat ! ice - end if +! else +! srcs1 = sol_factic(i,k)*cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat & ! liquid +! + sol_factiic*cldc(i,k)*fracp*tracer(i,k)*(weight)/deltat ! ice +! end if !--mcb @@ -570,7 +642,7 @@ subroutine wetdepa_v2( t, p, q, pdel, & ! End by Sungsu ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi, 2011/03/29 +! if (present(is_strat_cloudborne)) then ! Tianyi, 2011/03/29 if ( is_strat_cloudborne ) then ! only strat in-cloud removal affects strat-cloudborne aerosol srcs2 = 0._r8 @@ -582,13 +654,13 @@ subroutine wetdepa_v2( t, p, q, pdel, & srcs2 = sol_factb *cldmabc(i)*odds*tracer_mean*(1._r8-weight)/deltat & ! Liquid + sol_factbi*cldmabc(i)*odds*tracer_mean*(weight)/deltat ! Ice end if - else - odds=max( & - min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8) & - *scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - srcs2 = sol_factb*cldmabc(i)*odds*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factbi*cldmabc(i)*odds*tracer(i,k)*(weight)/deltat !ice - end if +! else +! odds=max( & +! min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8) & +! *scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) +! srcs2 = sol_factb*cldmabc(i)*odds*tracer(i,k)*(1._r8-weight)/deltat & ! liquid +! + sol_factbi*cldmabc(i)*odds*tracer(i,k)*(weight)/deltat !ice +! end if !Note that using the temperature-determined weight doesn't make much sense here @@ -603,7 +675,7 @@ subroutine wetdepa_v2( t, p, q, pdel, & ! incloud scavenging ! rce 2010/05/01 - if(present(is_strat_cloudborne)) then ! Tianyi 2011/03/29 +! if(present(is_strat_cloudborne)) then ! Tianyi 2011/03/29 if ( is_strat_cloudborne ) then ! new code for stratiform incloud scav of cloudborne (modal) aerosol ! >> use the 1st order cw to precip rate calculated in microphysics routine @@ -618,26 +690,26 @@ subroutine wetdepa_v2( t, p, q, pdel, & ! strat in-cloud removal only affects strat-cloudborne aerosol srcs1 = 0._r8 end if - else - ! fracp is the fraction of cloud water converted to precip - ! Sungsu modified fracp as the convectiv case. - ! Below new formula by Sungsu of 'fracp' is necessary since 'cwat' is a LWC/IWC - ! that has already precipitated out, that is, 'cwat' does not contain - ! precipitation at all ! - ! fracp = precs(i,k)*deltat/max(cwat(i,k),1.e-12_r8) - fracp = precs(i,k)*deltat/max(cwat(i,k)+precs(i,k)*deltat,1.e-12_r8) ! Sungsu. Mar.19.2010. - fracp = max(0._r8,min(1._r8,fracp)) - ! fracp = 0. ! for debug - - ! assume the corresponding amnt of tracer is removed - !++mcb -- remove cldc; change cldt to cldv - ! srcs1 = (cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat - ! srcs1 = cldv(i,k)*fracp*tracer(i,k)/deltat & - ! srcs1 = cldt(i,k)*fracp*tracer(i,k)/deltat ! all condensate - ! Jan.02.2010. Sungsu : cldt --> cldt - cldc below. - srcs1 = sol_facti*(cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat*(1._r8-weight) & ! liquid - + sol_factii*(cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat*(weight) ! ice - end if +! else +! ! fracp is the fraction of cloud water converted to precip +! ! Sungsu modified fracp as the convectiv case. +! ! Below new formula by Sungsu of 'fracp' is necessary since 'cwat' is a LWC/IWC +! ! that has already precipitated out, that is, 'cwat' does not contain +! ! precipitation at all ! +! ! fracp = precs(i,k)*deltat/max(cwat(i,k),1.e-12_r8) +! fracp = precs(i,k)*deltat/max(cwat(i,k)+precs(i,k)*deltat,1.e-12_r8) ! Sungsu. Mar.19.2010. +! fracp = max(0._r8,min(1._r8,fracp)) +! ! fracp = 0. ! for debug +! +! ! assume the corresponding amnt of tracer is removed +! !++mcb -- remove cldc; change cldt to cldv +! ! srcs1 = (cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat +! ! srcs1 = cldv(i,k)*fracp*tracer(i,k)/deltat & +! ! srcs1 = cldt(i,k)*fracp*tracer(i,k)/deltat ! all condensate +! ! Jan.02.2010. Sungsu : cldt --> cldt - cldc below. +! srcs1 = sol_facti*(cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat*(1._r8-weight) & ! liquid +! + sol_factii*(cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat*(weight) ! ice +! end if ! end rce 2010/05/01 @@ -653,7 +725,7 @@ subroutine wetdepa_v2( t, p, q, pdel, & ! End by Sungsu ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi 2011/03/29 +! if (present(is_strat_cloudborne)) then ! Tianyi 2011/03/29 if ( is_strat_cloudborne ) then ! only strat in-cloud removal affects strat-cloudborne aerosol srcs2 = 0._r8 @@ -663,12 +735,12 @@ subroutine wetdepa_v2( t, p, q, pdel, & srcs2 = sol_factb *cldmabs(i)*odds*tracer_mean*(1._r8-weight)/deltat & ! Liquid + sol_factbi*cldmabs(i)*odds*tracer_mean*(weight)/deltat ! Ice end if - else - odds = precabs(i)/max(cldmabs(i),1.e-5_r8)*scavcoef(i,k)*deltat - odds = max(min(1._r8,odds),0._r8) - srcs2 =sol_factb*(cldmabs(i)*odds) *tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factbi*(cldmabs(i)*odds) *tracer(i,k)*(weight)/deltat ! ice - end if +! else +! odds = precabs(i)/max(cldmabs(i),1.e-5_r8)*scavcoef(i,k)*deltat +! odds = max(min(1._r8,odds),0._r8) +! srcs2 =sol_factb*(cldmabs(i)*odds) *tracer(i,k)*(1._r8-weight)/deltat & ! liquid +! + sol_factbi*(cldmabs(i)*odds) *tracer(i,k)*(weight)/deltat ! ice +! end if !Note that using the temperature-determined weight doesn't make much sense here @@ -694,53 +766,272 @@ subroutine wetdepa_v2( t, p, q, pdel, & ! tend is all tracer removed by scavenging, plus all re-appearing from evaporation above ! Sungsu added cumulus contribution in the below 3 blocks - scavt(i,k) = -srct(i) + (fracev(i)*scavab(i)+fracev_cu(i)*scavabc(i))*gravit/pdel(i,k) - iscavt(i,k) = -(srcc*finc + srcs*fins)*omsm - if ( present(icscavt) ) icscavt(i,k) = -(srcc*finc) * omsm - if ( present(isscavt) ) isscavt(i,k) = -(srcs*fins) * omsm +! mam_prevap_resusp_optcc values: +! 0 = no resuspension +! 1 = linear resuspension of aerosol mass or number following original mam coding +! 2 = same as 1 but resuspension tendencies are in rc/sscavt rather than combined with bc/sscavt +! 3 = same as 2 but with some added "xxx = max( 0, xxx)" lines +! 130 = non-linear resuspension of aerosol mass based on scavenged aerosol mass +! 230 = non-linear resuspension of aerosol number based on raindrop number +resusp_block_aa: & + if ( mam_prevap_resusp_optcc >= 100) then + +jstrcnv_loop_aa: & + do jstrcnv = 1, 2 + +! step 1 - load working ("x") variables from stratiform ("s") or convective ("c") variables + if (jstrcnv == 1) then + pprdx = precs(i,k) + evapx = evaps(i,k) + precabx_old = precabs(i) + precabx_base_old = precabs_base(i) + if ( mam_prevap_resusp_optcc <= 130) then + scavabx_old = scavab(i) + srcx = srcs + else + precnumx_base_old = precnums_base(i) + arainx = cldvst(i,min(k+1,pver)) + end if + else + pprdx = cmfdqr(i,k) + evapx = evapc(i,k) + precabx_old = precabc(i) + precabx_base_old = precabc_base(i) + if ( mam_prevap_resusp_optcc <= 130) then + scavabx_old = scavabc(i) + srcx = srcc + else + precnumx_base_old = precnumc_base(i) + arainx = cldvcu(i,min(k+1,pver)) + end if + end if - if(.not.present(resus_fix)) then - if ( present(bcscavt) ) bcscavt(i,k) = -(srcc * (1-finc)) * omsm + & - fracev_cu(i)*scavabc(i)*gravit/pdel(i,k) - if ( present(bsscavt) ) bsscavt(i,k) = -(srcs * (1-fins)) * omsm + & - fracev(i)*scavab(i)*gravit/pdel(i,k) +! force these to be non-negative + precabx_base_old = max( 0.0_r8, precabx_base_old ) + precabx_old = max( 0.0_r8, precabx_old ) + precabx_old = min( precabx_base_old, precabx_old ) + if ( mam_prevap_resusp_optcc <= 130) then + scavabx_old = max( 0.0_r8, scavabx_old ) + else + precnumx_base_old = max( 0.0_r8, precnumx_base_old ) + precnumx_base_tmp = precnumx_base_old + end if + +! step 2 - do evaporation and resuspension + precabx_base_tmp = precabx_base_old + tmpa = max( 0.0_r8, evapx*pdel(i,k)/gravit ) + precabx_tmp = max( 0.0_r8, precabx_old - tmpa ) + precabx_tmp = min( precabx_base_tmp, precabx_tmp ) + + if (precabx_tmp < prec_smallaa) then + ! precip rate is essentially zero so do complete resuspension + if ( mam_prevap_resusp_optcc <= 130) then + ! linear resuspension based on scavenged aerosol mass or number + scavabx_tmp = 0.0_r8 + resusp_x = scavabx_old + else + ! non-linear resuspension of aerosol number based on raindrop number + if (precabx_base_old < prec_smallaa) then + resusp_x = 0.0_r8 + else + u_old = precabx_old/precabx_base_old + u_old = max( 0.0_r8, min( 1.0_r8, u_old ) ) + x_old = 1.0_r8 - fprecn_resusp_vs_fprec_evap_mpln( 1.0_r8-u_old, jstrcnv ) + x_old = max( 0.0_r8, min( 1.0_r8, x_old ) ) + x_tmp = 0.0_r8 + resusp_x = max( 0.0_r8, precnumx_base_tmp*(x_old - x_tmp) ) + end if + end if + ! setting both these precip rates to zero causes the resuspension + ! calculations to start fresh if there is any more precip production + precabx_tmp = 0.0_r8 + precabx_base_tmp = 0.0_r8 + + else if (evapx <= 0.0_r8) then + ! no evap so no resuspension + if ( mam_prevap_resusp_optcc <= 130) then + scavabx_tmp = scavabx_old + end if + resusp_x = 0.0_r8 + + else + u_old = precabx_old/precabx_base_old + u_old = max( 0.0_r8, min( 1.0_r8, u_old ) ) + if ( mam_prevap_resusp_optcc <= 130) then + ! non-linear resuspension of aerosol mass + x_old = 1.0_r8 - faer_resusp_vs_fprec_evap_mpln( 1.0_r8-u_old, jstrcnv ) + else + ! non-linear resuspension of aerosol number based on raindrop number + x_old = 1.0_r8 - fprecn_resusp_vs_fprec_evap_mpln( 1.0_r8-u_old, jstrcnv ) + end if + x_old = max( 0.0_r8, min( 1.0_r8, x_old ) ) + + if (x_old < x_smallaa) then + x_tmp = 0.0_r8 + x_ratio = 0.0_r8 + else + u_tmp = precabx_tmp/precabx_base_tmp + u_tmp = max( 0.0_r8, min( 1.0_r8, u_tmp ) ) + u_tmp = min( u_tmp, u_old ) + if ( mam_prevap_resusp_optcc <= 130) then + ! non-linear resuspension of aerosol mass + x_tmp = 1.0_r8 - faer_resusp_vs_fprec_evap_mpln( 1.0_r8-u_tmp, jstrcnv ) + else + ! non-linear resuspension of aerosol number based on raindrop number + x_tmp = 1.0_r8 - fprecn_resusp_vs_fprec_evap_mpln( 1.0_r8-u_tmp, jstrcnv ) + end if + x_tmp = max( 0.0_r8, min( 1.0_r8, x_tmp ) ) + x_tmp = min( x_tmp, x_old ) + x_ratio = x_tmp/x_old + x_ratio = max( 0.0_r8, min( 1.0_r8, x_ratio ) ) + end if + + if ( mam_prevap_resusp_optcc <= 130) then + ! aerosol mass resuspension + scavabx_tmp = max( 0.0_r8, scavabx_old * x_ratio ) + resusp_x = max( 0.0_r8, scavabx_old - scavabx_tmp ) + else + ! number resuspension + resusp_x = max( 0.0_r8, precnumx_base_tmp*(x_old - x_tmp) ) + end if + end if + +! step 3 - do precip production and scavenging + tmpa = max( 0.0_r8, pprdx*pdel(i,k)/gravit ) + precabx_base_new = max( 0.0_r8, precabx_base_tmp + tmpa ) + precabx_new = max( 0.0_r8, precabx_tmp + tmpa ) + precabx_new = min( precabx_base_new, precabx_new ) + + if ( mam_prevap_resusp_optcc <= 130) then + ! aerosol mass scavenging + tmpa = max( 0.0_r8, srcx*pdel(i,k)/gravit ) + scavabx_new = max( 0.0_r8, scavabx_tmp + tmpa ) + else + ! raindrop number increase + if (precabx_base_new < prec_smallaa) then + precnumx_base_new = 0.0_r8 + else if (precabx_base_new > precabx_base_tmp) then + ! note - calc rainshaft number flux from rainshaft water flux, + ! then multiply by rainshaft area to get grid-average number flux + arainx = max( arainx, 0.01_r8 ) + tmpa = arainx * flux_precnum_vs_flux_prec_mpln( (precabx_base_new/arainx), jstrcnv ) + precnumx_base_new = max( 0.0_r8, tmpa ) + else + precnumx_base_new = precnumx_base_tmp + end if + end if + +! step 4 - update stratiform ("s") or convective ("c") variables from working ("x") variables + if (jstrcnv == 1) then + resusp_s = resusp_x + precabs(i) = precabx_new + precabs_base(i) = precabx_base_new + if ( mam_prevap_resusp_optcc <= 130) then + scavab(i) = scavabx_new + else + precnums_base(i) = precnumx_base_new + end if + else + resusp_c = resusp_x + precabc(i) = precabx_new + precabc_base(i) = precabx_base_new + if ( mam_prevap_resusp_optcc <= 130) then + scavabc(i) = scavabx_new + else + precnumc_base(i) = precnumx_base_new + end if + end if + + end do jstrcnv_loop_aa + + + else resusp_block_aa + resusp_c = fracev_cu(i)*scavabc(i) + resusp_s = fracev(i)*scavab(i) + + end if resusp_block_aa + + resusp_s_sv(i) = resusp_s + resusp_c_sv(i) = resusp_c + + + if ( mam_prevap_resusp_optcc <= 3) then + scavt(i,k) = -srct(i) + (fracev(i)*scavab(i)+fracev_cu(i)*scavabc(i))*gravit/pdel(i,k) + else + scavt(i,k) = -srct(i) + (resusp_s+resusp_c)*gravit/pdel(i,k) endif - if(present(resus_fix)) then - if(.not.resus_fix) then - if ( present(bcscavt) ) bcscavt(i,k) = -(srcc * (1-finc)) * omsm + & + + iscavt(i,k) = -(srcc*finc + srcs*fins)*omsm + +! if ( present(icscavt) ) icscavt(i,k) = -(srcc*finc) * omsm +! if ( present(isscavt) ) isscavt(i,k) = -(srcs*fins) * omsm + icscavt(i,k) = -(srcc*finc) * omsm + isscavt(i,k) = -(srcs*fins) * omsm + +! if(.not.present(resus_fix)) then +! if ( present(bcscavt) ) bcscavt(i,k) = -(srcc * (1-finc)) * omsm + & +! fracev_cu(i)*scavabc(i)*gravit/pdel(i,k) +! if ( present(bsscavt) ) bsscavt(i,k) = -(srcs * (1-fins)) * omsm + & +! fracev(i)*scavab(i)*gravit/pdel(i,k) +! endif + +! if(present(resus_fix)) then +! if ( .not. resus_fix ) then + if (mam_prevap_resusp_optcc <= 1) then +! if ( present(bcscavt) ) bcscavt(i,k) = -(srcc * (1-finc)) * omsm + & +! fracev_cu(i)*scavabc(i)*gravit/pdel(i,k) +! if ( present(bsscavt) ) bsscavt(i,k) = -(srcs * (1-fins)) * omsm + & +! fracev(i)*scavab(i)*gravit/pdel(i,k) + bcscavt(i,k) = -(srcc * (1-finc)) * omsm + & fracev_cu(i)*scavabc(i)*gravit/pdel(i,k) - if ( present(bsscavt) ) bsscavt(i,k) = -(srcs * (1-fins)) * omsm + & + bsscavt(i,k) = -(srcs * (1-fins)) * omsm + & fracev(i)*scavab(i)*gravit/pdel(i,k) - else - if ( present(bcscavt) ) then - if ( present(rcscavt) ) then + rcscavt(i,k) = 0.0 + rsscavt(i,k) = 0.0 + else if (mam_prevap_resusp_optcc == 2 .or. mam_prevap_resusp_optcc == 3) then +! if ( present(bcscavt) ) then +! if ( present(rcscavt) ) then bcscavt(i,k) = -(srcc * (1-finc)) * omsm !RCE rcscavt(i,k) = fracev_cu(i)*scavabc(i)*gravit/pdel(i,k) !RCE - else - bcscavt(i,k) = -(srcc * (1-finc)) * omsm & - + fracev_cu(i)*scavabc(i)*gravit/pdel(i,k) - end if - end if - if ( present(bsscavt) ) then - if ( present(rsscavt) ) then +! else +! bcscavt(i,k) = -(srcc * (1-finc)) * omsm & +! + fracev_cu(i)*scavabc(i)*gravit/pdel(i,k) +! end if +! end if +! if ( present(bsscavt) ) then +! if ( present(rsscavt) ) then bsscavt(i,k) = -(srcs * (1-fins)) * omsm !RCE rsscavt(i,k) = + fracev(i)*scavab(i)*gravit/pdel(i,k) !RCE - else - bsscavt(i,k) = -(srcs * (1-fins)) * omsm & - + fracev(i)*scavab(i)*gravit/pdel(i,k) - end if - end if +! else +! bsscavt(i,k) = -(srcs * (1-fins)) * omsm & +! + fracev(i)*scavab(i)*gravit/pdel(i,k) +! end if +! end if + else ! here mam_prevap_resusp_optcc == 130, 210, 230 + bcscavt(i,k) = -(srcc * (1-finc)) * omsm + rcscavt(i,k) = resusp_c*gravit/pdel(i,k) + bsscavt(i,k) = -(srcs * (1-fins)) * omsm + rsscavt(i,k) = resusp_s*gravit/pdel(i,k) endif - endif +! endif dblchek(i) = tracer(i,k) + deltat*scavt(i,k) ! now keep track of scavenged mass and precip - scavab(i) = scavab(i)*(1-fracev(i)) + srcs*pdel(i,k)/gravit - precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdel(i,k)/gravit - scavabc(i) = scavabc(i)*(1-fracev_cu(i)) + srcc*pdel(i,k)/gravit - precabc(i) = precabc(i) + (cmfdqr(i,k) - evapc(i,k))*pdel(i,k)/gravit + if (mam_prevap_resusp_optcc <= 3) then + scavab(i) = scavab(i)*(1-fracev(i)) + srcs*pdel(i,k)/gravit + precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdel(i,k)/gravit + scavabc(i) = scavabc(i)*(1-fracev_cu(i)) + srcc*pdel(i,k)/gravit + precabc(i) = precabc(i) + (cmfdqr(i,k) - evapc(i,k))*pdel(i,k)/gravit + if (mam_prevap_resusp_optcc == 3) then + scavab(i) = max( 0.0_r8, scavab(i) ) + scavabc(i) = max( 0.0_r8, scavabc(i) ) + precabs(i) = max( 0.0_r8, precabs(i) ) + precabc(i) = max( 0.0_r8, precabc(i) ) + endif + endif + tracab(i) = tracab(i) + tracer(i,k)*pdel(i,k)/gravit ! Jan.16.2010. Sungsu @@ -756,7 +1047,7 @@ subroutine wetdepa_v2( t, p, q, pdel, & ! End by Sungsu - end do ! End of i = 1, ncol + end do main_i_loop ! End of i = 1, ncol found = .false. do i = 1,ncol @@ -769,17 +1060,285 @@ subroutine wetdepa_v2( t, p, q, pdel, & if ( found ) then do i = 1,ncol if (dblchek(i) .lt. 0._r8) then - write(iulog,*) ' wetdapa: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) + write(iulog,*) ' wetdepa_v2: negative value ', i, k, tracer(i,k), & + dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) + write(iulog,*) ' wetdepa_v2: negative value ', i, k, & + mam_prevap_resusp_optcc, is_strat_cloudborne, tracer(i,k), & + dblchek(i), deltat*scavt(i,k), deltat*srct(i), & + deltat*resusp_s_sv(i)*gravit/pdel(i,k), deltat*resusp_c_sv(i)*gravit/pdel(i,k) endif end do endif - end do ! End of k = 1, pver + end do main_k_loop ! End of k = 1, pver end subroutine wetdepa_v2 +!============================================================================== + function flux_precnum_vs_flux_prec_mpln( flux_prec, jstrcnv ) + real(r8) :: flux_precnum_vs_flux_prec_mpln + real(r8), intent(in) :: flux_prec + integer, intent(in) :: jstrcnv + + if (jstrcnv <= 1) then + flux_precnum_vs_flux_prec_mpln = flux_precnum_vs_flux_prec_mp( flux_prec ) + else + flux_precnum_vs_flux_prec_mpln = flux_precnum_vs_flux_prec_ln( flux_prec ) + end if + + return + end function flux_precnum_vs_flux_prec_mpln + + +!============================================================================== + function faer_resusp_vs_fprec_evap_mpln( fprec_evap, jstrcnv ) + real(r8) :: faer_resusp_vs_fprec_evap_mpln + real(r8), intent(in) :: fprec_evap + integer, intent(in) :: jstrcnv + + if (jstrcnv <= 1) then + faer_resusp_vs_fprec_evap_mpln = faer_resusp_vs_fprec_evap_mp( fprec_evap ) + else + faer_resusp_vs_fprec_evap_mpln = faer_resusp_vs_fprec_evap_ln( fprec_evap ) + end if + + return + end function faer_resusp_vs_fprec_evap_mpln + + +!============================================================================== + function fprecn_resusp_vs_fprec_evap_mpln( fprec_evap, jstrcnv ) + real(r8) :: fprecn_resusp_vs_fprec_evap_mpln + real(r8), intent(in) :: fprec_evap + integer, intent(in) :: jstrcnv + + if (jstrcnv <= 1) then + fprecn_resusp_vs_fprec_evap_mpln = fprecn_resusp_vs_fprec_evap_mp( fprec_evap ) + else + fprecn_resusp_vs_fprec_evap_mpln = fprecn_resusp_vs_fprec_evap_ln( fprec_evap ) + end if + + return + end function fprecn_resusp_vs_fprec_evap_mpln + + +!============================================================================== + function flux_precnum_vs_flux_prec_mp( flux_prec ) +! +! flux_prec = precipitation mass flux at the cloud base (kg/m^2/s) +! flux_precnum_vs_flux_prec_mp = precipitation number flux +! at the cloud base (drops/m^2/s), assuming marshall-palmer raindrop size distribution +! +! + real(r8) :: flux_precnum_vs_flux_prec_mp + real(r8), intent(in) :: flux_prec + + real(r8), parameter :: a0 = 1.0885896550304022E+01_r8 + real(r8), parameter :: a1 = 4.3660645528167907E-01_r8 + + real(r8) :: x, y + + if (flux_prec >= 1.0e-36_r8) then + x = log( flux_prec ) + y = exp( a0 + a1*x ) + else + y = 0.0_r8 + end if + flux_precnum_vs_flux_prec_mp = y + + return + end function flux_precnum_vs_flux_prec_mp + + +!============================================================================== + function flux_precnum_vs_flux_prec_ln( flux_prec ) +! +! flux_prec = precipitation mass flux at the cloud base (kg/m^2/s) +! flux_precnum_vs_flux_prec_ln = precipitation number flux +! at the cloud base (drops/m^2/s), assuming log-normal raindrop size distribution +! +! + real(r8) :: flux_precnum_vs_flux_prec_ln + real(r8), intent(in) :: flux_prec + + real(r8), parameter :: a0 = 9.9067806476181524E+00_r8 + real(r8), parameter :: a1 = 4.2690709912134056E-01_r8 + + real(r8) :: x, y + + if (flux_prec >= 1.0e-36_r8) then + x = log( flux_prec ) + y = exp( a0 + a1*x ) + else + y = 0.0_r8 + end if + flux_precnum_vs_flux_prec_ln = y + + return + end function flux_precnum_vs_flux_prec_ln + + +!============================================================================== + function faer_resusp_vs_fprec_evap_mp( fprec_evap ) +! +! fprec_evap = fraction of precipitation flux that has evaporated (below cloud base) +! faer_resusp_vs_fprec_evap_mp = corresponding fraction of precipitation-borne aerosol +! flux that is resuspended, assuming marshall-palmer raindrop size distribution +! +! note that these fractions are relative to the cloud-base fluxes, +! and not to the layer immediately above fluxes +! + real(r8) :: faer_resusp_vs_fprec_evap_mp + real(r8), intent(in) :: fprec_evap + + real(r8), parameter :: a01 = 8.6591133737322856E-02_r8 + real(r8), parameter :: a02 = -1.7389168499601941E+00_r8 + real(r8), parameter :: a03 = 2.7401882373663732E+01_r8 + real(r8), parameter :: a04 = -1.5861714653209464E+02_r8 + real(r8), parameter :: a05 = 5.1338179363011193E+02_r8 + real(r8), parameter :: a06 = -9.6835933124501412E+02_r8 + real(r8), parameter :: a07 = 1.0588489932213311E+03_r8 + real(r8), parameter :: a08 = -6.2184513459217271E+02_r8 + real(r8), parameter :: a09 = 1.5184126886039758E+02_r8 + real(r8), parameter :: x_lox_lin = 5.0000000000000003E-02_r8 + real(r8), parameter :: y_lox_lin = 2.5622471203221014E-03_r8 + + real(r8) :: x, y + + x = max( 0.0_r8, min( 1.0_r8, fprec_evap ) ) + if (x < x_lox_lin) then + y = y_lox_lin * (x/x_lox_lin) + else + y = x*( a01 + x*( a02 + x*( a03 + x*( a04 + x*( a05 & + + x*( a06 + x*( a07 + x*( a08 + x*a09 )))))))) + end if + faer_resusp_vs_fprec_evap_mp = y + + return + end function faer_resusp_vs_fprec_evap_mp + + +!============================================================================== + function faer_resusp_vs_fprec_evap_ln( fprec_evap ) +! +! fprec_evap = fraction of precipitation flux that has evaporated (below cloud base) +! faer_resusp_vs_fprec_evap_ln = corresponding fraction of precipitation-borne aerosol +! flux that is resuspended, assuming log-normal raindrop size distribution +! +! note that these fractions are relative to the cloud-base fluxes, +! and not to the layer immediately above fluxes +! + real(r8) :: faer_resusp_vs_fprec_evap_ln + real(r8), intent(in) :: fprec_evap + + real(r8), parameter :: a01 = 6.1944215103685640E-02_r8 + real(r8), parameter :: a02 = -2.0095166685965378E+00_r8 + real(r8), parameter :: a03 = 2.3882460251821236E+01_r8 + real(r8), parameter :: a04 = -1.2695611774753374E+02_r8 + real(r8), parameter :: a05 = 4.0086943562320101E+02_r8 + real(r8), parameter :: a06 = -7.4954272875943707E+02_r8 + real(r8), parameter :: a07 = 8.1701055892023624E+02_r8 + real(r8), parameter :: a08 = -4.7941894659538502E+02_r8 + real(r8), parameter :: a09 = 1.1710291076059025E+02_r8 + real(r8), parameter :: x_lox_lin = 1.0000000000000001E-01_r8 + real(r8), parameter :: y_lox_lin = 6.2227889828044350E-04_r8 + + real(r8) :: x, y + + x = max( 0.0_r8, min( 1.0_r8, fprec_evap ) ) + if (x < x_lox_lin) then + y = y_lox_lin * (x/x_lox_lin) + else + y = x*( a01 + x*( a02 + x*( a03 + x*( a04 + x*( a05 & + + x*( a06 + x*( a07 + x*( a08 + x*a09 )))))))) + end if + faer_resusp_vs_fprec_evap_ln = y + + return + end function faer_resusp_vs_fprec_evap_ln + + +!============================================================================== + function fprecn_resusp_vs_fprec_evap_mp( fprec_evap ) +! +! fprec_evap = fraction of precipitation flux that has evaporated (below cloud base) +! fprecn_resusp_vs_fprec_evap_mp = Rain number evaporation fraction, +! assuming marshall-palmer raindrop size distribution +! +! note that these fractions are relative to the cloud-base fluxes, +! and not to the layer immediately above fluxes +! + real(r8) :: fprecn_resusp_vs_fprec_evap_mp + real(r8), intent(in) :: fprec_evap + + real(r8), parameter :: a01 = 4.5461070198414655E+00_r8 + real(r8), parameter :: a02 = -3.0381753620077529E+01_r8 + real(r8), parameter :: a03 = 1.7959619926085665E+02_r8 + real(r8), parameter :: a04 = -6.7152282193785618E+02_r8 + real(r8), parameter :: a05 = 1.5651931323557126E+03_r8 + real(r8), parameter :: a06 = -2.2743927701175126E+03_r8 + real(r8), parameter :: a07 = 2.0004645897056735E+03_r8 + real(r8), parameter :: a08 = -9.7351466279626209E+02_r8 + real(r8), parameter :: a09 = 2.0101198012962413E+02_r8 + real(r8), parameter :: x_lox_lin = 5.0000000000000003E-02_r8 + real(r8), parameter :: y_lox_lin = 1.7005858490684875E-01_r8 + + real(r8) :: x, y + + x = max( 0.0_r8, min( 1.0_r8, fprec_evap ) ) + if (x < x_lox_lin) then + y = y_lox_lin * (x/x_lox_lin) + else + y = x*( a01 + x*( a02 + x*( a03 + x*( a04 + x*( a05 & + + x*( a06 + x*( a07 + x*( a08 + x*a09 )))))))) + end if + fprecn_resusp_vs_fprec_evap_mp = y + + return + end function fprecn_resusp_vs_fprec_evap_mp + + +!============================================================================== + function fprecn_resusp_vs_fprec_evap_ln( fprec_evap ) +! +! fprec_evap = fraction of precipitation flux that has evaporated (below cloud base) +! fprecn_resusp_vs_fprec_evap_ln = Rain number evaporation fraction, +! assuming log-normal raindrop size distribution +! +! note that these fractions are relative to the cloud-base fluxes, +! and not to the layer immediately above fluxes +! + real(r8) :: fprecn_resusp_vs_fprec_evap_ln + real(r8), intent(in) :: fprec_evap + + real(r8), parameter :: a01 = -5.2335291116884175E-02_r8 + real(r8), parameter :: a02 = 2.7203158069178226E+00_r8 + real(r8), parameter :: a03 = 9.4730878152409375E+00_r8 + real(r8), parameter :: a04 = -5.0573187592544798E+01_r8 + real(r8), parameter :: a05 = 9.4732631441282862E+01_r8 + real(r8), parameter :: a06 = -8.8265926556465814E+01_r8 + real(r8), parameter :: a07 = 3.5247835268269142E+01_r8 + real(r8), parameter :: a08 = 1.5404586576716444E+00_r8 + real(r8), parameter :: a09 = -3.8228795492549068E+00_r8 + real(r8), parameter :: x_lox_lin = 1.0000000000000001E-01_r8 + real(r8), parameter :: y_lox_lin = 2.7247994766566485E-02_r8 + + real(r8) :: x, y + + x = max( 0.0_r8, min( 1.0_r8, fprec_evap ) ) + if (x < x_lox_lin) then + y = y_lox_lin * (x/x_lox_lin) + else + y = x*( a01 + x*( a02 + x*( a03 + x*( a04 + x*( a05 & + + x*( a06 + x*( a07 + x*( a08 + x*a09 )))))))) + end if + fprecn_resusp_vs_fprec_evap_ln = y + + return + end function fprecn_resusp_vs_fprec_evap_ln + + !============================================================================== ! This is the frozen CAM4 version of wetdepa. diff --git a/components/cam/src/chemistry/modal_aero/aero_model.F90 b/components/cam/src/chemistry/modal_aero/aero_model.F90 index 6336a6537a8c..7b5cfbd7f862 100644 --- a/components/cam/src/chemistry/modal_aero/aero_model.F90 +++ b/components/cam/src/chemistry/modal_aero/aero_model.F90 @@ -62,6 +62,7 @@ module aero_model integer :: dp_frac_idx = 0 integer :: imozart = -1 + logical :: history_aero_prevap_resusp = .false. ! controls output of prevap resusp tendencies to history ! variables for table lookup of aerosol impaction/interception scavenging rates integer, parameter :: nimptblgrow_mind=-7, nimptblgrow_maxd=12 @@ -165,61 +166,157 @@ end subroutine aero_model_register !============================================================================= !============================================================================= - subroutine aero_model_init( pbuf2d, species_class ) + subroutine aero_model_init( pbuf2d, species_class, iflagaa ) use mo_chem_utls, only: get_inv_ndx use cam_history, only: addfld, add_default, phys_decomp use phys_control, only: phys_getopts use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx - use modal_aero_data, only: cnst_name_cw + use modal_aero_data, only: cnst_name_cw, rain_evap_to_coarse_aero, mam_prevap_resusp_optaa use modal_aero_initialize_data, only: modal_aero_initialize + use modal_aero_convproc, only: deepconv_wetdep_history use rad_constituents, only: rad_cnst_get_info use dust_model, only: dust_init, dust_names, dust_active, dust_nbin, dust_nnum use seasalt_model, only: seasalt_init, seasalt_names, seasalt_active,seasalt_nbin use drydep_mod, only: inidrydep use wetdep, only: wetdep_init use mo_chem_utls, only: get_het_ndx + use gas_wetdep_opts, only: gas_wetdep_cnt, gas_wetdep_list, gas_wetdep_method ! REASTER 08/04/2015 ! args type(physics_buffer_desc), pointer :: pbuf2d(:,:) integer, intent(inout) :: species_class(:) + integer, intent(in) :: iflagaa ! local vars - character(len=*), parameter :: subrname = 'aero_model_init' - integer :: m, n, id - character(len=20) :: dummy + integer :: id, l, m, n, nspc logical :: history_aerosol ! Output MAM or SECT aerosol tendencies - integer :: l - integer :: nspc + character(len=*), parameter :: subrname = 'aero_model_init' + character(len=20) :: dummy character(len=fieldname_len) :: wetdep_name, depflx_name character(len=6) :: test_name - character(len=64) :: errmes - + character(len=100) :: errmes character(len=2) :: unit_basename ! Units 'kg' or '1' + if ( masterproc ) write(iulog,'(a,i5)') 'aero_model_init iflagaa=', iflagaa ! REASTER 08/04/2015 + dgnum_idx = pbuf_get_index('DGNUM') dgnumwet_idx = pbuf_get_index('DGNUMWET') call phys_getopts( history_aerosol_out=history_aerosol, & convproc_do_aer_out = convproc_do_aer, & convproc_do_gas_out = convproc_do_gas, & - resus_fix_out = resus_fix ) - if(masterproc) then - if(convproc_do_aer .or. convproc_do_gas) then - if(.not. resus_fix)write(iulog,*)'WARNING: resus_fix=.false. and convproc_do_aer (or convproc_do_gas)=.true.' //& + resus_fix_out = resus_fix ) + +! mam_prevap_resusp_optaa = 30 + + ! REASTER 08/04/2015 BEGIN + m = mam_prevap_resusp_optaa + if ( rain_evap_to_coarse_aero ) then + if ( mam_prevap_resusp_optaa /= 30 ) then + mam_prevap_resusp_optaa = 30 + if ( masterproc ) write(iulog,'(2a,i4,a)') 'aero_model_init - ', & + 'mam_prevap_resusp_optaa changed from ', m, ' to 30 because rain_evap_to_coarse_aero = .true.' + end if + + else + if ( mam_prevap_resusp_optaa == 10 .and. resus_fix ) then + ! this case is mam_prevap_resusp_optaa = 20, so change the default value + mam_prevap_resusp_optaa = 20 + if ( masterproc ) write(iulog,'(2a)') 'aero_model_init - ', & + 'mam_prevap_resusp_optaa changed from 10 to 20 because resus_fix = .true.' + else if ( mam_prevap_resusp_optaa == 10 .and. convproc_do_aer ) then + ! when convproc_do_aer, the prevap_resusp tendencies are always written + ! to history, so change mam_prevap_resusp_optaa to 11 + mam_prevap_resusp_optaa = 11 + if ( masterproc ) write(iulog,'(2a)') 'aero_model_init - ', & + 'mam_prevap_resusp_optaa changed from 10 to 11 because convproc_do_aer = .true.' + endif + endif + + if ( masterproc ) then + write(iulog,'(2a,4l5,2i5)') 'aero_model_init - ', & + 'convproc_do_aer & _gas, resus_fix, rain_evap_to_coarse, mam_prevap_resusp_optaa_v1/v2', & + convproc_do_aer, convproc_do_gas, resus_fix, & + rain_evap_to_coarse_aero, m, mam_prevap_resusp_optaa + endif + + ! The unified convective transport/removal for aerosols does not + ! do gases yet, and convproc_do_gas is just a place holder. For that reason, + ! (1) All of the "if ( convproc_do_aer .or. convproc_do_gas ) then" statements + ! in aero_model.F90 have been changed to "if ( convproc_do_aer ) then" + ! (2) convproc_do_aer=.false. and convproc_do_gas=.true. is no longer allowed. + if ( ( .not. convproc_do_aer ) .and. convproc_do_gas ) then + errmes = 'aero_model_init - ' // & + 'convproc_do_aer MUST BE .true. when convproc_do_gas is .true.' + call endrun( errmes ) + endif + + if (masterproc) then + if ( convproc_do_aer .and. ( .not. resus_fix ) ) then + write(iulog,*)'WARNING: resus_fix=.false. and convproc_do_aer=.true.' //& ' is not a well tested configuration, may produce incorrect results!!' endif endif + + m = 0 + if ( mam_prevap_resusp_optaa == 0 ) m = 1 + if ( mam_prevap_resusp_optaa == 10 ) m = 1 + if ( mam_prevap_resusp_optaa == 11 ) m = 1 + if ( mam_prevap_resusp_optaa == 20 ) m = 1 + if ( mam_prevap_resusp_optaa == 21 ) m = 1 + if ( rain_evap_to_coarse_aero ) then + if ( mam_prevap_resusp_optaa == 30 ) m = 1 + endif + if (m <= 0) then + write(errmes,'(2a,l5,i10)') 'aero_model_init - ', & + 'illegal rain_evap_to_coarse_aero, bad mam_prevap_resusp_optaa = ', & + rain_evap_to_coarse_aero, mam_prevap_resusp_optaa + call endrun( errmes ) + endif + + history_aero_prevap_resusp = .false. + if ( mam_prevap_resusp_optaa /= 10 ) history_aero_prevap_resusp = .true. + + + ! This section cannot execute until chemini, ..., chm_diags_inti have been called + if ( iflagaa == 2 ) then + if ( masterproc ) then + write(iulog,'(a,i5,2x,a)') 'gas_wetdep_cnt,meth', gas_wetdep_cnt, gas_wetdep_method + do m = 1, gas_wetdep_cnt + write(iulog,'(a,i5,2x,a)') 'gas_wetdep_list ', m, trim(gas_wetdep_list(m)) + end do + end if + + ! These WD_ and DF_ fields should always been in a MAM history file, + ! but for now they are conditional on convproc_do_aer + if ( convproc_do_aer ) then + do m = 1,gas_pcnst + call cnst_get_ind( solsym(m), l, abort=.false. ) + if ( ( history_aerosol ) .and. & + (species_class(l) == spec_class_gas) ) then !RCE - only output WD_xxx and DF_xxx for gases + wetdep_name = 'WD_'//trim(solsym(m)) + depflx_name = 'DF_'//trim(solsym(m)) + nspc = get_het_ndx(solsym(m)) + if (nspc > 0) call add_default( wetdep_name, 1, ' ' ) + call add_default( depflx_name, 1, ' ' ) + endif + end do ! m = 1,gas_pcnst + endif + return + endif ! ( iflagaa == 2 ) + ! REASTER 08/11/2015 END + + !BSINGH: Decide the loop counters for the lphase loop in aero_model_wetdep subroutine !for cases with and without the unified convective transport - !Counters for "without" unified convective treatment (i.e. default case) strt_loop = 1 end_loop = 2 stride_loop = 1 - if(convproc_do_aer .or. convproc_do_gas) then + if (convproc_do_aer) then !BSINGH (09/12/2014):Do cloudborne first for unified convection scheme so that the resuspension of cloudborne !can be saved then applied to interstitial (RCE) strt_loop = 2 @@ -230,6 +327,7 @@ subroutine aero_model_init( pbuf2d, species_class ) call modal_aero_initialize(pbuf2d, imozart, species_class) call modal_aero_bcscavcoef_init() + call mam_prevap_resusp_init( ) ! REASTER 08/04/2015 call dust_init() call seasalt_init() @@ -403,6 +501,7 @@ subroutine aero_model_init( pbuf2d, species_class ) enddo do m = 1,nwetdep + if ( masterproc ) write(iulog,'(a,i3,2x,a)') 'm, wetdep_list', m, trim(wetdep_list(m)) ! REASTER 08/04/2015 ! units if (wetdep_list(m)(1:3) == 'num') then @@ -421,17 +520,22 @@ subroutine aero_model_init( pbuf2d, species_class ) 1, 'A','Wet deposition flux (belowcloud, convective) at surface',phys_decomp) call addfld (trim(wetdep_list(m))//'SFSBS',unit_basename//'/m2/s ', & 1, 'A','Wet deposition flux (belowcloud, stratiform) at surface',phys_decomp) - if(convproc_do_aer) then + + if ( history_aero_prevap_resusp ) then call addfld (trim(wetdep_list(m))//'SFSEC','kg/m2/s ', & 1, 'A','Wet deposition flux (precip evap, convective) at surface',phys_decomp) !RCE call addfld (trim(wetdep_list(m))//'SFSES','kg/m2/s ', & 1, 'A','Wet deposition flux (precip evap, stratiform) at surface',phys_decomp) !RCE + if (convproc_do_aer .and. deepconv_wetdep_history) then + call addfld (trim(wetdep_list(m))//'SFSED','kg/m2/s ', & + 1, 'A','Wet deposition flux (precip evap, deep convective) at surface',phys_decomp) !RCE + endif + endif + if (convproc_do_aer .and. deepconv_wetdep_history) then call addfld (trim(wetdep_list(m))//'SFSID','kg/m2/s ', & 1, 'A','Wet deposition flux (incloud, deep convective) at surface',phys_decomp) !RCE call addfld (trim(wetdep_list(m))//'SFSBD','kg/m2/s ', & 1, 'A','Wet deposition flux (belowcloud, deep convective) at surface',phys_decomp) !RCE - call addfld (trim(wetdep_list(m))//'SFSED','kg/m2/s ', & - 1, 'A','Wet deposition flux (precip evap, deep convective) at surface',phys_decomp) !RCE endif call addfld (trim(wetdep_list(m))//'WET',unit_basename//'/kg/s ',pver, 'A','wet deposition tendency',phys_decomp) @@ -450,9 +554,26 @@ subroutine aero_model_init( pbuf2d, species_class ) call add_default (trim(wetdep_list(m))//'SFSIS', 1, ' ') call add_default (trim(wetdep_list(m))//'SFSBC', 1, ' ') call add_default (trim(wetdep_list(m))//'SFSBS', 1, ' ') + ! REASTER 08/04/2015 BEGIN + call addfld (trim(wetdep_list(m))//'SFWEZ',unit_basename//'/m2/s ', & + 1, 'A','Wet deposition flux at surface',phys_decomp) + call addfld (trim(wetdep_list(m))//'SFSEZ','kg/m2/s ', & + 1, 'A','Wet deposition flux (precip evap, convective) at surface',phys_decomp) !RCE + call addfld (trim(wetdep_list(m))//'SFSIZ',unit_basename//'/m2/s ', & + 1, 'A','Wet deposition flux (incloud, convective) at surface',phys_decomp) + if ( history_aero_prevap_resusp ) then + call add_default (trim(wetdep_list(m))//'SFSEC', 1, ' ') + call add_default (trim(wetdep_list(m))//'SFSES', 1, ' ') + endif + if(convproc_do_aer) then + call add_default (trim(wetdep_list(m))//'SFWEZ', 1, ' ') + call add_default (trim(wetdep_list(m))//'SFSEZ', 1, ' ') + call add_default (trim(wetdep_list(m))//'SFSIZ', 1, ' ') + endif + ! REASTER 08/04/2015 END endif - enddo + enddo ! m = 1,nwetdep do m = 1,gas_pcnst @@ -471,31 +592,36 @@ subroutine aero_model_init( pbuf2d, species_class ) call add_default( 'AQ_'//trim(solsym(m)), 1, ' ') endif - if(convproc_do_gas) then - wetdep_name = 'WD_'//trim(solsym(m)) - depflx_name = 'DF_'//trim(solsym(m)) - - if ( history_aerosol ) then - nspc = get_het_ndx(solsym(m)) - if (nspc > 0) then - call cnst_get_ind( solsym(m), nspc, abort=.false. ) - if (nspc > 0) then - if (species_class(nspc) == spec_class_gas) & !RCE - only output WD_xxx for gases - call add_default( wetdep_name, 1, ' ' ) - endif - endif - endif - endif - - call cnst_get_ind(trim(solsym(m)), nspc, abort=.false. ) - if(convproc_do_gas) then - if ( history_aerosol .and. (nspc > 0) ) then - if (species_class(nspc) == spec_class_gas) & !RCE - only output DF_xxx for gases - call add_default( depflx_name, 1, ' ' ) - endif - endif - - if(nspc > 0 .and. .not.cnst_name_cw(nspc) == ' ') then +! REASTER 08/04/2015 BEGIN - this now done in the iflagaa==2 section +! if(convproc_do_gas) then +! wetdep_name = 'WD_'//trim(solsym(m)) +! depflx_name = 'DF_'//trim(solsym(m)) +! +! if ( history_aerosol ) then +! nspc = get_het_ndx(solsym(m)) +! if (nspc > 0) then +! call cnst_get_ind( solsym(m), nspc, abort=.false. ) +! if (nspc > 0) then +! if (species_class(nspc) == spec_class_gas) & !RCE - only output WD_xxx for gases +! call add_default( wetdep_name, 1, ' ' ) +! endif +! endif +! endif +! endif + +! call cnst_get_ind(trim(solsym(m)), nspc, abort=.false. ) +! if(convproc_do_gas) then +! if ( history_aerosol .and. (nspc > 0) ) then +! if (species_class(nspc) == spec_class_gas) & !RCE - only output DF_xxx for gases +! call add_default( depflx_name, 1, ' ' ) +! endif +! endif +! REASTER 08/04/2015 END + + call cnst_get_ind(trim(solsym(m)), nspc, abort=.false. ) ! REASTER 08/04/2015 +! if(nspc > 0 .and. .not.cnst_name_cw(nspc) == ' ') then ! REASTER 08/04/2015 + if( nspc > 0 ) then ! REASTER 08/04/2015 + if ( .not. cnst_name_cw(nspc) == ' ') then ! REASTER 08/04/2015 if(convproc_do_aer) then call addfld (trim(cnst_name_cw(nspc))//'SFSEC','kg/m2/s ',1, 'A', & trim(cnst_name_cw(nspc))//' wet deposition flux (precip evap, convective) at surface',phys_decomp) !RCE @@ -506,6 +632,7 @@ subroutine aero_model_init( pbuf2d, species_class ) call add_default (trim(cnst_name_cw(nspc))//'SFSES', 1, ' ') !RCE endif endif + endif endif enddo @@ -964,6 +1091,103 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, endsubroutine aero_model_drydep + +! REASTER 08/04/2015 BEGIN + !============================================================================= + !============================================================================= + subroutine mam_prevap_resusp_init( ) + + use modal_aero_data, only: & + lmassptr_amode, lspectype_amode, & + modeptr_coarse, & + nspec_amode, ntot_amode, numptr_amode, & + mam_prevap_resusp_optaa, mmtoo_prevap_resusp, ntoo_prevap_resusp + use phys_control, only: phys_getopts + + integer :: lspec, lspec2 + integer :: mm, mmtoo, mm2 + integer :: n, ntoo, nch + character(len=100) :: msg + + if ( masterproc ) then + write(iulog,'(/a)') 'mam_prevap_resusp_init' + write(iulog,'(a,i10)') 'mam_prevap_resusp_optaa', mam_prevap_resusp_optaa + end if + +! calculate pointers for resuspension +! when mam_prevap_resusp_optaa = 30, mmtoo_prevap_resusp values are +! >0 for aerosol mass species with coarse mode counterpart +! -1 for aerosol mass species WITHOUT coarse mode counterpart +! -2 for aerosol number species +! 0 for other species +! when mam_prevap_resusp_optaa = 0, 10, 11, 20, 21, mmtoo_prevap_resusp values are 0 + + mmtoo_prevap_resusp(:) = 0 + ntoo_prevap_resusp(:) = 0 + + if ( mam_prevap_resusp_optaa == 30 ) then + +#if ( defined MODAL_AERO_3MODE ) || ( defined MODAL_AERO_4MODE ) + ntoo = modeptr_coarse +#else + call endrun( 'modal_aero_wetscav_init: new resuspension not implemented for 7-mode') +#endif + + do n = 1, ntot_amode ! loop over aerosol modes that was wet-removed + + do lspec = 1, nspec_amode(n) ! loop over chem constituents that was wet-removed + mm = lmassptr_amode(lspec,n) ! q-array index of the species that was wet-removed + nch = len( trim( cnst_name(mm) ) ) - 1 + if (n >= 10) nch = nch - 1 + if (n >= 100) nch = nch - 1 +! lspectype = lspectype_amode(lspec,n) + + mmtoo = -1 ! q-array index of the coarse mode species that gets the resuspension + do lspec2 = 1, nspec_amode(ntoo) +! match based on the cnst_name (except for the last 1-2 characters) + mm2 = lmassptr_amode(lspec2,ntoo) + if ( cnst_name(mm)(1:nch) == cnst_name(mm2)(1:nch) ) then + mmtoo = mm2 + exit + end if + end do + + if (mmtoo <= 0) then + msg = 'modal_aero_wetscav_init: cannot find mmtoo for resuspension of: ' // cnst_name(mm) + write(iulog,'(a)') msg + call endrun( msg ) + end if + if ( masterproc ) then + write(iulog,'(a,3(2x,a))') 'modal_aero_wetscav_init mmfrm/too: ', & + cnst_name(mm), cnst_name(mmtoo), cnst_name(numptr_amode(ntoo)) + end if + + mmtoo_prevap_resusp(mm) = mmtoo + ntoo_prevap_resusp(mm) = ntoo + end do ! lspec + + mm = numptr_amode(n) + mmtoo_prevap_resusp(mm) = -2 + ntoo_prevap_resusp(mm) = ntoo + end do ! n + + end if + + if ( masterproc ) then + do mm = 1, pcnst + mmtoo = mmtoo_prevap_resusp(mm) + ntoo = ntoo_prevap_resusp(mm) + msg = ' ' + if (mmtoo > 0) msg = cnst_name(mmtoo) + write(iulog,'(2a,3(1x,i9),2x,a)') 'name, mm, mmtoo, ntoo = ', & + cnst_name(mm), mm, mmtoo, ntoo, trim(msg) + end do + end if + + end subroutine mam_prevap_resusp_init +! REASTER 08/04/2015 END + + !============================================================================= !============================================================================= subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &!Intent-ins @@ -979,7 +1203,8 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! use modal_aero_calcsize, only: modal_aero_calcsize_sub use modal_aero_wateruptake,only: modal_aero_wateruptake_dr use modal_aero_convproc, only: deepconv_wetdep_history, ma_convproc_intr - use infnan, only : nan, assignment(=) + use mo_constants, only: pi + use infnan, only: nan, assignment(=) ! args @@ -1011,18 +1236,25 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - ! local vars - integer :: m ! tracer index + ! local vars + integer :: i + integer :: jnv ! index for scavcoefnv 3rd dimension + integer :: jnummaswtr ! indicates current aerosol species type (0 = number, 1 = dry mass, 2 = water) + integer, parameter :: jaeronumb=0, jaeromass=1, jaerowater=2 + integer :: k integer :: lchnk ! chunk identifier + integer :: lphase ! index for interstitial / cloudborne aerosol + integer :: lspec ! index for aerosol number / chem-mass / water-mass + integer :: lspectype + integer :: lcoardust, lcoarnacl ! indices for coarse mode dust and seasalt masses + integer :: m, mtmp ! mode index + integer :: mm, mmai, mmtoo ! tracer (q-array) index integer :: ncol ! number of atmospheric columns + integer :: mam_prevap_resusp_optaa10, mam_prevap_resusp_optcc real(r8) :: iscavt(pcols, pver) - - integer :: mm - integer :: i,k - real(r8) :: icscavt(pcols, pver) real(r8) :: isscavt(pcols, pver) real(r8) :: bcscavt(pcols, pver) @@ -1033,11 +1265,9 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! real(r8) :: sflx(pcols) ! deposition flux - integer :: jnv ! index for scavcoefnv 3rd dimension - integer :: lphase ! index for interstitial / cloudborne aerosol - integer :: lspec ! index for aerosol number / chem-mass / water-mass - integer :: lcoardust, lcoarnacl ! indices for coarse mode dust and seasalt masses - real(r8) :: dqdt_tmp(pcols,pver) ! temporary array to hold tendency for 1 species + real(r8) :: d1p_prevap_resusp, v1p_prevap_resusp + real(r8) :: dqdt_tmp(pcols,pver) ! temporary array to hold tendency for the "current" aerosol species + real(r8) :: dqdt_sv(pcols,pver,pcnst) ! temporary array to hold tendency for all interstitial aerosol species real(r8) :: f_act_conv(pcols,pver) ! prescribed aerosol activation fraction for convective cloud ! rce 2010/05/01 real(r8) :: f_act_conv_coarse(pcols,pver) ! similar but for coarse mode ! rce 2010/05/02 real(r8) :: f_act_conv_coarse_dust, f_act_conv_coarse_nacl ! rce 2010/05/02 @@ -1068,7 +1298,10 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! real(r8) :: rcscavt(pcols, pver) !RCE real(r8) :: rsscavt(pcols, pver) !RCE real(r8) :: qqcw_in(pcols,pver), qqcw_sav(pcols,pver,0:maxd_aspectype) ! temporary array to hold qqcw for the current mode !RCE - real(r8) :: rtscavt(pcols, pver, 0:maxd_aspectype) !RCE +! real(r8) :: rtscavt_sv(pcols, pver, 0:maxd_aspectype) !RCE + real(r8) :: rtscavt_sv(pcols, pver, pcnst) ! REASTER 08/12/2015 + real(r8) :: rcscavt_cn_sv(pcols, pver) ! REASTER 08/12/2015 + real(r8) :: rsscavt_cn_sv(pcols, pver) ! REASTER 08/12/2015 real(r8), pointer :: fldcw(:,:) @@ -1094,6 +1327,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! real(r8), pointer :: sh_frac(:,:) ! Shallow convective cloud fraction real(r8), pointer :: dp_frac(:,:) ! Deep convective cloud fraction + character(len=100) :: msg type(wetdep_inputs_t) :: dep_inputs @@ -1153,7 +1387,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! *state%pdel(:ncol,k)/gravit end do - if(convproc_do_aer .or. convproc_do_gas) then + if (convproc_do_aer) then qsrflx_mzaer2cnvpr(:,:,:) = 0.0_r8 !RCE aerdepwetis(:,:) = 0.0_r8 !RCE aerdepwetcw(:,:) = 0.0_r8 !RCE @@ -1190,9 +1424,31 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! scavcoefnv(:,:,0) = 0.0_r8 ! below-cloud scavcoef = 0.0 for cloud-borne species - do m = 1, ntot_amode ! main loop over aerosol modes + if ( mam_prevap_resusp_optaa >= 20 ) then + ! resuspension goes to a different phase or mode + rtscavt_sv(:,:,:) = 0.0_r8 + rcscavt_cn_sv(:,:) = 0.0_r8 + rsscavt_cn_sv(:,:) = 0.0_r8 + endif + +mmode_loop_aa: & +! REASTER 08/11/2015 BEGIN + do mtmp = 1, ntot_amode ! main loop over aerosol modes + m = mtmp + if (ntot_amode == 4) then + ! for mam4, do accum, aitken, pcarbon, then coarse + if (mtmp == modeptr_coarse) then + m = ntot_amode + else if (mtmp > modeptr_coarse) then + m = mtmp - 1 + endif + endif +! REASTER 08/11/2015 END + !BSINGH: loop counters (strt_loop,end_loop and stride_loop) are selected based on whether ! convproc_do_aer is true or false in the aero_model_init subroutine above + +lphase_loop_aa: & do lphase = strt_loop,end_loop, stride_loop ! loop over interstitial (1) and cloud-borne (2) forms ! sol_factb and sol_facti values @@ -1263,7 +1519,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! f_act_conv = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean end if - if((convproc_do_aer .or. convproc_do_gas ).and. lphase == 1) then + if( convproc_do_aer .and. lphase == 1 ) then ! RCE 2012/01/12 ! if modal aero convproc is turned on for aerosols, then ! turn off the convective in-cloud removal for interstitial aerosols @@ -1292,27 +1548,35 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! sol_factiic = sol_factic(1,1) - do lspec = 0, nspec_amode(m)+1 ! loop over number + chem constituents + water +! REASTER 08/12/2015 - changed ordering (mass then number) for prevap resuspend to coarse +lspec_loop_aa: & + do lspec = 1, nspec_amode(m)+2 ! loop over number + chem constituents + water - if (lspec == 0) then ! number + mmai = 0 + if (lspec <= nspec_amode(m)) then ! non-water mass + jnummaswtr = jaeromass if (lphase == 1) then - mm = numptr_amode(m) - jnv = 1 + mm = lmassptr_amode(lspec,m) + jnv = 2 else - mm = numptrcw_amode(m) + mm = lmassptrcw_amode(lspec,m) + mmai = lmassptr_amode(lspec,m) jnv = 0 endif - else if (lspec <= nspec_amode(m)) then ! non-water mass + else if (lspec == nspec_amode(m)+1) then ! number + jnummaswtr = jaeronumb if (lphase == 1) then - mm = lmassptr_amode(lspec,m) - jnv = 2 + mm = numptr_amode(m) + jnv = 1 else - mm = lmassptrcw_amode(lspec,m) + mm = numptrcw_amode(m) + mmai = numptr_amode(m) jnv = 0 endif else ! water mass ! bypass wet removal of aerosol water - if(convproc_do_aer .or. convproc_do_gas) then + jnummaswtr = jaerowater + if (convproc_do_aer) then if ( .not. do_aero_water_removal ) cycle else cycle @@ -1330,6 +1594,58 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! if (mm <= 0) cycle + mam_prevap_resusp_optaa10 = mam_prevap_resusp_optaa/10 + +! mam_prevap_resusp_optcc values control the prevap_resusp calculations in wetdepa_v2: +! 0 = no resuspension +! 1 = linear resuspension of aerosol mass or number following original mam coding +! and history_aero_prevap_resusp = .false. +! 2 = same as 1 but history_aero_prevap_resusp = .true. +! 3 = same as 2 but with some added "xxx = max( 0, xxx)" lines +! +! 130 = non-linear resuspension of aerosol mass based on scavenged aerosol mass +! 230 = non-linear resuspension of aerosol number based on raindrop number +! the 130 thru 230 all use the new prevap_resusp code block in subr wetdepa_v2 +! and all have history_aero_prevap_resusp = .true. +! + mam_prevap_resusp_optcc = 0 + + if ( mam_prevap_resusp_optaa == 0 ) then + mam_prevap_resusp_optcc = 0 + else if ( mam_prevap_resusp_optaa == 10 ) then + mam_prevap_resusp_optcc = 1 + else if ( mam_prevap_resusp_optaa == 11) then + mam_prevap_resusp_optcc = 2 + + else if ( mam_prevap_resusp_optaa == 20 ) then + mam_prevap_resusp_optcc = 2 + else if ( mam_prevap_resusp_optaa == 21 ) then + mam_prevap_resusp_optcc = 3 + + else if ( mam_prevap_resusp_optaa == 30 ) then + if ( jnummaswtr == jaeromass ) then + mam_prevap_resusp_optcc = 130 + else if ( jnummaswtr == jaeronumb .and. & + lphase == 1 .and. & + m == modeptr_coarse ) then + mam_prevap_resusp_optcc = 230 + endif + + endif + + if ( mam_prevap_resusp_optcc /= 0 .and. & + mam_prevap_resusp_optcc /= 1 .and. & + mam_prevap_resusp_optcc /= 2 .and. & + mam_prevap_resusp_optcc /= 3 .and. & + mam_prevap_resusp_optcc /= 130 .and. & + mam_prevap_resusp_optcc /= 230 ) then + write(msg,'(a,2(1x,i10))') & + 'aero_model_wetdep - bad mam_prevap_resusp_optaa & cc =', & + mam_prevap_resusp_optaa, mam_prevap_resusp_optcc + call endrun( msg ) + endif + + ! set f_act_conv for interstitial (lphase=1) coarse mode species ! for the convective in-cloud, we conceptually treat the coarse dust and seasalt ! as being externally mixed, and apply f_act_conv = f_act_conv_coarse_dust/nacl to dust/seasalt @@ -1339,7 +1655,8 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! if ((lphase == 1) .and. (m == modeptr_coarse)) then ! sol_factic = sol_factic_coarse f_act_conv = f_act_conv_coarse ! rce 2010/05/02 - if (lspec > 0) then +! if (lspec > 0) then + if (jnummaswtr == jaeromass) then if (lmassptr_amode(lspec,m) == lptr_dust_a_amode(m)) then ! sol_factic = 0.2_r8 ! tuned 1/4 f_act_conv = f_act_conv_coarse_dust ! rce 2010/05/02 @@ -1351,12 +1668,14 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! end if - if ((lphase == 1) .and. (lspec <= nspec_amode(m))) then +lphase_jnmw_conditional: & + if ((lphase == 1) .and. (jnummaswtr /= jaerowater)) then +! if ((lphase == 1) .and. (lspec <= nspec_amode(m))) then ptend%lq(mm) = .TRUE. dqdt_tmp(:,:) = 0.0_r8 ! q_tmp reflects changes from modal_aero_calcsize and is the "most current" q q_tmp(1:ncol,:) = state%q(1:ncol,:,mm) + ptend%q(1:ncol,:,mm)*dt - if(convproc_do_aer .or. convproc_do_gas) then + if (convproc_do_aer) then !Feed in the saved cloudborne mixing ratios from phase 2 qqcw_in(:,:) = qqcw_sav(:,:,lspec) else @@ -1364,31 +1683,50 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! qqcw_in(:,:) = fldcw(:,:) endif - call wetdepa_v2( state%t, state%pmid, state%q(:,:,1), state%pdel, & - dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & - dep_inputs%evapc, dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & - dep_inputs%evapr, dep_inputs%totcond, q_tmp, dt, & - dqdt_tmp, iscavt, dep_inputs%cldv, dep_inputs%cldvcu, dep_inputs%cldvst, & - dlf, fracis(:,:,mm), sol_factb, ncol, & - scavcoefnv(:,:,jnv), & - is_strat_cloudborne=.false., & - rate1ord_cw2pr_st=rate1ord_cw2pr_st, & - qqcw=qqcw_in(:,:), & - f_act_conv=f_act_conv, & - icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & - rcscavt=rcscavt, rsscavt=rsscavt, & - sol_facti_in=sol_facti, sol_factbi_in=sol_factbi, sol_factii_in=sol_factii, & - sol_factic_in=sol_factic, sol_factiic_in=sol_factiic, resus_fix=resus_fix) + call wetdepa_v2( & + ncol, dt, & + state%t, state%pmid, state%q(:,:,1), state%pdel, & + dep_inputs%cmfdqr, dep_inputs%evapc, dlf, dep_inputs%conicw, & + dep_inputs%prain, dep_inputs%qme, dep_inputs%evapr, dep_inputs%totcond, & + dep_inputs%cldt, dep_inputs%cldcu, & + dep_inputs%cldv, dep_inputs%cldvcu, dep_inputs%cldvst, & + sol_factb, sol_factbi, sol_facti, sol_factii, sol_factic, sol_factiic, & + mam_prevap_resusp_optcc, .false., scavcoefnv(:,:,jnv), rate1ord_cw2pr_st, f_act_conv, & + q_tmp, qqcw_in(:,:), & + fracis(:,:,mm), dqdt_tmp, iscavt, & + icscavt, isscavt, bcscavt, bsscavt, rcscavt, rsscavt ) + +! REASTER 08/12/2015 BEGIN + if ( mam_prevap_resusp_optaa10 == 3 ) then + ! resuspension goes to coarse mode + ! first deduct the current resuspension from the dqdt_tmp of the current species + dqdt_tmp(1:ncol,:) = dqdt_tmp(1:ncol,:) - ( rcscavt(1:ncol,:) + rsscavt(1:ncol,:) ) + ! then add the current resuspension to the rtscavt_sv of the appropriate coarse mode species + mmtoo = mmtoo_prevap_resusp(mm) + if (mmtoo > 0) rtscavt_sv(1:ncol,:,mmtoo) = rtscavt_sv(1:ncol,:,mmtoo) & + + ( rcscavt(1:ncol,:) + rsscavt(1:ncol,:) ) + ! then add the rtscavt_sv of the current species to the dqdt_tmp of the current species + ! note that for so4_a3 and mam3, the rtscavt_sv at this point will have resuspension contributions + ! from so4_a1/2/3 and so4c1/2/3 + dqdt_tmp(1:ncol,:) = dqdt_tmp(1:ncol,:) + rtscavt_sv(1:ncol,:,mm) - do_hygro_sum_del = .false. - if ( lspec > 0 ) do_hygro_sum_del = .true. + endif +! REASTER 08/12/2015 END - if(convproc_do_aer .or. convproc_do_gas) then - do_hygro_sum_del = .false. +! if (convproc_do_aer) then + if ( mam_prevap_resusp_optaa10 == 2 ) then ! add resuspension of cloudborne species to dqdt of interstitial species - dqdt_tmp(1:ncol,:) = dqdt_tmp(1:ncol,:) + rtscavt(1:ncol,:,lspec) ! RCE 2012/01/12 +! dqdt_tmp(1:ncol,:) = dqdt_tmp(1:ncol,:) + rtscavt_sv(1:ncol,:,lspec) ! RCE 2012/01/12 + dqdt_tmp(1:ncol,:) = dqdt_tmp(1:ncol,:) + rtscavt_sv(1:ncol,:,mm) ! REASTER 08/12/2015 + endif - if ( (lspec > 0) .and. do_aero_water_removal ) then !RCE 2012/01/12 + do_hygro_sum_del = .false. +! if ( lspec > 0 ) do_hygro_sum_del = .true. + if ( jnummaswtr == jaeromass ) do_hygro_sum_del = .true. + if (convproc_do_aer) then + do_hygro_sum_del = .false. +! if ( (lspec > 0) .and. do_aero_water_removal ) then !RCE 2012/01/12 + if ( (jnummaswtr == jaeromass) .and. do_aero_water_removal ) then do_hygro_sum_del = .true. endif endif @@ -1407,7 +1745,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! sflx(i)=sflx(i)+dqdt_tmp(i,k)*state%pdel(i,k)/gravit enddo enddo - if (.not. (convproc_do_aer .or. convproc_do_gas)) call outfld( trim(cnst_name(mm))//'SFWET', sflx, pcols, lchnk) + if ( .not. convproc_do_aer ) call outfld( trim(cnst_name(mm))//'SFWET', sflx, pcols, lchnk) aerdepwetis(:ncol,mm) = sflx(:ncol) sflx(:)=0._r8 @@ -1416,8 +1754,9 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! sflx(i)=sflx(i)+icscavt(i,k)*state%pdel(i,k)/gravit enddo enddo - if (.not.(convproc_do_aer .or. convproc_do_gas))call outfld( trim(cnst_name(mm))//'SFSIC', sflx, pcols, lchnk) - if (convproc_do_aer .or. convproc_do_gas)sflxic = sflx + if ( .not. convproc_do_aer ) call outfld( trim(cnst_name(mm))//'SFSIC', sflx, pcols, lchnk) + if (convproc_do_aer) sflxic = sflx + sflx(:)=0._r8 do k=1,pver do i=1,ncol @@ -1425,6 +1764,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! enddo enddo call outfld( trim(cnst_name(mm))//'SFSIS', sflx, pcols, lchnk) + sflx(:)=0._r8 do k=1,pver do i=1,ncol @@ -1432,7 +1772,8 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! enddo enddo call outfld( trim(cnst_name(mm))//'SFSBC', sflx, pcols, lchnk) - if (convproc_do_aer .or. convproc_do_gas)sflxbc = sflx + if (convproc_do_aer) sflxbc = sflx + sflx(:)=0._r8 do k=1,pver do i=1,ncol @@ -1440,8 +1781,9 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! enddo enddo call outfld( trim(cnst_name(mm))//'SFSBS', sflx, pcols, lchnk) - - if(convproc_do_aer .or. convproc_do_gas) then + + if ( history_aero_prevap_resusp ) then + ! here the prevap resuspension is in rcscavt & rsscavt and column integral is written to history !BSINGH(09/15/2014):Following two nested do-loops are new additions for unified convection !BSINGH(09/15/2014):After these do-loops, code was added by RCE, the comments by RCE are kept as it is sflx(:)=0._r8 @@ -1450,7 +1792,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! sflx(i)=sflx(i)+rcscavt(i,k)*state%pdel(i,k)/gravit enddo enddo - sflxec = sflx + if (convproc_do_aer) sflxec = sflx sflx(:)=0._r8 do k=1,pver @@ -1459,66 +1801,75 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! enddo enddo call outfld( trim(cnst_name(mm))//'SFSES', sflx, pcols, lchnk) - !RCE 2012/01/12 end - prev ~40 lines are modified + else + if (convproc_do_aer) sflxec(:) = 0._r8 + end if ! ( history_aero_prevap_resusp ) - !RCE 2012/01/12 bgn - next ~40 lines are new - ! apportion convective surface fluxes to deep and shallow conv - ! this could be done more accurately in subr wetdepa - ! since deep and shallow rarely occur simultaneously, and these - ! fields are just diagnostics, this approximate method is adequate - ! only do this for interstitial aerosol, because conv clouds to not - ! affect the stratiform-cloudborne aerosol - if ( deepconv_wetdep_history) then + !RCE 2012/01/12 bgn - next ~40 lines are new + ! apportion convective surface fluxes to deep and shallow conv + ! this could be done more accurately in subr wetdepa + ! since deep and shallow rarely occur simultaneously, and these + ! fields are just diagnostics, this approximate method is adequate + ! only do this for interstitial aerosol, because conv clouds to not + ! affect the stratiform-cloudborne aerosol + if ( convproc_do_aer ) then + if ( deepconv_wetdep_history ) then do i = 1, ncol tmp_precdp = max( rprddpsum(i), 1.0e-35_r8 ) tmp_precsh = max( rprdshsum(i), 1.0e-35_r8 ) tmp_evapdp = max( evapcdpsum(i), 0.1e-35_r8 ) tmp_evapsh = max( evapcshsum(i), 0.1e-35_r8 ) - + ! assume that in- and below-cloud removal are proportional to column precip production tmpa = tmp_precdp / (tmp_precdp + tmp_precsh) tmpa = max( 0.0_r8, min( 1.0_r8, tmpa ) ) sflxicdp(i) = sflxic(i)*tmpa sflxbcdp(i) = sflxbc(i)*tmpa - + ! assume that resuspension is proportional to (wet removal)*[(precip evap)/(precip production)] - tmp_resudp = tmpa * min( (tmp_evapdp/tmp_precdp), 1.0_r8 ) - tmp_resush = (1.0_r8 - tmpa) * min( (tmp_evapsh/tmp_precsh), 1.0_r8 ) - tmpb = max( tmp_resudp, 1.0e-35_r8 ) / max( (tmp_resudp+tmp_resush), 1.0e-35_r8 ) - tmpb = max( 0.0_r8, min( 1.0_r8, tmpb ) ) - sflxecdp(i) = sflxec(i)*tmpb + if ( history_aero_prevap_resusp ) then + tmp_resudp = tmpa * min( (tmp_evapdp/tmp_precdp), 1.0_r8 ) + tmp_resush = (1.0_r8 - tmpa) * min( (tmp_evapsh/tmp_precsh), 1.0_r8 ) + tmpb = max( tmp_resudp, 1.0e-35_r8 ) / max( (tmp_resudp+tmp_resush), 1.0e-35_r8 ) + tmpb = max( 0.0_r8, min( 1.0_r8, tmpb ) ) + sflxecdp(i) = sflxec(i)*tmpb + else + sflxecdp(i) = 0.0_r8 + end if end do call outfld( trim(cnst_name(mm))//'SFSBD', sflxbcdp, pcols, lchnk) else - sflxec(1:ncol) = 0.0_r8 sflxecdp(1:ncol) = 0.0_r8 end if - ! when ma_convproc_intr is used, convective in-cloud wet removal is done there ! the convective (total and deep) precip-evap-resuspension includes in- and below-cloud - ! contributions - ! so pass the below-cloud contribution to ma_convproc_intr + ! contributions, so pass the below-cloud contribution to ma_convproc_intr qsrflx_mzaer2cnvpr(1:ncol,mm,1) = sflxec( 1:ncol) qsrflx_mzaer2cnvpr(1:ncol,mm,2) = sflxecdp(1:ncol) - !RCE 2012/01/12 end - prev ~40 lines are new - endif + end if ! ( convproc_do_aer ) + !RCE 2012/01/12 end - prev ~40 lines are new - if (do_hygro_sum_del) then - tmpa = spechygro(lspectype_amode(lspec,m))/ & - specdens_amode(lspectype_amode(lspec,m)) - tmpb = tmpa*dt - hygro_sum_old(1:ncol,:) = hygro_sum_old(1:ncol,:) & - + tmpa*q_tmp(1:ncol,:) - hygro_sum_del(1:ncol,:) = hygro_sum_del(1:ncol,:) & - + tmpb*dqdt_tmp(1:ncol,:) - end if - else if ((lphase == 1) .and. (lspec == nspec_amode(m)+1)) then + + if (do_hygro_sum_del) then + tmpa = spechygro(lspectype_amode(lspec,m))/ & + specdens_amode(lspectype_amode(lspec,m)) + tmpb = tmpa*dt + hygro_sum_old(1:ncol,:) = hygro_sum_old(1:ncol,:) & + + tmpa*q_tmp(1:ncol,:) + hygro_sum_del(1:ncol,:) = hygro_sum_del(1:ncol,:) & + + tmpb*dqdt_tmp(1:ncol,:) + end if + + + +! else if ((lphase == 1) .and. (lspec == nspec_amode(m)+1)) then + else if ((lphase == 1) .and. (jnummaswtr == jaerowater)) then lphase_jnmw_conditional do_lphase1 = .true. - if(convproc_do_aer .or. convproc_do_gas) then + if (convproc_do_aer) then do_lphase1 = .false. - if(do_aero_water_removal)do_lphase1 = .true. + if (do_aero_water_removal) do_lphase1 = .true. endif - if(do_lphase1) then + if (do_lphase1) then ! aerosol water -- because of how wetdepa treats evaporation of stratiform ! precip, it is not appropriate to apply wetdepa to aerosol water ! instead, "hygro_sum" = [sum of (mass*hygro/dens)] is calculated before and @@ -1555,17 +1906,27 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! ! enddo ! enddo ! call outfld( trim(cnst_name(mm)) - endif + endif ! (do_lphase1) + - elseif(lphase == 2) then ! lphase == 2 + + elseif (lphase == 2) then lphase_jnmw_conditional ! lphase == 2 do_lphase2 = .true. - if(convproc_do_aer .or. convproc_do_gas) then - do_lphase2 = .false. - if(lspec <= nspec_amode(m))do_lphase2 = .true. - endif - if( do_lphase2 ) then +! REASTER 08/11/2015 start +! There is no cloud-borne aerosol water in the model, so the do_lphase2 code block +! should NEVER execute for lspec = nspec_amode(m)+1 (i.e., jnummaswtr = jaerowater). +! The code only worked because the "do lspec" loop cycles when lspec = nspec_amode(m)+1, +! but that does not make the code correct. +! if (convproc_do_aer) then +! do_lphase2 = .false. +! if (lspec <= nspec_amode(m)) do_lphase2 = .true. +! endif + if (jnummaswtr == jaerowater) do_lphase2 = .false. +! REASTER 08/11/2015 end +do_lphase2_conditional: & + if ( do_lphase2 ) then dqdt_tmp(:,:) = 0.0_r8 - if(convproc_do_aer .or. convproc_do_gas) then + if (convproc_do_aer) then fldcw => qqcw_get_field(pbuf,mm,lchnk) qqcw_sav(1:ncol,:,lspec) = fldcw(1:ncol,:) !RCE 2012/01/12 else @@ -1573,30 +1934,49 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! fldcw => qqcw_get_field(pbuf, mm,lchnk) endif - call wetdepa_v2(state%t, state%pmid, state%q(:,:,1), state%pdel, & - dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & - dep_inputs%evapc, dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & - dep_inputs%evapr, dep_inputs%totcond, fldcw, dt, & - dqdt_tmp, iscavt, dep_inputs%cldv, dep_inputs%cldvcu, dep_inputs%cldvst, & - dlf, fracis_cw, sol_factb, ncol, & - scavcoefnv(:,:,jnv), & - is_strat_cloudborne=.true., & - rate1ord_cw2pr_st=rate1ord_cw2pr_st, & - qqcw=qqcw_tmp, & - f_act_conv=f_act_conv, & - icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & - rcscavt=rcscavt, rsscavt=rsscavt, & - sol_facti_in=sol_facti, sol_factbi_in=sol_factbi, sol_factii_in=sol_factii, & - sol_factic_in=sol_factic, sol_factiic_in=sol_factiic, resus_fix=resus_fix) - - if(convproc_do_aer .or. convproc_do_gas) then - ! save resuspension of cloudborne species - - rtscavt(1:ncol,:,lspec) = rcscavt(1:ncol,:) + rsscavt(1:ncol,:) ! RCE 2012/01/12 - - ! wetdepa_v2 adds the resuspension of cloudborne to the dqdt of cloudborne (as a source) - ! undo this, so the resuspension of cloudborne can be added to the dqdt of interstitial (above) - dqdt_tmp(1:ncol,:) = dqdt_tmp(1:ncol,:) - rtscavt(1:ncol,:,lspec) ! RCE 2012/01/12 + call wetdepa_v2( & + ncol, dt, & + state%t, state%pmid, state%q(:,:,1), state%pdel, & + dep_inputs%cmfdqr, dep_inputs%evapc, dlf, dep_inputs%conicw, & + dep_inputs%prain, dep_inputs%qme, dep_inputs%evapr, dep_inputs%totcond, & + dep_inputs%cldt, dep_inputs%cldcu, & + dep_inputs%cldv, dep_inputs%cldvcu, dep_inputs%cldvst, & + sol_factb, sol_factbi, sol_facti, sol_factii, sol_factic, sol_factiic, & + mam_prevap_resusp_optcc, .true., scavcoefnv(:,:,jnv), rate1ord_cw2pr_st, f_act_conv, & + fldcw, qqcw_tmp, & + fracis_cw, dqdt_tmp, iscavt, & + icscavt, isscavt, bcscavt, bsscavt, rcscavt, rsscavt ) + +! REASTER 08/12/2015 BEGIN + if ( mam_prevap_resusp_optaa10 == 3 ) then + ! resuspension goes to coarse mode + ! first deduct the current resuspension from the dqdt_tmp of the current species + dqdt_tmp(1:ncol,:) = dqdt_tmp(1:ncol,:) - ( rcscavt(1:ncol,:) + rsscavt(1:ncol,:) ) + ! then add the current resuspension to the rtscavt_sv of the appropriate coarse mode species + mmtoo = mmtoo_prevap_resusp(mm) + if (mmtoo > 0) rtscavt_sv(1:ncol,:,mmtoo) = rtscavt_sv(1:ncol,:,mmtoo) & + + ( rcscavt(1:ncol,:) + rsscavt(1:ncol,:) ) + + endif +! REASTER 08/12/2015 END + +! if (convproc_do_aer) then + if ( mam_prevap_resusp_optaa10 == 2 ) then + ! the original wetdepa_v2 adds the resuspension of cloudborne aerosol species + ! to the dqdt of cloudborne species (as a source) + ! when resus_fix=.true. and/or mam_prevap_resusp_optaa=20,21 ) then + ! > save resuspension of cloudborne species to rtscavt_sv + ! > deduct it from the tendency (dqdt_tmp) of the cloudborne species + ! > add it to the tendency (dqdt_tmp) of the interstitial species (which is done above) +! rtscavt_sv(1:ncol,:,lspec) = rcscavt(1:ncol,:) + rsscavt(1:ncol,:) ! RCE 2012/01/12 + if ( 0 < mmai .and. mmai <= pcnst ) then + rtscavt_sv(1:ncol,:,mmai) = rcscavt(1:ncol,:) + rsscavt(1:ncol,:) ! REASTER 08/11/2015 + else + write(msg,'(a,3(1x,i5))') 'aero_model_wetdep - bad mmai - m, mm, mmai =', m, mm, mmai + call endrun( msg ) + endif +! dqdt_tmp(1:ncol,:) = dqdt_tmp(1:ncol,:) - rtscavt_sv(1:ncol,:,lspec) ! RCE 2012/01/12 + dqdt_tmp(1:ncol,:) = dqdt_tmp(1:ncol,:) - rtscavt_sv(1:ncol,:,mmai) ! REASTER 08/11/2015 endif @@ -1640,8 +2020,10 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! enddo call outfld( trim(cnst_name_cw(mm))//'SFSBS', sflx, pcols, lchnk) - if(convproc_do_aer .or. convproc_do_gas) then - !BSINGH(09/15/2014):Following two nested do-loops are new additions for unified convection +! if (convproc_do_aer) then +! !BSINGH(09/15/2014):Following two nested do-loops are new additions for unified convection + ! REASTER 08/10/2015 - NO. They are new additions for resus_fix=.true. + if ( history_aero_prevap_resusp ) then sflx(:)=0.0_r8 do k=1,pver sflx(1:ncol)=sflx(1:ncol)+rcscavt(1:ncol,k)*state%pdel(1:ncol,k)/gravit @@ -1655,12 +2037,14 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! call outfld( trim(cnst_name_cw(mm))//'SFSES', sflx, pcols, lchnk) !RCE 2012/01/12 end - prev ~40 lines are changed endif - endif - endif - enddo ! lspec = 0, nspec_amode(m)+1 - enddo ! lphase = 1, 2 - enddo ! m = 1, ntot_amode + endif do_lphase2_conditional + + endif lphase_jnmw_conditional + + enddo lspec_loop_aa ! lspec = 1, nspec_amode(m)+2 + enddo lphase_loop_aa ! lphase = 1, 2 + enddo mmode_loop_aa ! m = 1, ntot_amode ! if the user has specified prescribed aerosol dep fluxes then ! do not set cam_out dep fluxes according to the prognostic aerosols @@ -1668,7 +2052,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! call set_srf_wetdep(aerdepwetis, aerdepwetcw, cam_out) endif - if(convproc_do_aer .or. convproc_do_gas) then + if (convproc_do_aer) then call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp ) call pbuf_get_field(pbuf, icwmrsh_idx, icwmrsh ) @@ -1682,7 +2066,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! dlf, dlf2, cmfmc2, sh_e_ed_ratio, & nsrflx_mzaer2cnvpr, qsrflx_mzaer2cnvpr, aerdepwetis, & mu, md, du, eu, ed, dp, dsubcld, jt, maxg, ideep, lengath, & - species_class) + species_class, mam_prevap_resusp_optaa ) call t_stopf('ma_convproc') endif diff --git a/components/cam/src/chemistry/modal_aero/modal_aero_convproc.F90 b/components/cam/src/chemistry/modal_aero/modal_aero_convproc.F90 index f789744e4aaf..2f24ab63ece0 100644 --- a/components/cam/src/chemistry/modal_aero/modal_aero_convproc.F90 +++ b/components/cam/src/chemistry/modal_aero/modal_aero_convproc.F90 @@ -20,6 +20,7 @@ module modal_aero_convproc use ppgrid, only: pver, pcols, pverp, begchunk, endchunk use cam_history, only: outfld, addfld, add_default, phys_decomp use cam_logfile, only: iulog + use cam_abortutils, only: endrun use physconst, only: spec_class_aerosol, spec_class_gas implicit none @@ -64,13 +65,14 @@ module modal_aero_convproc ! ! Private module data -! (none currently) ! logical, private :: convproc_do_gas, convproc_do_aer + logical, private :: convproc_prevap_resusp_fixaa = .false. ! REASTER 08/05/2015 + ! convproc_method_fixaa - see explanation in subr. ma_convproc_tend( & + integer, private :: convproc_method_activate ! convproc_method_activate - 1=apply abdulrazzak-ghan to entrained aerosols for lowest nlayers ! 2=do secondary activation with prescribed supersat - integer, private :: convproc_method_activate !========================================================================================= contains @@ -111,13 +113,16 @@ subroutine ma_convproc_init integer :: npass_calc_updraft logical :: history_aerosol ! Output the MAM aerosol tendencies + logical :: resus_fix + character(len=100) :: msg ! ! Add history fields ! call phys_getopts( history_aerosol_out=history_aerosol, & - convproc_do_aer_out = convproc_do_aer, convproc_do_gas_out = convproc_do_gas, & - convproc_method_activate_out = convproc_method_activate) + convproc_do_aer_out = convproc_do_aer, & + convproc_do_gas_out = convproc_do_gas, & + convproc_method_activate_out = convproc_method_activate ) call addfld( 'SH_MFUP_MAX', 'kg/m2', 1, 'A', & 'Shallow conv. column-max updraft mass flux', phys_decomp ) @@ -133,8 +138,7 @@ subroutine ma_convproc_init call addfld( 'DP_KCLDBASE', '1', 1, 'A', & 'Deep conv. cloudbase level index', phys_decomp ) - if ( history_aerosol .and. & - ( convproc_do_aer .or. convproc_do_gas) ) then + if ( history_aerosol .and. convproc_do_aer ) then call add_default( 'SH_MFUP_MAX', 1, ' ' ) call add_default( 'SH_WCLDBASE', 1, ' ' ) call add_default( 'SH_KCLDBASE', 1, ' ' ) @@ -188,7 +192,8 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & aerdepwetis, & mu, md, du, eu, & ed, dp, dsubcld, & - jt, maxg, ideep, lengath, species_class ) + jt, maxg, ideep, lengath, species_class, & + mam_prevap_resusp_optaa ) !----------------------------------------------------------------------- ! ! Purpose: @@ -212,7 +217,6 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & use constituents, only: pcnst, cnst_name use error_messages, only: alloc_err - use cam_abortutils, only: endrun use modal_aero_data, only: lmassptr_amode, nspec_amode, ntot_amode, numptr_amode ! Arguments @@ -253,10 +257,11 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & integer, intent(in) :: ideep(pcols) ! Gathering array integer, intent(in) :: lengath ! Gathered min lon indices over which to operate integer, intent(in) :: species_class(:) + integer, intent(in) :: mam_prevap_resusp_optaa ! Local variables - integer, parameter :: nsrflx = 5 ! last dimension of qsrflx + integer, parameter :: nsrflx = 6 ! last dimension of qsrflx ! REASTER 08/05/2015 integer :: i, ii, itmpa integer :: k integer :: l, ll, lchnk @@ -283,6 +288,10 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & ! ! Initialize ! + +! apply this minor fix when doing resuspend to coarse mode + if (mam_prevap_resusp_optaa >= 30) convproc_prevap_resusp_fixaa = .true. + lchnk = state%lchnk ncol = state%ncol nstep = get_nstep() @@ -352,7 +361,7 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & ed, dp, dsubcld, & jt, maxg, ideep, lengath, & qb, dqdt, dotend, nsrflx, qsrflx, & - species_class ) + species_class, mam_prevap_resusp_optaa ) ! apply deep conv processing tendency and prepare for shallow conv processing @@ -380,8 +389,8 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & ! these used for history file wetdep diagnostics sflxic(1:ncol,l) = sflxic(1:ncol,l) + qsrflx(1:ncol,l,4) sflxid(1:ncol,l) = sflxid(1:ncol,l) + qsrflx(1:ncol,l,4) - sflxec(1:ncol,l) = sflxec(1:ncol,l) + qsrflx(1:ncol,l,5) - sflxed(1:ncol,l) = sflxed(1:ncol,l) + qsrflx(1:ncol,l,5) + sflxec(1:ncol,l) = sflxec(1:ncol,l) + qsrflx(1:ncol,l,6) ! REASTER 08/05/2015 + sflxed(1:ncol,l) = sflxed(1:ncol,l) + qsrflx(1:ncol,l,6) ! REASTER 08/05/2015 end if if (species_class(l) == spec_class_aerosol) then @@ -409,7 +418,7 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & sh_frac, icwmrsh, rprdsh, evapcsh, dlfsh, & cmfmcsh, sh_e_ed_ratio, & qb, dqdt, dotend, nsrflx, qsrflx, & - species_class ) + species_class, mam_prevap_resusp_optaa ) ! apply shallow conv processing tendency @@ -435,7 +444,7 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & if ((species_class(l) == spec_class_aerosol) .or. & (species_class(l) == spec_class_gas )) then sflxic(1:ncol,l) = sflxic(1:ncol,l) + qsrflx(1:ncol,l,4) - sflxec(1:ncol,l) = sflxec(1:ncol,l) + qsrflx(1:ncol,l,5) + sflxec(1:ncol,l) = sflxec(1:ncol,l) + qsrflx(1:ncol,l,6) ! REASTER 08/05/2015 end if if (species_class(l) == spec_class_aerosol) then @@ -467,8 +476,8 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & call outfld( trim(cnst_name(l))//'SFSEC', sflxec(:,l), pcols, lchnk ) if ( deepconv_wetdep_history ) then - call outfld( trim(cnst_name(l))//'SFSID', sflxid(:,l), pcols, lchnk ) - call outfld( trim(cnst_name(l))//'SFSED', sflxed(:,l), pcols, lchnk ) + call outfld( trim(cnst_name(l))//'SFSID', sflxid(:,l), pcols, lchnk ) + call outfld( trim(cnst_name(l))//'SFSED', sflxed(:,l), pcols, lchnk ) end if end do ! ll end do ! n @@ -487,7 +496,7 @@ subroutine ma_convproc_dp_intr( & ed, dp, dsubcld, & jt, maxg, ideep, lengath, & q, dqdt, dotend, nsrflx, qsrflx, & - species_class ) + species_class, mam_prevap_resusp_optaa ) !----------------------------------------------------------------------- ! ! Purpose: @@ -513,7 +522,6 @@ subroutine ma_convproc_dp_intr( & use physconst, only: gravit, rair use phys_grid, only: get_lat_all_p, get_lon_all_p, get_rlat_all_p, get_rlon_all_p - use cam_abortutils, only: endrun use modal_aero_data, only: lmassptr_amode, nspec_amode, ntot_amode, numptr_amode @@ -550,6 +558,7 @@ subroutine ma_convproc_dp_intr( & integer, intent(in) :: ideep(pcols) ! Gathering array integer, intent(in) :: lengath ! Gathered min lon indices over which to operate integer, intent(in) :: species_class(:) + integer, intent(in) :: mam_prevap_resusp_optaa ! real(r8), intent(in) :: concld(pcols,pver) ! Convective cloud cover @@ -826,6 +835,7 @@ subroutine ma_convproc_dp_intr( & dp_frac, icwmrdp, rprddp, evapcdp, & fracice, & dqdt, dotend, nsrflx, qsrflx, & + species_class, mam_prevap_resusp_optaa, & ! REASTER 08/05/2015 xx_mfup_max, xx_wcldbase, xx_kcldbase, & lun, itmpveca ) ! ed, dp, dsubcld, jt, & @@ -912,7 +922,7 @@ subroutine ma_convproc_sh_intr( & sh_frac, icwmrsh, rprdsh, evapcsh, dlfsh, & cmfmcsh, sh_e_ed_ratio, & q, dqdt, dotend, nsrflx, qsrflx, & - species_class ) + species_class, mam_prevap_resusp_optaa ) !----------------------------------------------------------------------- ! ! Purpose: @@ -938,7 +948,6 @@ subroutine ma_convproc_sh_intr( & use physconst, only: gravit, rair use phys_grid, only: get_lat_all_p, get_lon_all_p, get_rlat_all_p, get_rlon_all_p - use cam_abortutils, only: endrun use modal_aero_data, only: lmassptr_amode, nspec_amode, ntot_amode, numptr_amode @@ -962,6 +971,7 @@ subroutine ma_convproc_sh_intr( & real(r8), intent(in) :: cmfmcsh(pcols,pverp) ! Shallow conv mass flux (kg/m2/s) real(r8), intent(in) :: sh_e_ed_ratio(pcols,pver) ! shallow conv [ent/(ent+det)] ratio integer, intent(in) :: species_class(:) + integer, intent(in) :: mam_prevap_resusp_optaa ! real(r8), intent(in) :: concld(pcols,pver) ! Convective cloud cover @@ -1351,6 +1361,7 @@ subroutine ma_convproc_sh_intr( & sh_frac, icwmrsh, rprdsh, evapcsh, & fracice, & dqdt, dotend, nsrflx, qsrflx, & + species_class, mam_prevap_resusp_optaa, & ! REASTER 08/05/2015 xx_mfup_max, xx_wcldbase, xx_kcldbase, & lun, itmpveca2 ) @@ -1453,6 +1464,7 @@ subroutine ma_convproc_tend( & cldfrac, icwmr, rprd, evapc, & fracice, & dqdt, doconvproc, nsrflx, qsrflx, & + species_class, mam_prevap_resusp_optaa, & ! REASTER 08/05/2015 xx_mfup_max, xx_wcldbase, xx_kcldbase, & lun, idiag_in ) @@ -1497,7 +1509,6 @@ subroutine ma_convproc_tend( & use ppgrid, only: pcols, pver use physconst, only: gravit, rair, rhoh2o use constituents, only: pcnst, cnst_name - use cam_abortutils, only: endrun use modal_aero_data, only: cnst_name_cw, & lmassptr_amode, lmassptrcw_amode, & @@ -1553,11 +1564,17 @@ subroutine ma_convproc_tend( & integer, intent(in) :: nsrflx ! last dimension of qsrflx real(r8), intent(out):: qsrflx(pcols,pcnst,nsrflx) ! process-specific column tracer tendencies - ! (1=activation, 2=resuspension, 3=aqueous rxn, - ! 4=wet removal, 5=renaming) - real(r8), intent(out) :: xx_mfup_max(pcols) - real(r8), intent(out) :: xx_wcldbase(pcols) - real(r8), intent(out) :: xx_kcldbase(pcols) + ! 1 = activation of interstial to conv-cloudborne + ! 2 = resuspension of conv-cloudborne to interstital + ! 3 = aqueous chemistry (not implemented yet, so zero) + ! 4 = wet removal + ! 5 = actual precip-evap resuspension (what actually is applied to a species) + ! 6 = pseudo precip-evap resuspension (for history file) ! REASTER 08/05/2015 + integer, intent(in) :: species_class(:) ! REASTER 08/05/2015 + integer, intent(in) :: mam_prevap_resusp_optaa ! REASTER 08/05/2015 + real(r8), intent(out):: xx_mfup_max(pcols) + real(r8), intent(out):: xx_wcldbase(pcols) + real(r8), intent(out):: xx_kcldbase(pcols) integer, intent(in) :: lun ! unit number for diagnostic output integer, intent(in) :: idiag_in(pcols) ! flag for diagnostic output @@ -1579,6 +1596,7 @@ subroutine ma_convproc_tend( & integer :: kactcntb ! Counter for activation diagnostic output integer :: kactfirst ! Lowest layer with activation (= cloudbase) integer :: kbot ! Cloud-flux bottom layer for current i (=mx(i)) + integer :: kbot_prevap ! Lowest layer for doing resuspension from evaporating precip ! REASTER 08/05/2015 integer :: ktop ! Cloud-flux top layer for current i (=jt(i)) ! Layers between kbot,ktop have mass fluxes ! but not all have cloud water, because the @@ -1608,6 +1626,7 @@ subroutine ma_convproc_tend( & real(r8) dcondt(pcnst_extd,pver) ! grid-average TMR tendency for current column real(r8) dcondt_prevap(pcnst_extd,pver) ! portion of dcondt from precip evaporation + real(r8) dcondt_prevap_hist(pcnst_extd,pver) ! similar but used for history output ! REASTER 08/05/2015 real(r8) dcondt_resusp(pcnst_extd,pver) ! portion of dcondt from resuspension real(r8) dcondt_wetdep(pcnst_extd,pver) ! portion of dcondt from wet deposition @@ -1629,6 +1648,7 @@ subroutine ma_convproc_tend( & real(r8) sumactiva(pcnst_extd) ! sum (over layers) of dp*dconudt_activa real(r8) sumaqchem(pcnst_extd) ! sum (over layers) of dp*dconudt_aqchem real(r8) sumprevap(pcnst_extd) ! sum (over layers) of dp*dcondt_prevap + real(r8) sumprevap_hist(pcnst_extd) ! sum (over layers) of dp*dcondt_prevap_hist ! REASTER 08/05/2015 real(r8) sumresusp(pcnst_extd) ! sum (over layers) of dp*dcondt_resusp real(r8) sumwetdep(pcnst_extd) ! sum (over layers) of dp*dconudt_wetdep @@ -1807,6 +1827,17 @@ subroutine ma_convproc_tend( & ! Zero out values at "top of cloudtop", "base of cloudbase" ktop = jt(i) kbot = mx(i) +! REASTER 08/05/2015 BEGIN +! usually the updraft ( & downdraft) start ( & end ) at kbot=pver, but sometimes kbot < pver +! transport, activation, resuspension, and wet removal only occur between kbot >= k >= ktop +! resuspension from evaporating precip can occur at k > kbot when kbot < pver +! in the first version of this routine, the precp evap resusp tendencies for k > kbot were ignored, +! but that is now fixed +! this was a minor bug with quite minor affects on the aerosol, +! because convective precip evap is (or used to be) much less than stratiform precip evap ) + kbot_prevap = kbot + if ( convproc_prevap_resusp_fixaa ) kbot_prevap = pver +! REASTER 08/05/2015 END mu_i(:) = 0.0 md_i(:) = 0.0 do k = ktop+1, kbot @@ -1907,6 +1938,7 @@ subroutine ma_convproc_tend( & dcondt_resusp(:,:) = 0.0 dcondt_wetdep(:,:) = 0.0 dcondt_prevap(:,:) = 0.0 + dcondt_prevap_hist(:,:) = 0.0 ! REASTER 08/05/2015 dconudt_aqchem(:,:) = 0.0 dconudt_wetdep(:,:) = 0.0 ! only initialize the activation tendency on ipass=1 @@ -2254,6 +2286,7 @@ subroutine ma_convproc_tend( & sumwetdep(:) = 0.0 sumresusp(:) = 0.0 sumprevap(:) = 0.0 + sumprevap_hist(:) = 0.0 ! REASTER 08/05/2015 maxflux(:) = 0.0 maxflux2(:) = 0.0 @@ -2371,10 +2404,12 @@ subroutine ma_convproc_tend( & ! calculate effects of precipitation evaporation call ma_precpevap_convproc( dcondt, dcondt_wetdep, dcondt_prevap, & + dcondt_prevap_hist, & ! REASTER 08/05/2015 rprd, evapc, dp_i, & icol, ktop, pcnst_extd, & lun, idiag_in(icol), lchnk, & - doconvproc_extd ) + doconvproc_extd, & + species_class, mam_prevap_resusp_optaa ) ! REASTER 08/05/2015 if ( idiag_in(icol)>0 ) then k = 26 do m = 16, 23, 7 @@ -2394,7 +2429,7 @@ subroutine ma_convproc_tend( & ! make adjustments to dcondt for activated & unactivated aerosol species ! pairs to account any (or total) resuspension of convective-cloudborne aerosol call ma_resuspend_convproc( dcondt, dcondt_resusp, & - const, dp_i, ktop, kbot, pcnst_extd ) + const, dp_i, ktop, kbot_prevap, pcnst_extd ) ! REASTER 08/05/2015 if ( idiag_in(icol)>0 ) then k = 26 do m = 16, 23, 7 @@ -2413,7 +2448,8 @@ subroutine ma_convproc_tend( & ! calculate new column-tendency variables do m = 2, ncnst_extd if (doconvproc_extd(m)) then - do k = ktop, kbot + ! should go to k=pver for dcondt_prevap, and this should be safe for other sums + do k = ktop, kbot_prevap ! REASTER 08/05/2015 sumchng3(m) = sumchng3(m) + dcondt(m,k)*dp_i(k) sumresusp(m) = sumresusp(m) + dcondt_resusp(m,k)*dp_i(k) maxresusp(m) = max( maxresusp(m), & @@ -2421,6 +2457,7 @@ subroutine ma_convproc_tend( & sumprevap(m) = sumprevap(m) + dcondt_prevap(m,k)*dp_i(k) maxprevap(m) = max( maxprevap(m), & abs(dcondt_prevap(m,k)*dp_i(k)) ) + sumprevap_hist(m) = sumprevap_hist(m) + dcondt_prevap_hist(m,k)*dp_i(k) ! REASTER 08/05/2015 end do end if end do ! m @@ -2520,6 +2557,7 @@ subroutine ma_convproc_tend( & sumaqchem(la) = sumaqchem(la) + sumaqchem(lc) sumwetdep(la) = sumwetdep(la) + sumwetdep(lc) sumprevap(la) = sumprevap(la) + sumprevap(lc) + sumprevap_hist(la) = sumprevap_hist(la) + sumprevap_hist(lc) ! REASTER 08/05/2015 ! if (n==1 .and. ll==1) then ! write(lun,*) 'la, sumaqchem(la) =', la, sumaqchem(la) ! endif @@ -2532,7 +2570,7 @@ subroutine ma_convproc_tend( & ! do m = 2, ncnst if (doconvproc(m)) then - do k = ktop, kbot + do k = ktop, kbot_prevap ! should go to k=pver because of prevap ! REASTER 08/05/2015 dqdt_i(k,m) = dcondt(m,k) dqdt(icol,k,m) = dqdt(icol,k,m) + dqdt_i(k,m)*xinv_ntsub end do @@ -2548,8 +2586,9 @@ subroutine ma_convproc_tend( & qsrflx_i(m,3) = sumaqchem(m)*hund_ovr_g qsrflx_i(m,4) = sumwetdep(m)*hund_ovr_g qsrflx_i(m,5) = sumprevap(m)*hund_ovr_g + qsrflx_i(m,6) = sumprevap_hist(m)*hund_ovr_g ! REASTER 08/05/2015 ! qsrflx_i(m,1:4) = 0. - qsrflx(icol,m,1:5) = qsrflx(icol,m,1:5) + qsrflx_i(m,1:5)*xinv_ntsub + qsrflx(icol,m,1:6) = qsrflx(icol,m,1:6) + qsrflx_i(m,1:6)*xinv_ntsub ! REASTER 08/05/2015 end if end do ! m @@ -2678,7 +2717,7 @@ subroutine ma_convproc_tend( & ! update the q_i for the next interation of the jtsub loop do m = 2, ncnst if (doconvproc(m)) then - do k = ktop, kbot + do k = ktop, kbot_prevap ! should go to k=pver because of prevap ! REASTER 08/05/2015 q_i(k,m) = max( (q_i(k,m) + dqdt_i(k,m)*dtsub), 0.0_r8 ) end do end if @@ -2700,10 +2739,12 @@ end subroutine ma_convproc_tend !========================================================================================= subroutine ma_precpevap_convproc( & dcondt, dcondt_wetdep, dcondt_prevap, & + dcondt_prevap_hist, & ! REASTER 08/05/2015 rprd, evapc, dp_i, & icol, ktop, pcnst_extd, & lun, idiag_prevap, lchnk, & - doconvproc_extd ) + doconvproc_extd, & + species_class, mam_prevap_resusp_optaa ) ! REASTER 08/05/2015 !----------------------------------------------------------------------- ! ! Purpose: @@ -2716,9 +2757,11 @@ subroutine ma_precpevap_convproc( & use ppgrid, only: pcols, pver use constituents, only: pcnst + use physconst, only: spec_class_aerosol ! REASTER 08/05/2015 use modal_aero_data, only: & - lmassptrcw_amode, nspec_amode, numptrcw_amode + lmassptrcw_amode, nspec_amode, numptrcw_amode, & + mmtoo_prevap_resusp ! REASTER 08/05/2015 implicit none @@ -2735,6 +2778,19 @@ subroutine ma_precpevap_convproc( & ! portion of TMR tendency due to precip evaporation ! (actually, due to the adjustments made here) ! (on entry, this is 0.0) + real(r8), intent(inout) :: dcondt_prevap_hist(pcnst_extd,pver) ! REASTER 08/05/2015 + ! this determines what goes into the history + ! precip-evap SFSEC variables + ! currently, the SFSEC resuspension are attributed + ! to the species that got scavenged, + ! WHICH IS NOT the species that actually + ! receives the resuspension + ! when modal_aero_wetdep_resusp_opt > 0 + ! so when scavenged so4_c1 is resuspended as so4_a1, + ! this resuspension column-tendency shows + ! up in so4_c1SFSES + ! this is done to allow better tracking of the + ! resuspension in the mass-budget post-processing scripts real(r8), intent(in) :: rprd(pcols,pver) ! conv precip production rate (gathered) real(r8), intent(in) :: evapc(pcols,pver) ! conv precip evaporation rate (gathered) @@ -2747,10 +2803,12 @@ subroutine ma_precpevap_convproc( & integer, intent(in) :: lchnk ! chunk index logical, intent(in) :: doconvproc_extd(pcnst_extd) ! indicates which species to process + integer, intent(in) :: species_class(:) ! REASTER 08/05/2015 + integer, intent(in) :: mam_prevap_resusp_optaa ! REASTER 08/05/2015 !----------------------------------------------------------------------- ! local variables - integer :: k, l, ll, m, n + integer :: k, l, ll, m, m2, mmtoo, n ! REASTER 08/05/2015 real(r8) :: del_pr_flux_prod ! change to precip flux from production [(kg/kg/s)*mb] real(r8) :: del_pr_flux_evap ! change to precip flux from evaporation [(kg/kg/s)*mb] real(r8) :: del_wd_flux_evap ! change to wet deposition flux from evaporation [(kg/kg/s)*mb] @@ -2760,9 +2818,47 @@ subroutine ma_precpevap_convproc( & real(r8) :: tmpa, tmpb, tmpc, tmpd real(r8) :: tmpdp ! delta-pressure (mb) real(r8) :: wd_flux(pcnst_extd) ! tracer wet deposition flux at base of current layer [(kg/kg/s)*mb] + character(len=100) :: msg + !----------------------------------------------------------------------- + if ( mam_prevap_resusp_optaa == 30 ) then + call ma_precpevap30_convproc( & + dcondt, dcondt_wetdep, dcondt_prevap, & + dcondt_prevap_hist, & + rprd, evapc, dp_i, & + icol, ktop, pcnst_extd, & + lun, idiag_prevap, lchnk, & + doconvproc_extd, & + species_class, mam_prevap_resusp_optaa ) + return + else if ( mam_prevap_resusp_optaa /= 0 .and. & + mam_prevap_resusp_optaa /= 10 .and. & + mam_prevap_resusp_optaa /= 11 .and. & + mam_prevap_resusp_optaa /= 20 .and. & + mam_prevap_resusp_optaa /= 21 ) then + write(msg,'(a,2(1x,i10))') & + 'ma_precpevap_convproc - bad mam_prevap_resusp_optaa =', & + mam_prevap_resusp_optaa + call endrun( msg ) + end if + +! +! *** note use of non-standard units +! +! precip +! tmpdp = dp_i is mb +! rprd and evapc are kgwtr/kgair/s +! pr_flux = tmpdp*rprd is mb*kgwtr/kgair/s +! this works ok because the only important thing is fdel_pr_flux_evap which is dimensionless +! +! precip-borne aerosol +! dcondt_wetdep is kgaero/kgair/s +! wd_flux = tmpdp*dcondt_wetdep is mb*kgaero/kgair/s +! dcondt_prevap = del_wd_flux_evap/tmpdp is kgaero/kgair/s +! so this works ok too +! pr_flux = 0.0_r8 wd_flux(:) = 0.0_r8 @@ -2781,17 +2877,35 @@ subroutine ma_precpevap_convproc( & del_pr_flux_evap = min( pr_flux, tmpdp*max(0.0_r8, evapc(icol,k)) ) fdel_pr_flux_evap = del_pr_flux_evap / max(pr_flux, 1.0e-35_r8) + if ( mam_prevap_resusp_optaa <= 0 ) then + fdel_pr_flux_evap = 0.0_r8 ! REASTER 08/05/2015 - turn off resuspension from precip evap + end if + do m = 2, pcnst_extd if ( doconvproc_extd(m) ) then - ! use -dcondt_wetdep(m,k) as it is negative (or zero) + + ! dcondt_wetdep(m,k) is negative (or zero), so use -dcondt_wetdep(m,k) here wd_flux(m) = wd_flux(m) + tmpdp*max(0.0_r8, -dcondt_wetdep(m,k)) del_wd_flux_evap = wd_flux(m)*fdel_pr_flux_evap - wd_flux(m) = max( 0.0_r8, wd_flux(m)-del_wd_flux_evap ) +! REASTER 08/05/2015 BEGIN +! wd_flux(m) = max( 0.0_r8, wd_flux(m)-del_wd_flux_evap ) + +! dcondt_prevap(m,k) = del_wd_flux_evap/tmpdp +! dcondt(m,k) = dcondt(m,k) + dcondt_prevap(m,k) + + ! do this for mam_prevap_resusp_optaa = 0,10,11,20,21 + ! (also for trace gases when mam_prevap_resusp_opt = ???, + ! but currently modal_aero_convproc does not do trace gases) + dcondt_prevap_hist(m,k) = del_wd_flux_evap/tmpdp dcondt_prevap(m,k) = del_wd_flux_evap/tmpdp dcondt(m,k) = dcondt(m,k) + dcondt_prevap(m,k) - end if - end do + + wd_flux(m) = max( 0.0_r8, wd_flux(m)-del_wd_flux_evap ) + + end if ! ( doconvproc_extd(m) ) then + end do ! m = 2, pcnst_extd +! REASTER 08/05/2015 END pr_flux = max( 0.0_r8, pr_flux-del_pr_flux_evap ) @@ -2818,6 +2932,259 @@ end subroutine ma_precpevap_convproc +!========================================================================================= + subroutine ma_precpevap30_convproc( & + dcondt, dcondt_wetdep, dcondt_prevap, & + dcondt_prevap_hist, & ! REASTER 08/05/2015 + rprd, evapc, dp_i, & + icol, ktop, pcnst_extd, & + lun, idiag_prevap, lchnk, & + doconvproc_extd, & + species_class, mam_prevap_resusp_optaa ) ! REASTER 08/05/2015 +!----------------------------------------------------------------------- +! +! Purpose: +! Calculate resuspension of wet-removed aerosol species resulting precip evaporation +! for mam_prevap_resusp_optaa = 30 +! +! for aerosol mass species, do non-linear resuspension to coarse mode +! for aerosol number species, all the resuspension is done in wetdepa_v2, so do nothing here +! +! Author: R. Easter +! +!----------------------------------------------------------------------- + + use ppgrid, only: pcols, pver + use constituents, only: pcnst + use physconst, only: pi, spec_class_aerosol ! REASTER 08/05/2015 + + use modal_aero_data, only: & + lmassptr_amode, lmassptrcw_amode, lspectype_amode, & + nspec_amode, ntot_amode, numptr_amode, numptrcw_amode, & + mmtoo_prevap_resusp, ntoo_prevap_resusp, & ! REASTER 08/05/2015 + specdens_amode + use wetdep, only: faer_resusp_vs_fprec_evap_mpln + + implicit none + +!----------------------------------------------------------------------- +! arguments +! (note: TMR = tracer mixing ratio) + integer, intent(in) :: pcnst_extd + + real(r8), intent(inout) :: dcondt(pcnst_extd,pver) + ! overall TMR tendency from convection + real(r8), intent(in) :: dcondt_wetdep(pcnst_extd,pver) + ! portion of TMR tendency due to wet removal + real(r8), intent(inout) :: dcondt_prevap(pcnst_extd,pver) + ! portion of TMR tendency due to precip evaporation + ! (actually, due to the adjustments made here) + ! (on entry, this is 0.0) + real(r8), intent(inout) :: dcondt_prevap_hist(pcnst_extd,pver) ! REASTER 08/05/2015 + ! this determines what goes into the history + ! precip-evap SFSEC variables + ! currently, the SFSEC resuspension are attributed + ! to the species that got scavenged, + ! WHICH IS NOT the species that actually + ! receives the resuspension + ! when modal_aero_wetdep_resusp_opt > 0 + ! so when scavenged so4_c1 is resuspended as so4_a1, + ! this resuspension column-tendency shows + ! up in so4_c1SFSES + ! this is done to allow better tracking of the + ! resuspension in the mass-budget post-processing scripts + + real(r8), intent(in) :: rprd(pcols,pver) ! conv precip production rate (gathered) + real(r8), intent(in) :: evapc(pcols,pver) ! conv precip evaporation rate (gathered) + real(r8), intent(in) :: dp_i(pver) ! pressure thickness of level (in mb) + + integer, intent(in) :: icol ! normal (ungathered) i index for current column + integer, intent(in) :: ktop ! index of top cloud level for current column + integer, intent(in) :: lun ! logical unit for diagnostic output + integer, intent(in) :: idiag_prevap ! flag for diagnostic output + integer, intent(in) :: lchnk ! chunk index + + logical, intent(in) :: doconvproc_extd(pcnst_extd) ! indicates which species to process + integer, intent(in) :: species_class(:) ! REASTER 08/05/2015 + integer, intent(in) :: mam_prevap_resusp_optaa ! REASTER 08/05/2015 + +!----------------------------------------------------------------------- +! local variables + integer :: k, l, ll, lspec, lspectype + integer :: m, m2, mmtoo, n, numtoo + real(r8) :: d1p_prevap_resusp ! dry-diameter of one resuspended aerosol particle (m) + real(r8) :: del_pr_flux_prod ! change to precip flux from production [(kg/kg/s)*mb] + real(r8) :: del_pr_flux_evap ! change to precip flux from evaporation [(kg/kg/s)*mb] + real(r8) :: del_wd_flux_evap ! change to wet deposition flux from evaporation [(kg/kg/s)*mb] + real(r8) :: fdel_pr_flux_evap ! fractional change to precip flux from evaporation + real(r8) :: pr_flux ! precip flux at base of current layer [(kg/kg/s)*mb] + real(r8) :: pr_flux_old + real(r8) :: pr_flux_tmp + real(r8) :: pr_flux_base ! precip flux at an effective cloud base for calculations in a particular layer + real(r8) :: specdens_prevap_resusp(pcnst) + real(r8) :: tmpa, tmpb, tmpc, tmpd + real(r8) :: tmpdp ! delta-pressure (mb) + real(r8) :: u_old, u_tmp + real(r8) :: v1p_prevap_resusp ! dry-volume of one resuspended aerosol particle (m^3) + real(r8) :: wd_flux(pcnst_extd) ! tracer wet deposition flux at base of current layer [(kg/kg/s)*mb] + real(r8) :: wd_flux_tmp(pcnst_extd) + real(r8) :: x_old, x_tmp, x_ratio +!----------------------------------------------------------------------- + +! +! *** note use of non-standard units +! +! precip +! tmpdp = dp_i is mb +! rprd and evapc are kgwtr/kgair/s +! pr_flux = tmpdp*rprd is mb*kgwtr/kgair/s +! this works ok because the only important thing is fdel_pr_flux_evap which is dimensionless +! +! precip-borne aerosol +! dcondt_wetdep is kgaero/kgair/s +! wd_flux = tmpdp*dcondt_wetdep is mb*kgaero/kgair/s +! dcondt_prevap = del_wd_flux_evap/tmpdp is kgaero/kgair/s +! so this works ok too +! +! *** dilip switched from tmpdg to tmpdpg = tmpdp/gravit +! that is incorrect, but probably does not matter +! for precip, the u_old and u_tmp are dimensionless +! for aerosol, wd_flux units do not matter +! only important thing is that tmpdp (or tmpdpg) is used +! consistently when going from dcondt to wd_flux then to dcondt +! + + pr_flux = 0.0_r8 + pr_flux_base = 0.0_r8 + wd_flux(:) = 0.0_r8 + + if (idiag_prevap > 0) then + write(lun,'(a,i9,i4,5x,a)') 'qakx - lchnk,i', lchnk, icol, & + '// k; pr_flux old,new; delprod,devap; mode-1 numb wetdep,prevap; mass ...' + end if + + do k = ktop, pver + tmpdp = dp_i(k) + +! note - setting pr_flux_tmp, wd_flux_tmp, u_old, u_tmp, x_old, x_tmp +! to zero at this point is not necessary since they are all calculated +! "fresh" in each iteration of the "do k" loop +! no big deal except it clutters up the code + +! pr_flux_old = pr_flux +! del_pr_flux_prod = tmpdp*max(0.0_r8, rprd(icol,k)) +! pr_flux = pr_flux_old + del_pr_flux_prod + +! del_pr_flux_evap = min( pr_flux, tmpdp*max(0.0_r8, evapc(icol,k)) ) +! fdel_pr_flux_evap = del_pr_flux_evap / max(pr_flux, 1.0e-35_r8) + +! step 1 - precip evaporation and aerosol resuspension + tmpa = max( 0.0_r8, evapc(icol,k)*tmpdp ) + pr_flux_tmp = max( 0.0_r8, pr_flux - tmpa ) + pr_flux_tmp = min( pr_flux_base, pr_flux_tmp ) + + if (pr_flux_base < 1.0e-30_r8) then + ! when pr_flux_base=0, set u=0 to force 100% resuspension + u_old = 1.0_r8 ; x_old = 1.0_r8 + u_tmp = 0.0_r8 ; x_tmp = 0.0_r8 + x_ratio = 0.0_r8 + pr_flux_base = 0.0_r8 ! this will start things fresh at the next layer + pr_flux_tmp = 0.0_r8 ! (the next layer will then have u_old = 1) + else + u_old = pr_flux/pr_flux_base + u_old = max( 0.0_r8, min( 1.0_r8, u_old ) ) + x_old = 1.0_r8 - faer_resusp_vs_fprec_evap_mpln( 1.0_r8-u_old, 2) + x_old = max( 0.0_r8, min( 1.0_r8, x_old ) ) + + u_tmp = pr_flux_tmp/pr_flux_base + u_tmp = max( 0.0_r8, min( 1.0_r8, u_tmp ) ) + u_tmp = min( u_tmp, u_old ) + x_tmp = 1.0_r8 - faer_resusp_vs_fprec_evap_mpln( 1.0_r8-u_tmp, 2) + x_tmp = max( 0.0_r8, min( 1.0_r8, x_tmp ) ) + x_tmp = min( x_tmp, x_old ) + + if (x_tmp < 1.0e-30_r8) then ! or check on x? note that should have x_tmp >= x + x_ratio = 0.0_r8 + pr_flux_base = 0.0_r8 ! this will start things fresh at the next layer + pr_flux_tmp = 0.0_r8 ! (the next layer will then have u_old = 1) + else + x_ratio = x_tmp/x_old + end if + end if + +! step 2 - precip production and aerosol scavenging + tmpa = max( 0.0_r8, rprd(icol,k)*tmpdp ) + pr_flux_base = max( 0.0_r8, pr_flux_base + tmpa ) + pr_flux = max( 0.0_r8, pr_flux_tmp + tmpa ) + pr_flux = min( pr_flux_base, pr_flux ) + + + do m = 2, pcnst_extd + if ( .not. doconvproc_extd(m) ) cycle + +! step 1 again, but only the aerosol resuspension +! wd_flux_tmp (updated) = (wd_flux coming into the layer) - (resuspension ! decrement) + wd_flux_tmp(m) = max( 0.0_r8, wd_flux(m) * x_ratio ) + del_wd_flux_evap = max( 0.0_r8, wd_flux(m) - wd_flux_tmp(m) ) + +! step 2 again, but only the aerosol scavenging +! wd_flux (updated) = (wd_flux after resuspension) - (scavenging increment) + tmpa = max( 0.0_r8, -dcondt_wetdep(m,k)*tmpdp ) + wd_flux(m) = max( 0.0_r8, wd_flux_tmp(m) + tmpa ) + + tmpc = del_wd_flux_evap/tmpdp + + m2 = mod( m-1, pcnst ) + 1 ! for interstitial m2=m; for activated m2=m-pcnst + mmtoo = mmtoo_prevap_resusp(m2) + + if ( species_class(m2) == spec_class_aerosol ) then + if (mmtoo > 0) then + ! current species is an aerosol mass species + ! because mmtoo_resusp <= 0 for aerosol number species + + ! add the precip-evap (resuspension) to the history-tendency of the current species + dcondt_prevap_hist(m,k) = dcondt_prevap_hist(m,k) + tmpc + ! add the precip-evap (resuspension) to the actual tendencies + ! of appropriate + ! coarse-mode species + dcondt_prevap(mmtoo,k) = dcondt_prevap(mmtoo,k) + tmpc + dcondt(mmtoo,k) = dcondt(mmtoo,k) + tmpc + end if + + else ! ( species_class(m2) /= spec_class_aerosol ) + ! do this for trace gases (although currently modal_aero_convproc + ! does not treat trace gases) + dcondt_prevap_hist(m,k) = dcondt_prevap_hist(m,k) + tmpc + dcondt_prevap(m,k) = dcondt_prevap(m,k) + tmpc + dcondt(m,k) = dcondt(m,k) + tmpc + end if + + end do ! m = 2, pcnst_extd + + if (idiag_prevap > 0) then + n = 1 + l = numptrcw_amode(n) + pcnst + tmpa = dcondt_wetdep(l,k) + tmpb = dcondt_prevap(l,k) + tmpc = 0.0_r8 + tmpd = 0.0_r8 + do ll = 1, nspec_amode(n) + l = lmassptrcw_amode(ll,n) + pcnst + tmpc = tmpc + dcondt_wetdep(l,k) + tmpd = tmpd + dcondt_prevap(l,k) + end do + write(lun,'(a,i4,1p,4(2x,2e10.2))') 'qakx', k, & + pr_flux_old, pr_flux, del_pr_flux_prod, -del_pr_flux_evap, & + -tmpa, tmpb, -tmpc, tmpd + end if + + end do ! k + + return + end subroutine ma_precpevap30_convproc + + + !========================================================================================= subroutine ma_activate_convproc( & conu, dconudt, conent, & @@ -3399,7 +3766,7 @@ end subroutine ma_activate_convproc_method2 !========================================================================================= subroutine ma_resuspend_convproc( & dcondt, dcondt_resusp, & - const, dp_i, ktop, kbot, pcnst_extd ) + const, dp_i, ktop, kbot_prevap, pcnst_extd ) ! REASTER 08/05/2015 !----------------------------------------------------------------------- ! ! Purpose: @@ -3451,7 +3818,7 @@ subroutine ma_resuspend_convproc( & real(r8), intent(in) :: const(pcnst_extd,pver) ! TMRs before convection real(r8), intent(in) :: dp_i(pver) ! pressure thickness of level (in mb) - integer, intent(in) :: ktop, kbot ! indices of top and bottom cloud levels + integer, intent(in) :: ktop, kbot_prevap ! indices of top and bottom cloud levels ! REASTER 08/05/2015 !----------------------------------------------------------------------- ! local variables @@ -3477,7 +3844,7 @@ subroutine ma_resuspend_convproc( & if ( (la <= 0) .or. (la > pcnst_extd) ) cycle if ( (lc <= 0) .or. (lc > pcnst_extd) ) cycle - do k = ktop, kbot + do k = ktop, kbot_prevap ! REASTER 08/05/2015 qdota = dcondt(la,k) qdotc = dcondt(lc,k) qdotac = qdota + qdotc diff --git a/components/cam/src/chemistry/modal_aero/modal_aero_data.F90 b/components/cam/src/chemistry/modal_aero/modal_aero_data.F90 index 5e1c79b6285e..d41c1d1d683e 100644 --- a/components/cam/src/chemistry/modal_aero/modal_aero_data.F90 +++ b/components/cam/src/chemistry/modal_aero/modal_aero_data.F90 @@ -21,6 +21,12 @@ module modal_aero_data integer, parameter :: ntot_amode = 3 #endif +#if (( defined MODAL_AERO_3MODE ) || ( defined MODAL_AERO_4MODE )) && ( defined RAIN_EVAP_TO_COARSE_AERO ) + logical, parameter :: rain_evap_to_coarse_aero = .true. +#else + logical, parameter :: rain_evap_to_coarse_aero = .false. +#endif + ! ! definitions for aerosol chemical components ! @@ -70,9 +76,17 @@ module modal_aero_data #if ( defined MODAL_AERO_7MODE ) integer, parameter :: nspec_amode(ntot_amode) = (/ 6, 4, 2, 3, 3, 3, 3 /) ! SS #elif ( defined MODAL_AERO_4MODE ) +#if (defined RAIN_EVAP_TO_COARSE_AERO) + integer, parameter :: nspec_amode(ntot_amode) = (/ 6, 3, 6, 2 /) +#else integer, parameter :: nspec_amode(ntot_amode) = (/ 6, 3, 3, 2 /) +#endif #elif ( defined MODAL_AERO_3MODE ) +#if (defined RAIN_EVAP_TO_COARSE_AERO) + integer, parameter :: nspec_amode(ntot_amode) = (/ 6, 3, 6 /) +#else integer, parameter :: nspec_amode(ntot_amode) = (/ 6, 3, 3 /) +#endif #endif integer, parameter :: nspec_amode_max = 6 ! input mprognum_amode, mdiagnum_amode, mprogsfc_amode, mcalcwater_amode @@ -177,11 +191,22 @@ module modal_aero_data ! cldphysics, aerosol, gas ) + ! REASTER 08/04/2015 - used in precip evap resuspension to coarse mode + integer :: mam_prevap_resusp_optaa = 10 +! 0 = no resuspension +! 10 = original mam method with resus_fix=.false. (so4_a1 --> so4_a1, so4_c1 --> so4_c1) +! 20 = original mam method with resus_fix=.true. (so4_a1 & so4_c1 --> so4_a1) +! 30 = resuspend to coarse mode, full non-linear method (so4_a1 & so4_c1 --> so4_a3) +! 11 = like 10 but output column resuspension tendencies (rcscavt & rsscavt) to history +! 21 = like 20 but a with a few xxx = max( 0.0, xxx) added in werdepa_v2 + + integer :: mmtoo_prevap_resusp(pcnst), ntoo_prevap_resusp(pcnst) ! threshold for reporting negatives from subr qneg3 real(r8) :: qneg3_worst_thresh_amode(pcnst) integer, private :: qqcw(pcnst)=-1 ! Remaps modal_aero indices into pbuf + contains subroutine qqcw_set_ptr(index, iptr) diff --git a/components/cam/src/chemistry/modal_aero/modal_aero_initialize_data.F90 b/components/cam/src/chemistry/modal_aero/modal_aero_initialize_data.F90 index 2870a2f98b1c..226658b6cbc5 100644 --- a/components/cam/src/chemistry/modal_aero/modal_aero_initialize_data.F90 +++ b/components/cam/src/chemistry/modal_aero/modal_aero_initialize_data.F90 @@ -103,9 +103,16 @@ subroutine modal_aero_register(species_class) xname_spectype(:nspec_amode(3),3) = (/ 'p-organic ', 'black-c ' /) #elif ( defined MODAL_AERO_3MODE ) || ( defined MODAL_AERO_4MODE ) ! mode 3 (coarse dust & seasalt) species - xname_massptr(:nspec_amode(3),3) = (/ 'dst_a3 ', 'ncl_a3 ', 'so4_a3 ' /) - xname_massptrcw(:nspec_amode(3),3) = (/ 'dst_c3 ', 'ncl_c3 ', 'so4_c3 ' /) - xname_spectype(:nspec_amode(3),3) = (/ 'dust ', 'seasalt ', 'sulfate ' /) +#if (defined RAIN_EVAP_TO_COARSE_AERO) + xname_massptr(:nspec_amode(3),3) = (/ 'dst_a3 ', 'ncl_a3 ', 'so4_a3 ', 'bc_a3 ','pom_a3 ','soa_a3 ' /) + xname_massptrcw(:nspec_amode(3),3) = (/ 'dst_c3 ', 'ncl_c3 ', 'so4_c3 ', 'bc_c3 ','pom_c3 ','soa_c3 ' /) + xname_spectype(:nspec_amode(3),3) = (/ 'dust ', 'seasalt ', 'sulfate ', 'black-c ','p-organic ', & + 's-organic ' /) +#else + xname_massptr(:nspec_amode(3),3) = (/ 'dst_a3 ', 'ncl_a3 ', 'so4_a3 ' /) + xname_massptrcw(:nspec_amode(3),3) = (/ 'dst_c3 ', 'ncl_c3 ', 'so4_c3 ' /) + xname_spectype(:nspec_amode(3),3) = (/ 'dust ', 'seasalt ', 'sulfate ' /) +#endif #endif #if ( defined MODAL_AERO_4MODE ) diff --git a/components/cam/src/chemistry/mozart/chemistry.F90 b/components/cam/src/chemistry/mozart/chemistry.F90 index d6db48eba8fc..1d8fa64cd8f2 100644 --- a/components/cam/src/chemistry/mozart/chemistry.F90 +++ b/components/cam/src/chemistry/mozart/chemistry.F90 @@ -917,8 +917,8 @@ subroutine chem_init(phys_state, pbuf2d, species_class) call phys_getopts( cam_chempkg_out=chem_name, & history_aerosol_out=history_aerosol ) - ! Initialize aerosols - call aero_model_init( pbuf2d, species_class ) + ! Initialize aerosols - part 1 ! REASTER 8/4/2015 + call aero_model_init( pbuf2d, species_class, 1 ) ! aqueous chem initialization call sox_inti() @@ -1049,6 +1049,10 @@ subroutine chem_init(phys_state, pbuf2d, species_class) trim(shr_megan_mechcomps(n)%name)//' MEGAN emissions flux',phys_decomp) enddo endif + + ! Initialize aerosols - part 2 ! REASTER 8/4/2015 + call aero_model_init( pbuf2d, species_class, 2 ) + end subroutine chem_init !================================================================================ diff --git a/components/cam/src/dynamics/se/share/prim_state_mod.F90 b/components/cam/src/dynamics/se/share/prim_state_mod.F90 index 071f2a210b00..98bb5990e52a 100644 --- a/components/cam/src/dynamics/se/share/prim_state_mod.F90 +++ b/components/cam/src/dynamics/se/share/prim_state_mod.F90 @@ -637,7 +637,7 @@ subroutine prim_printstate(elem, tl,hybrid,hvcoord,nets,nete, fvm) if (tstep_type>0) then !no longer support tracer advection with tstep_type = 0 do q=1,qsize - write(iulog,'(a,i1,a,E22.14,a,2E15.7)') "Q",q,",Q diss, dQ^2/dt:",Qmass(q,2)," kg/m^2",& + write(iulog,'(a,i3,a,E22.14,a,2E15.7)') "Q",q,",Q diss, dQ^2/dt:",Qmass(q,2)," kg/m^2",& (Qmass(q,2)-Qmass(q,1))/dt,(Qvar(q,2)-Qvar(q,1))/dt enddo endif diff --git a/components/cam/src/physics/cam/gw_drag.F90 b/components/cam/src/physics/cam/gw_drag.F90 index 692b96ad1939..e111e1dbd5fc 100644 --- a/components/cam/src/physics/cam/gw_drag.F90 +++ b/components/cam/src/physics/cam/gw_drag.F90 @@ -288,7 +288,7 @@ subroutine gw_init() write(iulog,*) ' ' write(iulog,*) "GW_DRAG: pgwv = ", pgwv do l = -pgwv, pgwv - write (iulog,'(A,I2,A,F7.2)') "GW_DRAG: cref(",l,") = ",cref(l) + write (iulog,'(A,I4,A,F7.2)') "GW_DRAG: cref(",l,") = ",cref(l) enddo write(iulog,*) 'GW_DRAG: kwv = ', kwv write(iulog,*) 'GW_DRAG: fcrit2 = ', fcrit2 diff --git a/components/cam/src/physics/cam/phys_control.F90 b/components/cam/src/physics/cam/phys_control.F90 index e1da0ac317a6..a14ae96632b9 100644 --- a/components/cam/src/physics/cam/phys_control.F90 +++ b/components/cam/src/physics/cam/phys_control.F90 @@ -66,11 +66,12 @@ module phys_control ! liquid budgets. logical :: ssalt_tuning = .false. ! sea salt tuning flag for progseasalts_intr.F90 logical :: resus_fix = .false. ! to address resuspension bug fix in wetdep.F90 -logical :: convproc_do_aer = .false. ! to apply unified convective transport for aerosols -logical :: convproc_do_gas = .false. ! to apply unified convective transport for gasses +logical :: convproc_do_aer = .false. ! to apply unified convective transport/removal for aerosols +logical :: convproc_do_gas = .false. ! to apply unified convective transport/removal for trace gases + ! *** the unified conv. trans/removal currently does not do gases *** ! convproc_method_activate - 1=apply abdulrazzak-ghan to entrained aerosols for lowest nlayers ! 2=do secondary activation with prescribed supersat -integer :: convproc_method_activate = 2 ! unified convective transport method +integer :: convproc_method_activate = 2 ! controls activation in the unified convective transport/removal logical :: liqcf_fix = .false. ! liq cld fraction fix calc. logical :: regen_fix = .false. ! aerosol regeneration bug fix for ndrop.F90 logical :: demott_ice_nuc = .false. ! use DeMott ice nucleation treatment in microphysics From 5caba47aa44ce7ccab8278dc351f620a689bc2c3 Mon Sep 17 00:00:00 2001 From: Balwinder Singh Date: Mon, 23 Nov 2015 16:05:05 -0800 Subject: [PATCH 2/2] Added amicphys file and modified associated codes This commit adds a new file modal_aero_amicphys.F90 and modify associated codes. A new namelist option "mam_amicphys_optaa" is added to control the invokation of this code. This peice of code is invoked when "mam_amicphys_optaa" is set to 1 (default is 0). Fixes #484 --- components/cam/bld/build-namelist | 1 + .../namelist_files/namelist_defaults_cam.xml | 3 + .../namelist_files/namelist_definition.xml | 7 + .../src/chemistry/modal_aero/aero_model.F90 | 290 +- .../modal_aero/modal_aero_amicphys.F90 | 6042 +++++++++++++++++ .../chemistry/modal_aero/modal_aero_coag.F90 | 27 +- .../modal_aero/modal_aero_convproc.F90 | 6 +- .../chemistry/modal_aero/modal_aero_data.F90 | 10 + .../modal_aero/modal_aero_initialize_data.F90 | 40 +- .../modal_aero/modal_aero_newnuc.F90 | 119 +- .../chemistry/mozart/mo_gas_phase_chemdr.F90 | 2 +- .../chemistry/utils/modal_aero_calcsize.F90 | 471 +- .../cam/src/physics/cam/phys_control.F90 | 11 +- components/cam/src/physics/cam/physpkg.F90 | 2 +- components/rtm/src/riverroute/RtmMod.F90 | 5 +- 15 files changed, 6701 insertions(+), 335 deletions(-) create mode 100644 components/cam/src/chemistry/modal_aero/modal_aero_amicphys.F90 diff --git a/components/cam/bld/build-namelist b/components/cam/bld/build-namelist index 4fa66c24923b..b98731b563e8 100755 --- a/components/cam/bld/build-namelist +++ b/components/cam/bld/build-namelist @@ -2678,6 +2678,7 @@ add_default($nl, 'convproc_do_gas'); add_default($nl, 'demott_ice_nuc'); #BSINGH - ENDS +add_default($nl, 'mam_amicphys_optaa'); #for enabling amicphys code in cam # Microphysics scheme add_default($nl, 'use_subcol_microp'); diff --git a/components/cam/bld/namelist_files/namelist_defaults_cam.xml b/components/cam/bld/namelist_files/namelist_defaults_cam.xml index bf9379e7a178..4448156d8d20 100644 --- a/components/cam/bld/namelist_files/namelist_defaults_cam.xml +++ b/components/cam/bld/namelist_files/namelist_defaults_cam.xml @@ -848,6 +848,9 @@ 2 .false. + +0 + .false. diff --git a/components/cam/bld/namelist_files/namelist_definition.xml b/components/cam/bld/namelist_files/namelist_definition.xml index 549bac273dc6..0c019ae35e34 100644 --- a/components/cam/bld/namelist_files/namelist_definition.xml +++ b/components/cam/bld/namelist_files/namelist_definition.xml @@ -3368,6 +3368,13 @@ Default: .false. + + +invokes new microphysics code (single call to amicphys routine) if > 0 +Default: 0 + + diff --git a/components/cam/src/chemistry/modal_aero/aero_model.F90 b/components/cam/src/chemistry/modal_aero/aero_model.F90 index 7b5cfbd7f862..0289f5842afc 100644 --- a/components/cam/src/chemistry/modal_aero/aero_model.F90 +++ b/components/cam/src/chemistry/modal_aero/aero_model.F90 @@ -83,6 +83,7 @@ module aero_model integer :: strt_loop, end_loop, stride_loop !loop indices for the lphase loop ! Namelist variables + integer :: mam_amicphys_optaa logical :: sscav_tuning, convproc_do_aer, convproc_do_gas, resus_fix character(len=16) :: wetdep_list(pcnst) = ' ' character(len=16) :: drydep_list(pcnst) = ' ' @@ -202,17 +203,42 @@ subroutine aero_model_init( pbuf2d, species_class, iflagaa ) if ( masterproc ) write(iulog,'(a,i5)') 'aero_model_init iflagaa=', iflagaa ! REASTER 08/04/2015 - dgnum_idx = pbuf_get_index('DGNUM') - dgnumwet_idx = pbuf_get_index('DGNUMWET') - call phys_getopts( history_aerosol_out=history_aerosol, & convproc_do_aer_out = convproc_do_aer, & convproc_do_gas_out = convproc_do_gas, & - resus_fix_out = resus_fix ) + resus_fix_out = resus_fix, & + mam_amicphys_optaa_out = mam_amicphys_optaa ) ! REASTER 08/04/2015 -! mam_prevap_resusp_optaa = 30 ! REASTER 08/04/2015 BEGIN + ! This section cannot execute until chemini, ..., chm_diags_inti have been called + if ( iflagaa == 2 ) then + if ( masterproc ) then + write(iulog,'(a,i5,2x,a)') 'gas_wetdep_cnt,meth', gas_wetdep_cnt, gas_wetdep_method + do m = 1, gas_wetdep_cnt + write(iulog,'(a,i5,2x,a)') 'gas_wetdep_list ', m, trim(gas_wetdep_list(m)) + end do + end if + + ! These WD_ and DF_ fields should always been in a MAM history file, + ! but for now they are conditional on convproc_do_aer + if ( convproc_do_aer ) then + do m = 1,gas_pcnst + call cnst_get_ind( solsym(m), l, abort=.false. ) + if ( ( history_aerosol ) .and. & + (species_class(l) == spec_class_gas) ) then !RCE - only output WD_xxx and DF_xxx for gases + wetdep_name = 'WD_'//trim(solsym(m)) + depflx_name = 'DF_'//trim(solsym(m)) + nspc = get_het_ndx(solsym(m)) + if (nspc > 0) call add_default( wetdep_name, 1, ' ' ) + call add_default( depflx_name, 1, ' ' ) + endif + end do ! m = 1,gas_pcnst + endif + return + endif ! ( iflagaa == 2 ) + + m = mam_prevap_resusp_optaa if ( rain_evap_to_coarse_aero ) then if ( mam_prevap_resusp_optaa /= 30 ) then @@ -236,6 +262,11 @@ subroutine aero_model_init( pbuf2d, species_class, iflagaa ) endif endif +! *** activate this to override mam_prevap_resusp_optaa value for testing *** +! mam_prevap_resusp_optaa = 20 +! if ( masterproc ) write(iulog,'(2a)') 'aero_model_init - ', & +! 'mam_prevap_resusp_optaa changed from ?? to 20 for special test run' + if ( masterproc ) then write(iulog,'(2a,4l5,2i5)') 'aero_model_init - ', & 'convproc_do_aer & _gas, resus_fix, rain_evap_to_coarse, mam_prevap_resusp_optaa_v1/v2', & @@ -261,6 +292,13 @@ subroutine aero_model_init( pbuf2d, species_class, iflagaa ) endif endif +! mam_prevap_resusp_optaa values +! 0 = no resuspension +! 10 = original mam method with resus_fix=.false. (so4_a1 --> so4_a1, so4_c1 --> so4_c1) +! 20 = original mam method with resus_fix=.true. (so4_a1 & so4_c1 --> so4_a1) +! 30 = resuspend to coarse mode, full non-linear method (so4_a1 & so4_c1 --> so4_a3) +! 11 = like 10 but output column resuspension tendencies (rcscavt & rsscavt) to history +! 21 = like 20 but a with a few xxx = max( 0.0, xxx) added in werdepa_v2 m = 0 if ( mam_prevap_resusp_optaa == 0 ) m = 1 if ( mam_prevap_resusp_optaa == 10 ) m = 1 @@ -279,37 +317,12 @@ subroutine aero_model_init( pbuf2d, species_class, iflagaa ) history_aero_prevap_resusp = .false. if ( mam_prevap_resusp_optaa /= 10 ) history_aero_prevap_resusp = .true. + ! REASTER 08/04/2015 END - ! This section cannot execute until chemini, ..., chm_diags_inti have been called - if ( iflagaa == 2 ) then - if ( masterproc ) then - write(iulog,'(a,i5,2x,a)') 'gas_wetdep_cnt,meth', gas_wetdep_cnt, gas_wetdep_method - do m = 1, gas_wetdep_cnt - write(iulog,'(a,i5,2x,a)') 'gas_wetdep_list ', m, trim(gas_wetdep_list(m)) - end do - end if - - ! These WD_ and DF_ fields should always been in a MAM history file, - ! but for now they are conditional on convproc_do_aer - if ( convproc_do_aer ) then - do m = 1,gas_pcnst - call cnst_get_ind( solsym(m), l, abort=.false. ) - if ( ( history_aerosol ) .and. & - (species_class(l) == spec_class_gas) ) then !RCE - only output WD_xxx and DF_xxx for gases - wetdep_name = 'WD_'//trim(solsym(m)) - depflx_name = 'DF_'//trim(solsym(m)) - nspc = get_het_ndx(solsym(m)) - if (nspc > 0) call add_default( wetdep_name, 1, ' ' ) - call add_default( depflx_name, 1, ' ' ) - endif - end do ! m = 1,gas_pcnst - endif - return - endif ! ( iflagaa == 2 ) - ! REASTER 08/11/2015 END - - + dgnum_idx = pbuf_get_index('DGNUM') + dgnumwet_idx = pbuf_get_index('DGNUMWET') + !BSINGH: Decide the loop counters for the lphase loop in aero_model_wetdep subroutine !for cases with and without the unified convective transport !Counters for "without" unified convective treatment (i.e. default case) @@ -554,23 +567,10 @@ subroutine aero_model_init( pbuf2d, species_class, iflagaa ) call add_default (trim(wetdep_list(m))//'SFSIS', 1, ' ') call add_default (trim(wetdep_list(m))//'SFSBC', 1, ' ') call add_default (trim(wetdep_list(m))//'SFSBS', 1, ' ') - ! REASTER 08/04/2015 BEGIN - call addfld (trim(wetdep_list(m))//'SFWEZ',unit_basename//'/m2/s ', & - 1, 'A','Wet deposition flux at surface',phys_decomp) - call addfld (trim(wetdep_list(m))//'SFSEZ','kg/m2/s ', & - 1, 'A','Wet deposition flux (precip evap, convective) at surface',phys_decomp) !RCE - call addfld (trim(wetdep_list(m))//'SFSIZ',unit_basename//'/m2/s ', & - 1, 'A','Wet deposition flux (incloud, convective) at surface',phys_decomp) if ( history_aero_prevap_resusp ) then call add_default (trim(wetdep_list(m))//'SFSEC', 1, ' ') call add_default (trim(wetdep_list(m))//'SFSES', 1, ' ') endif - if(convproc_do_aer) then - call add_default (trim(wetdep_list(m))//'SFWEZ', 1, ' ') - call add_default (trim(wetdep_list(m))//'SFSEZ', 1, ' ') - call add_default (trim(wetdep_list(m))//'SFSIZ', 1, ' ') - endif - ! REASTER 08/04/2015 END endif enddo ! m = 1,nwetdep @@ -592,37 +592,11 @@ subroutine aero_model_init( pbuf2d, species_class, iflagaa ) call add_default( 'AQ_'//trim(solsym(m)), 1, ' ') endif -! REASTER 08/04/2015 BEGIN - this now done in the iflagaa==2 section -! if(convproc_do_gas) then -! wetdep_name = 'WD_'//trim(solsym(m)) -! depflx_name = 'DF_'//trim(solsym(m)) -! -! if ( history_aerosol ) then -! nspc = get_het_ndx(solsym(m)) -! if (nspc > 0) then -! call cnst_get_ind( solsym(m), nspc, abort=.false. ) -! if (nspc > 0) then -! if (species_class(nspc) == spec_class_gas) & !RCE - only output WD_xxx for gases -! call add_default( wetdep_name, 1, ' ' ) -! endif -! endif -! endif -! endif - -! call cnst_get_ind(trim(solsym(m)), nspc, abort=.false. ) -! if(convproc_do_gas) then -! if ( history_aerosol .and. (nspc > 0) ) then -! if (species_class(nspc) == spec_class_gas) & !RCE - only output DF_xxx for gases -! call add_default( depflx_name, 1, ' ' ) -! endif -! endif -! REASTER 08/04/2015 END - call cnst_get_ind(trim(solsym(m)), nspc, abort=.false. ) ! REASTER 08/04/2015 ! if(nspc > 0 .and. .not.cnst_name_cw(nspc) == ' ') then ! REASTER 08/04/2015 if( nspc > 0 ) then ! REASTER 08/04/2015 if ( .not. cnst_name_cw(nspc) == ' ') then ! REASTER 08/04/2015 - if(convproc_do_aer) then + if ( history_aero_prevap_resusp ) then call addfld (trim(cnst_name_cw(nspc))//'SFSEC','kg/m2/s ',1, 'A', & trim(cnst_name_cw(nspc))//' wet deposition flux (precip evap, convective) at surface',phys_decomp) !RCE call addfld (trim(cnst_name_cw(nspc))//'SFSES','kg/m2/s ',1, 'A', & @@ -636,6 +610,7 @@ subroutine aero_model_init( pbuf2d, species_class, iflagaa ) endif enddo + do n = 1,pcnst if( .not. (cnst_name_cw(n) == ' ') ) then @@ -677,6 +652,7 @@ subroutine aero_model_init( pbuf2d, species_class, iflagaa ) endif endif enddo + do n=1,ntot_amode dgnum_name(n) = ' ' write(dgnum_name(n),fmt='(a,i1)') 'dgnumwet',n @@ -1284,6 +1260,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! real(r8) :: tmpa, tmpb real(r8) :: tmpdust, tmpnacl real(r8) :: water_old, water_new ! temporary old/new aerosol water mix-rat + logical :: isprx(pcols,pver) ! true if precipation logical, parameter :: do_aero_water_removal = .false. ! True if aerosol water reduction by wet removal is to be calculated ! (this has not been fully tested, so best to leave it off) @@ -1331,6 +1308,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! type(wetdep_inputs_t) :: dep_inputs + lchnk = state%lchnk ncol = state%ncol @@ -1998,6 +1976,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! enddo enddo call outfld( trim(cnst_name_cw(mm))//'SFSIC', sflx, pcols, lchnk) + sflx(:)=0._r8 do k=1,pver do i=1,ncol @@ -2005,6 +1984,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! enddo enddo call outfld( trim(cnst_name_cw(mm))//'SFSIS', sflx, pcols, lchnk) + sflx(:)=0._r8 do k=1,pver do i=1,ncol @@ -2012,6 +1992,7 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! enddo enddo call outfld( trim(cnst_name_cw(mm))//'SFSBC', sflx, pcols, lchnk) + sflx(:)=0._r8 do k=1,pver do i=1,ncol @@ -2066,7 +2047,8 @@ subroutine aero_model_wetdep(dt, dlf, dlf2, cmfmc2, state, &! dlf, dlf2, cmfmc2, sh_e_ed_ratio, & nsrflx_mzaer2cnvpr, qsrflx_mzaer2cnvpr, aerdepwetis, & mu, md, du, eu, ed, dp, dsubcld, jt, maxg, ideep, lengath, & - species_class, mam_prevap_resusp_optaa ) + species_class, mam_prevap_resusp_optaa, & + history_aero_prevap_resusp ) call t_stopf('ma_convproc') endif @@ -2163,13 +2145,15 @@ end subroutine aero_model_surfarea !============================================================================= !============================================================================= - subroutine aero_model_gasaerexch( loffset, ncol, lchnk, delt, reaction_rates, & + subroutine aero_model_gasaerexch( loffset, ncol, lchnk, delt, & + latndx, lonndx, reaction_rates, & tfld, pmid, pdel, mbar, relhum, & zm, qh2o, cwat, cldfr, cldnum, & airdens, invariants, del_h2so4_gasprod, & vmr0, vmr, pbuf ) use time_manager, only : get_nstep + use modal_aero_amicphys, only : modal_aero_amicphys_intr use modal_aero_coag, only : modal_aero_coag_sub use modal_aero_gasaerexch, only : modal_aero_gasaerexch_sub use modal_aero_newnuc, only : modal_aero_newnuc_sub @@ -2182,6 +2166,8 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, delt, reaction_rates, & integer, intent(in) :: loffset ! offset applied to modal aero "pointers" integer, intent(in) :: ncol ! number columns in chunk integer, intent(in) :: lchnk ! chunk index + integer, intent(in) :: latndx(pcols) ! latitude indices + integer, intent(in) :: lonndx(pcols) ! longitude indices real(r8), intent(in) :: delt ! time step size (sec) real(r8), intent(in) :: reaction_rates(:,:,:) ! reaction rates real(r8), intent(in) :: tfld(:,:) ! temperature (K) @@ -2275,67 +2261,125 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, delt, reaction_rates, & endif ! Tendency due to aqueous chemistry - dvmrdt = (vmr - dvmrdt) / delt - dvmrcwdt = (vmrcw - dvmrcwdt) / delt +! When mam_amicphys_optaa > 0, dvmrdt & dvmrcwdt to hold vmr & vmrcw +! before aqueous chemistry, and cannot be used to hold aq. chem. tendencies +!***Note - should calc & output tendencies for cloud-borne aerosol species +! rather than interstitial here + if (mam_amicphys_optaa <= 0) then + dvmrdt = (vmr - dvmrdt) / delt + dvmrcwdt = (vmrcw - dvmrcwdt) / delt + endif do m = 1, gas_pcnst wrk(:) = 0._r8 do k = 1,pver - wrk(:ncol) = wrk(:ncol) + dvmrdt(:ncol,k,m) * adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + if (mam_amicphys_optaa <= 0) then + ! here dvmrdt is (delta vmr from aqueous chemistry)/(delt) + wrk(:ncol) = wrk(:ncol) + dvmrdt(:ncol,k,m) * adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + else + ! here dvmrdt is vmr before aqueous chemistry, so need to calculate (delta vmr)/(delt) + wrk(:ncol) = wrk(:ncol) + ((vmr(:ncol,k,m)-dvmrdt(:ncol,k,m))/delt) & + * adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + endif end do name = 'AQ_'//trim(solsym(m)) call outfld( name, wrk(:ncol), ncol, lchnk ) enddo -! do gas-aerosol exchange (h2so4, msa, nh3 condensation) - - if (ndx_h2so4 > 0) then - del_h2so4_aeruptk(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) - else - del_h2so4_aeruptk(:,:) = 0.0_r8 - endif - - call t_startf('modal_gas-aer_exchng') - - call modal_aero_gasaerexch_sub( & - lchnk, ncol, nstep, & - loffset, delt, & - tfld, pmid, pdel, & - vmr, vmrcw, & - dvmrdt, dvmrcwdt, & - dgnum, dgnumwet ) + if (mam_amicphys_optaa <= 0) then + ! do gas-aerosol exchange, nucleation, and coagulation using old routines - if (ndx_h2so4 > 0) then - del_h2so4_aeruptk(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) - del_h2so4_aeruptk(1:ncol,:) - endif - - call t_stopf('modal_gas-aer_exchng') - - call t_startf('modal_nucl') + ! do gas-aerosol exchange (h2so4, msa, nh3 condensation) + if (ndx_h2so4 > 0) then + del_h2so4_aeruptk(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) + else + del_h2so4_aeruptk(:,:) = 0.0_r8 + endif - ! do aerosol nucleation (new particle formation) - call modal_aero_newnuc_sub( & - lchnk, ncol, nstep, & - loffset, delt, & - tfld, pmid, pdel, & - zm, pblh, & - qh2o, cldfr, & - vmr, & - del_h2so4_gasprod, del_h2so4_aeruptk ) + call t_startf('modal_gas-aer_exchng') - call t_stopf('modal_nucl') + call modal_aero_gasaerexch_sub( & + lchnk, ncol, nstep, & + loffset, delt, & + tfld, pmid, pdel, & + vmr, vmrcw, & + dvmrdt, dvmrcwdt, & + dgnum, dgnumwet ) - call t_startf('modal_coag') + if (ndx_h2so4 > 0) then + del_h2so4_aeruptk(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) - del_h2so4_aeruptk(1:ncol,:) + endif - ! do aerosol coagulation - call modal_aero_coag_sub( & - lchnk, ncol, nstep, & - loffset, delt, & - tfld, pmid, pdel, & - vmr, & - dgnum, dgnumwet, & - wetdens ) + call t_stopf('modal_gas-aer_exchng') + + ! do aerosol nucleation (new particle formation) + call t_startf('modal_nucl') + + call modal_aero_newnuc_sub( & + lchnk, ncol, nstep, & + loffset, delt, & + tfld, pmid, pdel, & + zm, pblh, & + qh2o, cldfr, & + vmr, & + del_h2so4_gasprod, del_h2so4_aeruptk ) + + call t_stopf('modal_nucl') + + ! do aerosol coagulation + call t_startf('modal_coag') + + call modal_aero_coag_sub( & + lchnk, ncol, nstep, & + loffset, delt, & + tfld, pmid, pdel, & + vmr, & + dgnum, dgnumwet, & + wetdens ) + + call t_stopf('modal_coag') + + else ! (mam_amicphys_optaa > 0) + ! do gas-aerosol exchange, nucleation, and coagulation using new routines + + call t_startf('modal_aero_amicphys') + + ! note that: + ! vmr0 holds vmr before gas-phase chemistry + ! dvmrdt and dvmrcwdt hold vmr and vmrcw before aqueous chemistry + call modal_aero_amicphys_intr( & + 1, 1, & + 1, 1, & + lchnk, ncol, nstep, & + loffset, delt, & + latndx, lonndx, & + tfld, pmid, pdel, & + zm, pblh, & + qh2o, cldfr, & + vmr, vmrcw, & + vmr0, & + dvmrdt, dvmrcwdt, & + dgnum, dgnumwet, & + wetdens ) +! subroutine modal_aero_amicphys_intr( & +! mdo_gasaerexch, mdo_rename, & +! mdo_newnuc, mdo_coag, & +! lchnk, ncol, nstep, & +! loffset, deltat, & +! latndx, lonndx, & +! t, pmid, pdel, & +! zm, pblh, & +! qv, cld, & +! q, qqcw, & +! q_pregaschem, & +! q_precldchem, qqcw_precldchem, & +! dgncur_a, dgncur_awet, & +! wetdens_host, & +! qaerwat ) + + call t_startf('modal_aero_amicphys') + + endif ! (mam_amicphys_optaa <= 0 OR > 0) - call t_stopf('modal_coag') call vmr2qqcw( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) diff --git a/components/cam/src/chemistry/modal_aero/modal_aero_amicphys.F90 b/components/cam/src/chemistry/modal_aero/modal_aero_amicphys.F90 new file mode 100644 index 000000000000..7cbfbacba7d8 --- /dev/null +++ b/components/cam/src/chemistry/modal_aero/modal_aero_amicphys.F90 @@ -0,0 +1,6042 @@ +#define CAM_VERSION_IS_ACME + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +!BOP +! +! !MODULE: modal_aero_amicphys --- does modal aerosol gas-aerosol exchange +! +! !INTERFACE: + module modal_aero_amicphys + +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use chem_mods, only: gas_pcnst + use physconst, only: pi + use ppgrid, only: pcols, pver + use modal_aero_data, only: ntot_aspectype, ntot_amode, nsoa, npoa, nbc +! use ref_pres, only: top_lev => clim_modal_aero_top_lev ! this is for gg02a + use ref_pres, only: top_lev => trop_cloud_top_lev ! this is for ee02c + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + public modal_aero_amicphys_intr, modal_aero_amicphys_init + +! !PUBLIC DATA MEMBERS: + type :: misc_vars_aa_type +! using this derived type reduces the number of changes needed to add more mosaic diagnostics to history + real(r8) :: ncluster_tend_nnuc_1grid +#if ( defined( MOSAIC_SPECIES ) ) + real(r8) :: cnvrg_fail_1grid + real(r8) :: max_kelvin_iter_1grid + real(r8), dimension(5,4) :: xnerr_astem_negative_1grid +#endif + end type misc_vars_aa_type + + logical, public :: mosaic = .true. !BSINGH - Added logical for mosaic model + + integer, parameter :: pcnstxx = gas_pcnst + +! real(r8), parameter, public :: n_so4_monolayers_pcage = 1.0_r8 + real(r8), parameter, public :: n_so4_monolayers_pcage = 3.0_r8 +! number of so4(+nh4) monolayers needed to "age" a carbon particle + + real(r8), parameter, public :: & + dr_so4_monolayers_pcage = n_so4_monolayers_pcage * 4.76e-10 +! thickness of the so4 monolayers (m) +! for so4(+nh4), use bi-sulfate mw and 1.77 g/cm3, +! --> 1 mol so4(+nh4) = 65 cm^3 --> 1 molecule = (4.76e-10 m)^3 +! aging criterion is approximate so do not try to distinguish +! sulfuric acid, bisulfate, ammonium sulfate + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + integer, public :: cldy_rh_sameas_clear = 0 +! this is only used for some specific box model tests +#endif + + integer, public :: mdo_gaexch_cldy_subarea = 0 +! controls if gas condensation is done in cloudy subarea +! 1 = yes ; 0 = no + + integer, public :: gaexch_h2so4_uptake_optaa = 2 +! controls treatment of h2so4 condensation in mam_gasaerexch_1subarea +! 1 = sequential calc. of gas-chem prod then condensation loss +! 2 = simultaneous calc. of gas-chem prod and condensation loss + + integer, public :: newnuc_h2so4_conc_optaa = 2 +! controls treatment of h2so4 concentrationin mam_newnuc_1subarea +! 1 = use average value calculated in standard cam5.2.10 and earlier +! 2 = use average value calculated in mam_gasaerexch_1subarea +! 11 = use average of initial and final values from mam_gasaerexch_1subarea +! 12 = use final value from mam_gasaerexch_1subarea + + integer, public :: rename_method_optaa = 40 +! controls renaming parameterization + + integer, public :: update_qaerwat = 0 + integer, public :: update_dgncur_a = 0 + integer, public :: update_dgncur_awet = 0 +! controls updating of qaerwat +! controls updating of dgncur_a +! controls updating of dgncur_awet and wetdens_host + + real (r8) :: newnuc_adjust_factor_dnaitdt = 1.0_r8 + real (r8) :: newnuc_adjust_factor_pbl = 1.0_r8 + + +#if ( defined MODAL_AERO_3MODE ) + integer, parameter :: max_gas = nsoa + 1 + integer, parameter :: max_aer = nsoa + npoa + nbc + 3 +#elif ( defined MODAL_AERO_4MODE ) + integer, parameter :: max_gas = nsoa + 1 + integer, parameter :: max_aer = nsoa + npoa + nbc + 3 +#elif ( ( defined MODAL_AERO_7MODE ) && ( defined MOSAIC_SPECIES ) ) + integer, parameter :: max_gas = nsoa + 4 + integer, parameter :: max_aer = nsoa + npoa + nbc + 8 +#elif ( defined MODAL_AERO_7MODE ) + integer, parameter :: max_gas = nsoa + 2 + integer, parameter :: max_aer = nsoa + npoa + nbc + 4 +#elif ( defined MODAL_AERO_8MODE ) + integer, parameter :: max_gas = nsoa + 2 + integer, parameter :: max_aer = nsoa + npoa + nbc + 4 +#elif ( defined MODAL_AERO_9MODE ) + integer, parameter :: max_gas = nsoa + 2 + integer, parameter :: max_aer = nsoa + npoa + nbc + 4 + 5 +#endif + +#if ( defined MODAL_AERO_8MODE ) || ( defined MODAL_AERO_4MODE ) + integer, parameter :: ntot_amode_extd = ntot_amode +#else + integer, parameter :: ntot_amode_extd = ntot_amode + 1 +! integer, parameter :: ntot_amode_extd = ntot_amode +#endif + + integer, parameter :: max_mode_fresh = 1 + + integer, parameter :: max_mode = ntot_amode_extd + max_mode_fresh + public max_mode !BSINGH - used in module_mosaic_cam_init.F90 + + integer, parameter :: max_coagpair = 100 + +#if ( defined MODAL_AERO_9MODE ) + integer, parameter :: max_agepair = 3 +#else + integer, parameter :: max_agepair = 1 +#endif + + integer, parameter :: maxsubarea = 2 + + integer, parameter :: nqtendaa = 4 + integer, parameter :: iqtend_cond = 1 + integer, parameter :: iqtend_rnam = 2 + integer, parameter :: iqtend_nnuc = 3 + integer, parameter :: iqtend_coag = 4 + integer, parameter :: nqqcwtendaa = 1 + integer, parameter :: iqqcwtend_rnam = 1 + + integer, parameter :: iqqcwtend_match_iqtend(nqtendaa) = (/ 0, iqqcwtend_rnam, 0, 0 /) + + logical, parameter :: aging_include_seasalt = .false. + ! when .true., aging (by coagulation) includes contribution of seasalt + ! early versions of mam neglected the seasalt contribution + + ! species indices for various qgas_--- arrays + integer :: igas_soa, igas_h2so4, igas_nh3, igas_hno3, igas_hcl + ! species indices for various qaer_--- arrays + ! when nsoa > 1, igas_soa and iaer_soa are indices of the first soa species + ! when nbc > 1, iaer_bc is index of the first bc species + ! when npom > 1, iaer_pom is index of the first pom species + integer :: iaer_bc, iaer_dst, iaer_ncl, iaer_nh4, iaer_pom, iaer_soa, iaer_so4, & + iaer_mpoly, iaer_mprot, iaer_mlip, iaer_mhum, iaer_mproc, & + iaer_no3, iaer_cl, iaer_ca, iaer_co3 + integer :: i_agepair_pca, i_agepair_macc, i_agepair_mait + integer :: lmap_gas(max_gas) + integer :: lmap_aer(max_aer,max_mode), lmapbb_aer(max_aer,max_mode), & + lmap_aercw(max_aer,max_mode) + integer :: lmap_num(max_mode), lmap_numcw(max_mode) + integer :: lmapcc_all(gas_pcnst) + integer, parameter :: lmapcc_val_gas = 1, lmapcc_val_aer = 2, lmapcc_val_num = 3 + integer :: ngas, naer + integer :: nacc, nait, npca, nufi, nmacc, nmait + + integer :: n_agepair, n_coagpair + integer :: modefrm_agepair(max_agepair), modetoo_agepair(max_agepair) + integer :: mode_aging_optaa(max_mode) + integer :: modefrm_coagpair(max_coagpair), modetoo_coagpair(max_coagpair), & + modeend_coagpair(max_coagpair) + + integer :: lun82, lun97, lun98, lun13n, lun15n + logical :: ldiag82, ldiag97, ldiag98, ldiag13n, ldiag15n + logical :: ldiagd1 + + real(r8) :: accom_coef_gas(max_gas) + real(r8) :: alnsg_aer(max_mode) + real(r8) :: dgnum_aer(max_mode), dgnumhi_aer(max_mode), dgnumlo_aer(max_mode) + real(r8) :: dens_aer(max_aer) + real(r8) :: dens_so4a_host + real(r8) :: fac_m2v_aer(max_aer) ! converts (mol-aero/mol-air) to (m3-aero/mol-air) + real(r8) :: fac_eqvso4hyg_aer(max_aer) ! converts a species volume to a volume of so4 + ! (or nh4hso4) having same hygroscopicity + real(r8) :: fac_m2v_eqvhyg_aer(max_aer) ! = fac_m2v_aer * fac_eqvso4hyg_aer + + real(r8) :: fcvt_gas(max_gas), fcvt_aer(max_aer), fcvt_num, fcvt_wtr + real(r8) :: fcvt_dgnum_dvolmean(max_mode) + real(r8) :: hygro_aer(max_aer) + real(r8) :: mw_gas(max_gas), mw_aer(max_aer) + real(r8) :: mwhost_gas(max_gas), mwhost_aer(max_aer), mwhost_num + real(r8) :: mw_nh4a_host, mw_so4a_host + real(r8) :: mwuse_soa(nsoa), mwuse_poa(npoa) + real(r8) :: sigmag_aer(max_mode) + real(r8) :: vol_molar_gas(max_gas) + +! following were used in aging calcs but are no longer needed +! fac_m2v_so4, fac_m2v_nh4, fac_m2v_soa(:) +! fac_m2v_pcarbon(:) +! soa_equivso4_factor(:) + + + character(len=16) :: name_gas(max_gas), name_aerpfx(max_aer), & + name_aer(max_aer,max_mode), name_aercw(max_aer,max_mode), & + name_num(max_mode), name_numcw(max_mode) + + character(len=8) :: suffix_q_coltendaa(nqtendaa) = & + (/ '_sfgaex1', '_sfgaex2', '_sfnnuc1', '_sfcoag1' /) + character(len=8) :: suffix_qqcw_coltendaa(nqqcwtendaa) = & + '_sfgaex2' + + logical :: do_q_coltendaa(gas_pcnst,nqtendaa) = .false. + logical :: do_qqcw_coltendaa(gas_pcnst,nqqcwtendaa) = .false. + +! *** following 3 variables should eventually be in modal_aero_data + real(r8) :: specmw2_amode(ntot_aspectype,ntot_amode) + real(r8) :: specdens2_amode(ntot_aspectype,ntot_amode) + real(r8) :: spechygro2(ntot_aspectype,ntot_amode) + + +! !DESCRIPTION: This module implements ... +! +! !REVISION HISTORY: +! +! RCE 07.04.13: Adapted from MIRAGE2 code +! +!EOP +!---------------------------------------------------------------------- +!BOC + +! list private module data here + +!EOC +!---------------------------------------------------------------------- + + + contains + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- +subroutine modal_aero_amicphys_intr( & + mdo_gasaerexch, mdo_rename, & + mdo_newnuc, mdo_coag, & + lchnk, ncol, nstep, & + loffset, deltat, & + latndx, lonndx, & + t, pmid, pdel, & + zm, pblh, & + qv, cld, & + q, qqcw, & + q_pregaschem, & + q_precldchem, qqcw_precldchem, & +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + nqtendbb, nqqcwtendbb, & + q_tendbb, qqcw_tendbb, & +#endif + dgncur_a, dgncur_awet, & + wetdens_host, & + qaerwat ) + + +! !USES: +use cam_history, only: outfld, fieldname_len +use chem_mods, only: adv_mass +use constituents, only: cnst_name +use physconst, only: gravit, mwdry, r_universal +use wv_saturation, only: qsat +use phys_control, only: phys_getopts + +use modal_aero_data, only: & + cnst_name_cw, & + lmassptr_amode, lmassptrcw_amode, lptr2_soa_g_amode, & + nspec_amode, & + numptr_amode, numptrcw_amode +use modal_aero_newnuc, only: adjust_factor_pbl_ratenucl + + +implicit none + +! !PARAMETERS: + integer, intent(in) :: mdo_gasaerexch, mdo_rename, mdo_newnuc, mdo_coag + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns in the chunk + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: loffset ! offset applied to modal aero "ptrs" + integer, intent(in) :: latndx(pcols), lonndx(pcols) +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + integer, intent(in) :: nqtendbb ! dimension for q_tendbb + integer, intent(in) :: nqqcwtendbb ! dimension for qqcw_tendbb +#endif + + real(r8), intent(in) :: deltat ! time step (s) + + real(r8), intent(inout) :: q(ncol,pver,pcnstxx) ! current tracer mixing ratios (TMRs) + ! these values are updated (so out /= in) + ! *** MUST BE #/kmol-air for number + ! *** MUST BE mol/mol-air for mass + ! *** NOTE ncol dimension + real(r8), intent(inout) :: qqcw(ncol,pver,pcnstxx) + ! like q but for cloud-borner tracers + ! these values are updated + real(r8), intent(in) :: q_pregaschem(ncol,pver,pcnstxx) ! q TMRs before gas-phase chemistry + real(r8), intent(in) :: q_precldchem(ncol,pver,pcnstxx) ! q TMRs before cloud chemistry + real(r8), intent(in) :: qqcw_precldchem(ncol,pver,pcnstxx) ! qqcw TMRs before cloud chemistry +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + real(r8), intent(inout) :: q_tendbb(ncol,pver,pcnstxx,nqtendbb) ! TMR tendencies for box-model diagnostic output + real(r8), intent(inout) :: qqcw_tendbb(ncol,pver,pcnstxx,nqqcwtendbb) +#endif + + real(r8), intent(in) :: t(pcols,pver) ! temperature at model levels (K) + real(r8), intent(in) :: pmid(pcols,pver) ! pressure at model level centers (Pa) + real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness of levels (Pa) + real(r8), intent(in) :: zm(pcols,pver) ! altitude (above ground) at level centers (m) + real(r8), intent(in) :: pblh(pcols) ! planetary boundary layer depth (m) + real(r8), intent(in) :: qv(pcols,pver) ! specific humidity (kg/kg) + real(r8), intent(in) :: cld(ncol,pver) ! cloud fraction (-) *** NOTE ncol dimension + real(r8), intent(inout) :: dgncur_a(pcols,pver,ntot_amode) + real(r8), intent(inout) :: dgncur_awet(pcols,pver,ntot_amode) + ! dry & wet geo. mean dia. (m) of number distrib. + real(r8), intent(inout) :: wetdens_host(pcols,pver,ntot_amode) + ! interstitial aerosol wet density (kg/m3) + real(r8), intent(inout), optional :: & + qaerwat(pcols,pver,ntot_amode) + ! aerosol water mixing ratio (kg/kg, NOT mol/mol) + +! !DESCRIPTION: +! calculates changes to gas and aerosol TMRs (tracer mixing ratios) from +! gas-aerosol exchange (condensation/evaporation) +! growth from smaller to larger modes (renaming) due to both +! condensation and cloud chemistry +! new particle nucleation +! coagulation +! transfer of particles from hydrophobic modes to hydrophilic modes (aging) +! due to condensation and coagulation +! +! the incoming mixing ratios (q and qqcw) are updated before output +! +! !REVISION HISTORY: +! RCE 07.04.13: Adapted from earlier version of CAM5 modal aerosol routines +! for these processes +! +!EOP +!---------------------------------------------------------------------- +!BOC + +! local variables + integer, parameter :: ldiag1=-1, ldiag2=-1, ldiag3=-1, ldiag4=-1 + integer, parameter :: method_soa = 2 +! method_soa=0 is no uptake +! method_soa=1 is irreversible uptake done like h2so4 uptake +! method_soa=2 is reversible uptake using subr modal_aero_soaexch + + integer :: i, icol_diag, ipass, iq + integer :: itmpa, itmpb, itmpc, itmpd + integer :: iqtend, iqqcwtend + integer :: iaer, igas + integer :: j, jac, jsoa, jsub + integer :: jclea, jcldy + integer :: k + integer :: l, l2, l3, la, lb, lc, lmz, lsfrm, lstoo + integer :: lun, lund + integer :: m + integer :: n, niter, niter_max, ntot_soamode + integer :: nsubarea, ncldy_subarea + + logical :: do_cond, do_rename, do_newnuc, do_coag + logical :: iscldy_subarea(maxsubarea) + + character(len=fieldname_len+3) :: fieldname + character(len=6) :: tmpch6a, tmpch6c + character(len=200) :: tmp_str + + real (r8) :: pdel_fac + +!---------------------------------------------------------------------- + logical :: history_aerocom ! Output the aerocom history +!----------------------------------------------------------------------- + + + real(8), parameter :: fcld_locutoff = 1.0e-5_r8 +! cloud chemistry is only on when cld(i,k) >= 1.0e-5_r8 +! it may be that the macrophysics has a higher threshold that this + real(8), parameter :: fcld_hicutoff = 0.999_r8 + + real(r8) :: afracsub(maxsubarea) + real(r8) :: dgn_a(max_mode), dgn_awet(max_mode) + real(r8) :: ev_sat(pcols,pver) + real(r8) :: fclea, fcldy, fcldybb + real(r8) :: nufine_3dtend_nnuc(pcols,pver) + real(r8) :: ncluster_3dtend_nnuc(pcols,pver) + real(r8) :: qv_sat(pcols,pver) + real(r8) :: relhumgcm, relhumsub(maxsubarea) + real(r8) :: soag_3dtend_cond(pcols,pver,nsoa) + real(r8) :: tmpa, tmpb, tmpc + real(r8) :: tmp_qa_clea, tmp_qa_cldy, tmp_qa_gcav + real(r8) :: tmp_qc_cldy, tmp_qc_gcav + real(r8) :: tmp_aa, tmp_aa_clea, tmp_aa_cldy + real(r8) :: tmp_kxt, tmp_kxt2, tmp_pxt, tmp_pok + real(r8) :: tmp_q1, tmp_q2, tmp_q3, tmp_q4, tmp_q5, tmp_qdot4 + real(r8) :: wetdens(max_mode) + + +! qgcmN and qqcwgcmN (N=1:4) are grid-cell mean tracer mixing ratios (TMRs, mol/mol or #/kmol) +! N=1 - before gas-phase chemistry +! N=2 - before cloud chemistry +! N=3 - incoming values (before gas-aerosol exchange, newnuc, coag) +! N=4 - outgoing values (after gas-aerosol exchange, newnuc, coag) + real(r8), dimension( 1:gas_pcnst ) :: & + qgcm1, qgcm2, qgcm3, qgcm4, & + qqcwgcm1, qqcwgcm2, qqcwgcm3, qqcwgcm4 + real(r8), dimension( 1:gas_pcnst, 1:nqtendaa ) :: & + qgcm_tendaa + real(r8), dimension( 1:gas_pcnst, 1:nqqcwtendaa ) :: & + qqcwgcm_tendaa + real(r8), dimension( 1:ntot_amode_extd ) :: & + qaerwatgcm3, qaerwatgcm4 ! aerosol water mixing ratios (mol/mol) + +! qsubN and qqcwsubN (N=1:4) are TMRs in sub-areas +! currently there are just clear and cloudy sub-areas +! the N=1:4 have same meanings as for qgcmN + real(r8), dimension( 1:gas_pcnst, 1:maxsubarea ) :: & + qsub1, qsub2, qsub3, qsub4, & + qqcwsub1, qqcwsub2, qqcwsub3, qqcwsub4 + real(r8), dimension( 1:gas_pcnst, 1:nqtendaa, 1:maxsubarea ) :: & + qsub_tendaa + real(r8), dimension( 1:gas_pcnst, 1:nqqcwtendaa, 1:maxsubarea ) :: & + qqcwsub_tendaa + real(r8), dimension( 1:ntot_amode_extd, 1:maxsubarea ) :: & + qaerwatsub3, qaerwatsub4 ! aerosol water mixing ratios (mol/mol) + +! q_coltendaa and qqcw_coltendaa are column-integrated tendencies +! for different processes, which are output to history +! the processes are condensation/evaporation (and associated aging), +! renaming, coagulation, and nucleation + real(r8), dimension( 1:pcols, 1:gas_pcnst, 1:nqtendaa ) :: & + q_coltendaa + real(r8), dimension( 1:pcols, 1:gas_pcnst, 1:nqqcwtendaa ) :: & + qqcw_coltendaa + +#if ( defined( MOSAIC_SPECIES ) ) + real(r8) :: cnvrg_fail(pcols,pver) !BSINGH - For tracking MOSAIC convergence failures + real(r8) :: max_kelvin_iter(pcols,pver) !BSINGH - For tracking when max is hit for kelvin iterations + real(r8) :: xnerr_astem_negative(pcols,pver,5,4) +#endif + + type ( misc_vars_aa_type ) :: misc_vars_aa + + + + + adjust_factor_pbl_ratenucl = newnuc_adjust_factor_pbl + +#if ( defined CAM_VERSION_IS_ACME ) + history_aerocom = .false. +#else + call phys_getopts( history_aerocom_out = history_aerocom ) +#endif + + + icol_diag = -1 + if (ldiag1 > 0) then + if (nstep < 3) then + do i = 1, ncol +! if ((latndx(i) == 23) .and. (lonndx(i) == 37)) icol_diag = i + if ((latndx(i) == 47) .and. (lonndx(i) ==121)) icol_diag = i ! amazon + end do + end if + end if + + do_cond = ( mdo_gasaerexch > 0 ) + do_rename = ( mdo_rename > 0 ) + do_newnuc = ( mdo_newnuc > 0 ) + do_coag = ( mdo_coag > 0 ) + + q_coltendaa = 0.0_r8 ; qqcw_coltendaa = 0.0_r8 + nufine_3dtend_nnuc = 0.0_r8 + ncluster_3dtend_nnuc = 0.0_r8 + soag_3dtend_cond = 0.0_r8 + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) +! these variables otherwise undefined + q_tendbb = 0.0_r8 ; qqcw_tendbb = 0.0_r8 +#endif + +#if ( defined( MOSAIC_SPECIES ) ) + cnvrg_fail(1:pcols,1:pver) = 0.0_r8 + max_kelvin_iter(1:pcols,1:pver) = 0.0_r8 + xnerr_astem_negative(1:pcols,1:pver,1:5,1:4) = 0.0_r8 +#endif + +! turn off history selectively for comparison with dd06f + if ( (.not. do_cond) .and. (.not. do_rename) ) then + do_q_coltendaa(:,iqtend_cond) = .false. + do_q_coltendaa(:,iqtend_rnam) = .false. + do_qqcw_coltendaa(:,iqqcwtend_rnam) = .false. + end if + if ( .not. do_newnuc ) then + do_q_coltendaa(:,iqtend_nnuc) = .false. + end if + if ( .not. do_coag ) then + do_q_coltendaa(:,iqtend_coag) = .false. + end if + +! get saturation mixing ratio + call qsat( t(1:ncol,1:pver), pmid(1:ncol,1:pver), & + ev_sat(1:ncol,1:pver), qv_sat(1:ncol,1:pver) ) + +main_k_loop: & + do k = top_lev, pver +main_i_loop: & + do i = 1, ncol + + if ( ldiag13n ) lun13n = 129 + i + + +! +! determine the number of sub-areas, their fractional areas, and relative humidities +! +! if cloud fraction ~= 0, the grid-cell has a single clear sub-area (nsubarea = 1) +! if cloud fraction ~= 1, the grid-cell has a single cloudy sub-area (nsubarea = 1) +! otherwise, the grid-cell has a clear and a cloudy sub-area (nsubarea = 2) +! + if (cld(i,k) < fcld_locutoff) then +! note that cloud chemistry is only on when cld(i,k) >= 1.0e-5_r8 +! it may be that the macrophysics has a higher threshold that this + fcldy = 0.0_r8 + nsubarea = 1 ; ncldy_subarea = 0 + jclea = 1 ; jcldy = 0 + else if (cld(i,k) > fcld_hicutoff) then + fcldy = 1.0_r8 + nsubarea = 1 ; ncldy_subarea = 1 + jclea = 0 ; jcldy = 1 + else + fcldy = cld(i,k) + nsubarea = 2 ; ncldy_subarea = 1 + jclea = 1 ; jcldy = 2 + end if + fclea = 1.0_r8 - fcldy + fcldybb = max( cld(i,k), 1.0e-6_r8 ) + + iscldy_subarea(:) = .false. + if (jcldy > 0) iscldy_subarea(jcldy) = .true. + + afracsub(:) = 0.0_r8 + if (jclea > 0) afracsub(jclea) = fclea + if (jcldy > 0) afracsub(jcldy) = fcldy + + relhumgcm = max( 0.0_r8, min( 1.0_r8, qv(i,k)/qv_sat(i,k) ) ) + if (ncldy_subarea <= 0) then + relhumsub(:) = relhumgcm +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + else if (cldy_rh_sameas_clear > 0) then + relhumsub(:) = relhumgcm +#endif + else + relhumsub(jcldy) = 1.0_r8 + if (jclea > 0) then + tmpa = (relhumgcm - afracsub(jcldy))/afracsub(jclea) + relhumsub(jclea) = max( 0.0_r8, min( 1.0_r8, tmpa ) ) + end if + end if + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( ldiag13n ) then + write(lun13n,'(/a,3i5)') 'modal_aero_amicphys_intr mapping at nstep, i, k', nstep, i, k + write(lun13n,'(a,1p,5i12 )') 'jclea, jcldy, ncldy, nsubc', & + jclea, jcldy, ncldy_subarea, nsubarea + write(lun13n,'(a,1p,5e12.4)') 'cld, fcldy, fcldybb, fclea', & + cld(i,k), fcldy, fcldybb, fclea + write(lun13n,'(a,1p,5e12.4)') 'relhumav, relhumsub(1:2) ', & + relhumgcm, relhumsub(1:2) + end if +#endif + + + do lmz = 1, gas_pcnst + qgcm1(lmz) = max( 0.0_r8, q_pregaschem(i,k,lmz) ) + qgcm2(lmz) = max( 0.0_r8, q_precldchem(i,k,lmz) ) + qqcwgcm2(lmz) = max( 0.0_r8, qqcw_precldchem(i,k,lmz) ) + qgcm3(lmz) = max( 0.0_r8, q(i,k,lmz) ) + qqcwgcm3(lmz) = max( 0.0_r8, qqcw(i,k,lmz) ) + end do + qaerwatgcm3(:) = 0.0_r8 + if ( present( qaerwat ) ) then + qaerwatgcm3(1:ntot_amode) = max( 0.0_r8, qaerwat(i,k,1:ntot_amode) ) + end if + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + n = min( maxsubarea, nsubarea+1 ) +#else + n = nsubarea +#endif + qsub1(:,1:n) = 0.0_r8 + qsub2(:,1:n) = 0.0_r8 + qsub3(:,1:n) = 0.0_r8 + qsub4(:,1:n) = 0.0_r8 + qqcwsub1(:,1:n) = 0.0_r8 + qqcwsub2(:,1:n) = 0.0_r8 + qqcwsub3(:,1:n) = 0.0_r8 + qqcwsub4(:,1:n) = 0.0_r8 + qaerwatsub3(:,1:n) = 0.0_r8 + qaerwatsub4(:,1:n) = 0.0_r8 + +! +! calculate initial (i.e., before cond/rnam/nnuc/coag) tracer mixing ratios within the sub-areas +! for all-clear or all-cloudy cases, the sub-area TMRs are equal to the grid-cell means +! for partly cloudy case, they are different. This is primarily because the +! interstitial aerosol mixing ratios are assumed lower in the cloudy sub-area than in +! the clear sub-area, because much of the aerosol is activated in the cloudy sub-area. +! + if ( (jclea > 0) .and. (jcldy > 0) .and. & + (jclea+jcldy == 3) .and. (nsubarea == 2) ) then +! partly cloudy case + +! set gas mixing ratios in sub-areas (for the condensing gases only!!) + do lmz = 1, gas_pcnst + if (lmapcc_all(lmz) /= lmapcc_val_gas) cycle + + ! assume gas in both sub-areas before gas-chem and cloud-chem equal grid-cell mean + qsub1(lmz,1:nsubarea) = qgcm1(lmz) + qsub2(lmz,1:nsubarea) = qgcm2(lmz) + + ! assume gas in clear sub-area after cloud-chem equals before cloud-chem value + qsub3(lmz,jclea) = qsub2(lmz,jclea) + ! gas in cloud sub-area then determined by grid-cell mean and clear values + qsub3(lmz,jcldy) = (qgcm3(lmz) - fclea*qsub3(lmz,jclea))/fcldy + ! check that this does not produce a negative value + if (qsub3(lmz,jcldy) < 0.0_r8) then + qsub3(lmz,jcldy) = 0.0_r8 + qsub3(lmz,jclea) = qgcm3(lmz)/fclea + end if + end do + +! set aerosol mixing ratios in sub-areas + do n = 1, ntot_amode + + do l2 = 0, nspec_amode(n) + + if (l2 <= 1) then + ! calculcate partitioning factors + if (l2 == 0) then + la = numptr_amode(n) - loffset + lc = numptrcw_amode(n) - loffset + tmp_qa_gcav = qgcm2(la) + tmp_qc_gcav = qqcwgcm2(lc) + else + tmp_qa_gcav = 0.0_r8 + tmp_qc_gcav = 0.0_r8 + do l3 = 1, nspec_amode(n) + la = lmassptr_amode(l3,n) - loffset + tmp_qa_gcav = tmp_qa_gcav + qgcm2(la) + lc = lmassptrcw_amode(l3,n) - loffset + tmp_qc_gcav = tmp_qc_gcav + qqcwgcm2(lc) + end do + end if + + tmp_qc_cldy = tmp_qc_gcav/fcldy + tmp_qa_cldy = max( 0.0_r8, ((tmp_qa_gcav+tmp_qc_gcav) - tmp_qc_cldy) ) + tmp_qa_clea = (tmp_qa_gcav - fcldy*tmp_qa_cldy)/fclea + + ! *** question *** + ! use same tmp_aa_clea/cldy for everything ? + ! use one for number and one for all masses (based on total mass) ? + ! use separate ones for everything ? + ! maybe one for number and one for all masses is best, + ! because number and mass have different activation fractions + ! *** question *** + tmp_aa = max( 1.e-35_r8, tmp_qa_clea*fclea ) / max( 1.e-35_r8, tmp_qa_gcav ) + tmp_aa = max( 0.0_r8, min( 1.0_r8, tmp_aa ) ) + tmp_aa_clea = tmp_aa/fclea + tmp_aa_cldy = (1.0_r8-tmp_aa)/fcldy + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( n <= 2 .and. ldiag13n ) then + if (n==1 .and. l2==0) write(lun13n,'(a)') + write(lun13n,'(a,2i3, 1p,6e12.4)') 'n, l2, tmp_aa, tmp_aa_clea, tmp_aa_cldy', & + n, l2, tmp_aa, tmp_aa_clea, tmp_aa_cldy + tmpa = 1.0e-6_r8*mwhost_num/mwdry + if (l2 > 0) tmpa = 1.0e9_r8 + write(lun13n,'(a, 6x, 1p,6e12.4)') 'qct, qcy, qat, qay, qax, qtt ', & + tmpa*tmp_qc_gcav, tmpa*tmp_qc_cldy, tmpa*tmp_qa_gcav, & + tmpa*tmp_qa_cldy, tmpa*tmp_qa_clea, tmpa*(tmp_qc_gcav+tmp_qa_gcav) + end if +#endif + end if ! (l2 <= 1) + + if (l2 == 0) then + la = numptr_amode(n) - loffset + lc = numptrcw_amode(n) - loffset + else + la = lmassptr_amode(l2,n) - loffset + lc = lmassptrcw_amode(l2,n) - loffset + end if + + qsub2(la,jclea) = qgcm2(la)*tmp_aa_clea + qsub2(la,jcldy) = qgcm2(la)*tmp_aa_cldy + qqcwsub2(lc,jclea) = 0.0_r8 + qqcwsub2(lc,jcldy) = qqcwgcm2(lc)/fcldy + + qsub3(la,jclea) = qgcm3(la)*tmp_aa_clea + qsub3(la,jcldy) = qgcm3(la)*tmp_aa_cldy + qqcwsub3(lc,jclea) = 0.0_r8 + qqcwsub3(lc,jcldy) = qqcwgcm3(lc)/fcldy + + end do ! l2 + end do ! n + + else if ((jclea == 1) .and. (jcldy == 0) .and. (nsubarea == 1)) then +! all clear, or cld < 1e-5 +! in this case, fclea=1 and fcldy=0 +! +! put all the gases and interstitial aerosols in the clear sub-area +! and set mix-ratios = 0 in cloudy sub-area +! for cloud-borne aerosol, do nothing +! because the grid-cell-mean cloud-borne aerosol will be left unchanged +! (i.e., this routine only changes qqcw when cld >= 1e-5) +! + do lmz = 1, gas_pcnst + if (lmapcc_all(lmz) <= 0) cycle + qsub1(lmz,jclea) = qgcm1(lmz) + qsub2(lmz,jclea) = qgcm2(lmz) + qsub3(lmz,jclea) = qgcm3(lmz) + qqcwsub2(lmz,jclea) = qqcwgcm2(lmz) + qqcwsub3(lmz,jclea) = qqcwgcm3(lmz) + end do + + else if ((jclea == 0) .and. (jcldy == 1) .and. (nsubarea == 1)) then +! all cloudy, or cld > 0.999 +! in this case, fcldy= and fclea=0 +! +! put all the gases and interstitial aerosols in the cloudy sub-area +! and set mix-ratios = 0 in clear sub-area +! + do lmz = 1, gas_pcnst + if (lmapcc_all(lmz) <= 0) cycle + qsub1(lmz,jcldy) = qgcm1(lmz) + qsub2(lmz,jcldy) = qgcm2(lmz) + qsub3(lmz,jcldy) = qgcm3(lmz) + qqcwsub2(lmz,jcldy) = qqcwgcm2(lmz) + qqcwsub3(lmz,jcldy) = qqcwgcm3(lmz) + end do + + else +! this should not happen + write(tmp_str,'(a,3(1x,i10))') & + '*** modal_aero_amicphys - bad jclea, jcldy, nsubarea', & + jclea, jcldy, nsubarea + call endrun( tmp_str ) + end if + +! aerosol water -- how to treat this in sub-areas needs more work/thinking +! currently modal_aero_water_uptake calculates qaerwat using +! the grid-cell mean interstital-aerosol mix-rats and the clear-area rh + do jsub = 1, nsubarea + qaerwatsub3(:,jsub) = qaerwatgcm3(:) + end do + + if (nsubarea == 1) then +! the j=2 subarea is used for some diagnostics +! but is not used in actual calculations + j = 2 + qsub1(:,j) = 0.0_r8 + qsub2(:,j) = 0.0_r8 + qsub3(:,j) = 0.0_r8 + qqcwsub2(:,j) = 0.0_r8 + qqcwsub3(:,j) = 0.0_r8 + end if + + +! diagnostics after forming sub-areas +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( ldiag13n ) then + do l2 = 1, 4 + if (l2 == 1) then + igas = igas_h2so4 + else if (l2 == 3) then + igas = igas_nh3 + if (igas <= 0) cycle + else if (l2 == 4) then + igas = -3 + else + igas = 1 + end if + if (igas > 0) then + l = lmap_gas(igas) + tmpch6a = name_gas(igas) + else + l = -igas + tmpch6a = cnst_name(l+loffset) + end if + tmpa = 1.0e9 + write(lun13n,'(a)') + write(lun13n,'(2a,1p,4e12.4)') tmpch6a, ' host 1-3', & + q_pregaschem(i,k,l)*tmpa, q_precldchem(i,k,l)*tmpa, q(i,k,l)*tmpa + write(lun13n,'(2a,1p,4e12.4)') tmpch6a, ' gm 1-3', & + qgcm1(l)*tmpa, qgcm2(l)*tmpa, qgcm3(l)*tmpa + j = jclea ; if (j <= 0) j = nsubarea+1 + write(lun13n,'(2a,1p,4e12.4)') tmpch6a, ' clear 1-3', & + qsub1(l,j)*tmpa, qsub2(l,j)*tmpa, qsub3(l,j)*tmpa + j = jcldy ; if (j <= 0) j = nsubarea+1 + write(lun13n,'(2a,1p,4e12.4)') tmpch6a, ' cloud 1-3', & + qsub1(l,j)*tmpa, qsub2(l,j)*tmpa, qsub3(l,j)*tmpa + end do ! l2 + + n = 1 + do l2 = 1, 3 + if (l2 == 1) then + tmpa = 1.0e-6_r8/28.966_r8 + la = lmap_num(n) + lc = lmap_numcw(n) + tmpch6a = name_num(n) + tmpch6c = name_numcw(n) + else + if (l2 == 2) then + iaer = iaer_so4 + else + iaer = iaer_soa + end if + tmpa = 1.0e9_r8 + la = lmap_aer(iaer,n) + lc = lmap_aercw(iaer,n) + tmpch6a = name_aer(iaer,n) + tmpch6c = name_aercw(iaer,n) + end if + write(lun13n,'(a)') + write(lun13n,'(4a,1p,2(2x,2e12.4))') tmpch6a, ' host 2-3; ', tmpch6c, ' ...', & + q_precldchem(i,k,la)*tmpa, q(i,k,la)*tmpa, & + qqcw_precldchem(i,k,lc)*tmpa, qqcw(i,k,lc)*tmpa + write(lun13n,'(4a,1p,2(2x,2e12.4))') tmpch6a, ' gm 2-3; ', tmpch6c, ' ...', & + qgcm2(la)*tmpa, qgcm3(la)*tmpa, & + qqcwgcm2(lc)*tmpa, qqcwgcm3(lc)*tmpa + j = jclea ; if (j <= 0) j = nsubarea+1 + write(lun13n,'(4a,1p,2(2x,2e12.4))') tmpch6a, ' clear 2-3; ', tmpch6c, ' ...', & + qsub2(la,j)*tmpa, qsub3(la,j)*tmpa, & + qqcwsub2(lc,j)*tmpa, qqcwsub3(lc,j)*tmpa + j = jcldy ; if (j <= 0) j = nsubarea+1 + write(lun13n,'(4a,1p,2(2x,2e12.4))') tmpch6a, ' cloud 2-3; ', tmpch6c, ' ...', & + qsub2(la,j)*tmpa, qsub3(la,j)*tmpa, & + qqcwsub2(lc,j)*tmpa, qqcwsub3(lc,j)*tmpa + end do ! l2 + end if ! ( ldiag13n ) +#endif + +! +! start integration +! + do n = 1, max_mode + if (n <= ntot_amode) then + dgn_a(n) = dgncur_a(i,k,n) + dgn_awet(n) = dgncur_awet(i,k,n) + wetdens(n) = max( 1000.0_r8, wetdens_host(i,k,n) ) + else + dgn_a(n) = 0.0_r8 + dgn_awet(n) = 0.0_r8 + wetdens(n) = 1000.0_r8 + end if + end do + + misc_vars_aa%ncluster_tend_nnuc_1grid = ncluster_3dtend_nnuc(i,k) +#if ( defined ( MOSAIC_SPECIES ) ) + misc_vars_aa%cnvrg_fail_1grid = cnvrg_fail(i,k) + misc_vars_aa%max_kelvin_iter_1grid = max_kelvin_iter(i,k) + misc_vars_aa%xnerr_astem_negative_1grid(1:5,1:4) = xnerr_astem_negative(pcols,pver,1:5,1:4) +#endif + + + lund = iulog ! for cambox, iulog=93 at this point + +! ubroutine mam_amicphys_1gridcell( & +! do_cond, do_rename, & +! do_newnuc, do_coag, & +! nstep, lchnk, i, k, & +! latndx, lonndx, lund, & +! loffset, deltat, & +! nsubarea, ncldy_subarea, & +! iscldy_subarea, afracsub, & +! temp, pmid, pdel, & +! zmid, pblh, relhumsub, & +! dgn_a, dgn_awet, wetdens, & +! qsub1, & +! qsub2, qqcwsub2, & +! qsub3, qqcwsub3, & +! qsub4, qqcwsub4, & +! qsub_tendaa, qqcwsub_tendaa ) + + call mam_amicphys_1gridcell( & + do_cond, do_rename, & + do_newnuc, do_coag, & + nstep, lchnk, i, k, & + latndx(i), lonndx(i), lund, & + loffset, deltat, & + nsubarea, ncldy_subarea, & + iscldy_subarea, afracsub, & + t(i,k), pmid(i,k), pdel(i,k), & + zm(i,k), pblh(i), relhumsub, & + dgn_a, dgn_awet, wetdens, & + qsub1, & + qsub2, qqcwsub2, & + qsub3, qqcwsub3, qaerwatsub3, & + qsub4, qqcwsub4, qaerwatsub4, & + qsub_tendaa, qqcwsub_tendaa, & + misc_vars_aa ) + + +! +! form new grid-mean mix-ratios +! + if (nsubarea == 1) then + qgcm4(:) = qsub4(:,1) + qgcm_tendaa(:,:) = qsub_tendaa(:,:,1) + qaerwatgcm4(1:ntot_amode) = qaerwatsub4(1:ntot_amode,1) + else + qgcm4(:) = 0.0_r8 + qgcm_tendaa(:,:) = 0.0_r8 + do j = 1, nsubarea + qgcm4(:) = qgcm4(:) + qsub4(:,j)*afracsub(j) + qgcm_tendaa(:,:) = qgcm_tendaa(:,:) + qsub_tendaa(:,:,j)*afracsub(j) + end do + ! for aerosol water use the clear sub-area value + qaerwatgcm4(1:ntot_amode) = qaerwatsub4(1:ntot_amode,jclea) + end if + + if (ncldy_subarea <= 0) then + qqcwgcm4(:) = qqcwgcm3(:) + qqcwgcm_tendaa(:,:) = 0.0_r8 + else if (nsubarea == 1) then + qqcwgcm4(:) = qqcwsub4(:,1) + qqcwgcm_tendaa(:,:) = qqcwsub_tendaa(:,:,1) + else + qqcwgcm4(:) = 0.0_r8 + qqcwgcm_tendaa(:,:) = 0.0_r8 + do j = 1, nsubarea + if ( .not. iscldy_subarea(j) ) cycle + qqcwgcm4(:) = qqcwgcm4(:) + qqcwsub4(:,j)*afracsub(j) + qqcwgcm_tendaa(:,:) = qqcwgcm_tendaa(:,:) + qqcwsub_tendaa(:,:,j)*afracsub(j) + end do + end if + + do lmz = 1, gas_pcnst + if (lmapcc_all(lmz) > 0) then + q(i,k,lmz) = qgcm4(lmz) + if (lmapcc_all(lmz) >= lmapcc_val_aer) then + qqcw(i,k,lmz) = qqcwgcm4(lmz) + end if + end if + end do + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if (iqtend_cond <= nqtendbb) q_tendbb(i,k,:,iqtend_cond) = qgcm_tendaa(:,iqtend_cond) + if (iqtend_rnam <= nqtendbb) q_tendbb(i,k,:,iqtend_rnam) = qgcm_tendaa(:,iqtend_rnam) + if (iqtend_nnuc <= nqtendbb) q_tendbb(i,k,:,iqtend_nnuc) = qgcm_tendaa(:,iqtend_nnuc) + if (iqtend_coag <= nqtendbb) q_tendbb(i,k,:,iqtend_coag) = qgcm_tendaa(:,iqtend_coag) + if (iqqcwtend_rnam <= nqqcwtendbb) qqcw_tendbb(i,k,:,iqqcwtend_rnam) = qqcwgcm_tendaa(:,iqqcwtend_rnam) +#endif + if ( update_qaerwat > 0 .and. present( qaerwat ) ) then + qaerwat(i,k,1:ntot_amode) = qaerwatgcm4(1:ntot_amode) + end if + + +! diagnostics after forming sub-areas +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( ldiag13n ) then + do l2 = 1, 4 + if (l2 == 1) then + igas = igas_h2so4 + else if (l2 == 3) then + igas = igas_nh3 + if (igas <= 0) cycle + else if (l2 == 4) then + igas = -3 + else + igas = 1 + end if + if (igas > 0) then + l = lmap_gas(igas) + tmpch6a = name_gas(igas) + else + l = -igas + tmpch6a = cnst_name(l+loffset) + end if + tmpa = 1.0e9 + write(lun13n,'(a)') + write(lun13n,'(2a,1p,4e12.4)') tmpch6a, ' host 1-4', & + q_pregaschem(i,k,l)*tmpa, q_precldchem(i,k,l)*tmpa, 0.0, q(i,k,l)*tmpa + write(lun13n,'(2a,1p,4e12.4)') tmpch6a, ' gm 1-4', & + qgcm1(l)*tmpa, qgcm2(l)*tmpa, qgcm3(l)*tmpa, qgcm4(l)*tmpa + j = jclea ; if (j <= 0) j = nsubarea+1 + write(lun13n,'(2a,1p,4e12.4)') tmpch6a, ' clear 1-4', & + qsub1(l,j)*tmpa, qsub2(l,j)*tmpa, qsub3(l,j)*tmpa, qsub4(l,j)*tmpa + j = jcldy ; if (j <= 0) j = nsubarea+1 + write(lun13n,'(2a,1p,4e12.4)') tmpch6a, ' cloud 1-4', & + qsub1(l,j)*tmpa, qsub2(l,j)*tmpa, qsub3(l,j)*tmpa, qsub4(l,j)*tmpa + end do ! l2 + end if ! ( ldiag13n ) +#endif + + +! increment column tendencies + pdel_fac = pdel(i,k)/gravit + do iqtend = 1, nqtendaa + do l = 1, gas_pcnst + if ( do_q_coltendaa(l,iqtend) ) then + q_coltendaa(i,l,iqtend) = q_coltendaa(i,l,iqtend) + qgcm_tendaa(l,iqtend)*pdel_fac + end if + if (iqtend <= nqqcwtendaa) then + if ( do_qqcw_coltendaa(l,iqtend) ) then + qqcw_coltendaa(i,l,iqtend) = qqcw_coltendaa(i,l,iqtend) + qqcwgcm_tendaa(l,iqtend)*pdel_fac + end if + end if + end do ! l + end do ! iqtend + + if ( history_aerocom ) then + ! 3d soa tendency for aerocom + ! note that flux units (kg/m2/s) are used here instead of tendency units (kg/kg/s or kg/m3/s) + do jsoa = 1, nsoa + l = lptr2_soa_g_amode(jsoa) - loffset + soag_3dtend_cond(i,k,jsoa) = qgcm_tendaa(l,iqtend_cond)*(adv_mass(l)/mwdry)*(pdel(i,k)/gravit) + end do + ! 3d number nucleation tendency for aerocom - units are (#/m3/s) + ! so multiply qgcm_tendaa (#/kmol/s) by air molar density (kmol/m3) + l = numptr_amode(nait) - loffset + nufine_3dtend_nnuc(i,k) = qgcm_tendaa(l,iqtend_nnuc) * (pmid(i,k)/(r_universal*t(i,k))) + end if + + + ncluster_3dtend_nnuc(i,k) = misc_vars_aa%ncluster_tend_nnuc_1grid +#if ( defined ( MOSAIC_SPECIES ) ) + cnvrg_fail(i,k) = misc_vars_aa%cnvrg_fail_1grid + max_kelvin_iter(i,k) = misc_vars_aa%max_kelvin_iter_1grid + xnerr_astem_negative(pcols,pver,1:5,1:4) = misc_vars_aa%xnerr_astem_negative_1grid(1:5,1:4) +#endif + + end do main_i_loop + + end do main_k_loop + + +! output column tendencies to history +! the ordering here is to allow comparison of fort.90 files from box model testing +! but is not important for regular cam simulations + do ipass = 1, 3 + + if (ipass == 1) then + itmpa = iqtend_cond ; itmpb = iqtend_rnam + itmpc = iqqcwtend_rnam ; itmpd = iqqcwtend_rnam + else if (ipass == 2) then + itmpa = iqtend_nnuc ; itmpb = iqtend_nnuc + itmpc = 0 ; itmpd = 0 + else + itmpa = iqtend_coag ; itmpb = iqtend_coag + itmpc = 0 ; itmpd = 0 + end if + + do l = 1, gas_pcnst + do iqtend = itmpa, itmpb + if (iqtend <= 0) cycle + if ( do_q_coltendaa(l,iqtend) ) then + q_coltendaa(1:ncol,l,iqtend) = q_coltendaa(1:ncol,l,iqtend)*(adv_mass(l)/mwdry) + fieldname = trim(cnst_name(l+loffset)) // suffix_q_coltendaa(iqtend) + call outfld( fieldname, q_coltendaa(1:ncol,l,iqtend), ncol, lchnk ) + end if + end do ! iqtend + do iqqcwtend = itmpc, itmpd + if (iqqcwtend <= 0) cycle + if ( do_qqcw_coltendaa(l,iqqcwtend) ) then + qqcw_coltendaa(1:ncol,l,iqqcwtend) = qqcw_coltendaa(1:ncol,l,iqqcwtend)* (adv_mass(l)/mwdry) + fieldname = trim(cnst_name_cw(l+loffset)) // suffix_qqcw_coltendaa(iqqcwtend) + call outfld( fieldname, qqcw_coltendaa(1:ncol,l,iqqcwtend), ncol, lchnk ) + end if + end do ! iqqcwtend + end do ! l + + if ( ipass==1 .and. history_aerocom ) then + do jsoa = 1, nsoa + l = lptr2_soa_g_amode(jsoa) + fieldname = trim(cnst_name(l)) // '_sfgaex3d' + call outfld( fieldname, soag_3dtend_cond(1:ncol,:,jsoa), ncol, lchnk ) + end do + l = numptr_amode(nait) + fieldname = trim(cnst_name(l)) // '_nuc1' + call outfld( fieldname, nufine_3dtend_nnuc(1:ncol,:), ncol, lchnk ) + fieldname = trim(cnst_name(l)) // '_nuc2' + call outfld( fieldname, ncluster_3dtend_nnuc(1:ncol,:), ncol, lchnk ) + end if + + end do ! ipass + +#if ( defined( MOSAIC_SPECIES ) ) + if ( mosaic ) then + !BSINGH - output MOSAIC convergence fail tracking: + call outfld( 'convergence_fail', cnvrg_fail(1:ncol,:), ncol, lchnk ) + call outfld( 'max_kelvin_iter' , max_kelvin_iter(1:ncol,:), ncol, lchnk ) + + do n = 1, 4 + do m = 1, 5 + fieldname = ' ' + write( fieldname(1:16), '(a,i1,a,i1)') 'astem_negval_', m, '_', n + call outfld( fieldname, xnerr_astem_negative(1:ncol,1:pver,m,n), ncol, lchnk ) + end do + end do + end if +#endif + + return +!EOC + end subroutine modal_aero_amicphys_intr + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + subroutine mam_amicphys_1gridcell( & + do_cond, do_rename, & + do_newnuc, do_coag, & + nstep, lchnk, i, k, & + latndx, lonndx, lund, & + loffset, deltat, & + nsubarea, ncldy_subarea, & + iscldy_subarea, afracsub, & + temp, pmid, pdel, & + zmid, pblh, relhumsub, & + dgn_a, dgn_awet, wetdens, & + qsub1, & + qsub2, qqcwsub2, & + qsub3, qqcwsub3, qaerwatsub3, & + qsub4, qqcwsub4, qaerwatsub4, & + qsub_tendaa, qqcwsub_tendaa, & + misc_vars_aa ) +! +! calculates changes to gas and aerosol sub-area TMRs (tracer mixing ratios) +! for the current grid cell (with indices = lchnk,i,k) +! qsub3 and qqcwsub3 are the incoming current TMRs +! qsub4 and qqcwsub4 are the outgoing updated TMRs +! + logical, intent(in) :: do_cond, do_rename, do_newnuc, do_coag + logical, intent(in) :: iscldy_subarea(maxsubarea) + + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: i, k ! column and level indices + integer, intent(in) :: latndx, lonndx ! lat and lon indices + integer, intent(in) :: lund ! logical unit for diagnostic output + integer, intent(in) :: loffset + integer, intent(in) :: nsubarea, ncldy_subarea + + real(r8), intent(in) :: deltat ! time step (s) + real(r8), intent(in) :: afracsub(maxsubarea) ! sub-area fractional area (0-1) + + real(r8), intent(in) :: temp ! temperature at model levels (K) + real(r8), intent(in) :: pmid ! pressure at layer center (Pa) + real(r8), intent(in) :: pdel ! pressure thickness of layer (Pa) + real(r8), intent(in) :: zmid ! altitude (above ground) at layer center (m) + real(r8), intent(in) :: pblh ! planetary boundary layer depth (m) + real(r8), intent(in) :: relhumsub(maxsubarea) ! sub-area relative humidity (0-1) + real(r8), intent(inout) :: dgn_a(max_mode) + real(r8), intent(inout) :: dgn_awet(max_mode) + ! dry & wet geo. mean dia. (m) of number distrib. + real(r8), intent(inout) :: wetdens(max_mode) + ! interstitial aerosol wet density (kg/m3) + ! dry & wet geo. mean dia. (m) of number distrib. + +! qsubN and qqcwsubN (N=1:4) are tracer mixing ratios (TMRs, mol/mol or #/kmol) in sub-areas +! currently there are just clear and cloudy sub-areas +! the N=1:4 have same meanings as for qgcmN +! N=1 - before gas-phase chemistry +! N=2 - before cloud chemistry +! N=3 - incoming values (before gas-aerosol exchange, newnuc, coag) +! N=4 - outgoing values (after gas-aerosol exchange, newnuc, coag) + real(r8), intent(in ), dimension( 1:gas_pcnst, 1:maxsubarea ) :: & + qsub1, qsub2, qsub3, qqcwsub2, qqcwsub3 + real(r8), intent(inout), dimension( 1:gas_pcnst, 1:maxsubarea ) :: & + qsub4, qqcwsub4 + real(r8), intent(inout), dimension( 1:ntot_amode_extd, 1:maxsubarea ) :: & + qaerwatsub3, qaerwatsub4 ! aerosol water mixing ratios (mol/mol) +! qsub_tendaa and qqcwsub_tendaa are TMR tendencies +! for different processes, which are used to produce history output +! the processes are condensation/evaporation (and associated aging), +! renaming, coagulation, and nucleation + real(r8), intent(inout), dimension( 1:gas_pcnst, 1:nqtendaa, 1:maxsubarea ) :: & + qsub_tendaa + real(r8), intent(inout), dimension( 1:gas_pcnst, 1:nqqcwtendaa, 1:maxsubarea ) :: & + qqcwsub_tendaa + type ( misc_vars_aa_type ), intent(inout) :: misc_vars_aa + +! local + integer :: iaer, igas + integer :: jsub + integer :: l + integer :: n + logical :: do_cond_sub, do_rename_sub, do_newnuc_sub, do_coag_sub + logical :: do_map_gas_sub + + real(r8), dimension( 1:max_gas ) :: & + qgas1, qgas2, qgas3, qgas4 + real(r8), dimension( 1:max_mode ) :: & + qnum2, qnum3, qnum4, & + qnumcw2, qnumcw3, qnumcw4 + real(r8), dimension( 1:max_aer, 1:max_mode ) :: & + qaer2, qaer3, qaer4, & + qaercw2, qaercw3, qaercw4 + real(r8), dimension( 1:max_mode ) :: & + qwtr3, qwtr4 + + real(r8), dimension( 1:max_gas, 1:nqtendaa ) :: & + qgas_delaa + real(r8), dimension( 1:max_mode, 1:nqtendaa ) :: & + qnum_delaa + real(r8), dimension( 1:max_mode, 1:nqqcwtendaa ) :: & + qnumcw_delaa + real(r8), dimension( 1:max_aer, 1:max_mode, 1:nqtendaa ) :: & + qaer_delaa + real(r8), dimension( 1:max_aer, 1:max_mode, 1:nqqcwtendaa ) :: & + qaercw_delaa + + real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpn + + type ( misc_vars_aa_type ), dimension(nsubarea) :: misc_vars_aa_sub + + +! the q--4 values will be equal to q--3 values unless they get changed + qsub4(:,1:nsubarea) = qsub3(:,1:nsubarea) + qqcwsub4(:,1:nsubarea) = qqcwsub3(:,1:nsubarea) + qaerwatsub4(:,1:nsubarea) = qaerwatsub3(:,1:nsubarea) + + qsub_tendaa(:,:,1:nsubarea) = 0.0_r8 + qqcwsub_tendaa(:,:,1:nsubarea) = 0.0_r8 + + do jsub = 1, nsubarea + misc_vars_aa_sub(jsub) = misc_vars_aa + end do + + +main_jsub_loop: & + do jsub = 1, nsubarea + + if ( iscldy_subarea(jsub) .eqv. .true. ) then + do_cond_sub = do_cond + do_rename_sub = do_rename + do_newnuc_sub = .false. + do_coag_sub = .false. + if (mdo_gaexch_cldy_subarea <= 0) do_cond_sub = .false. + else + do_cond_sub = do_cond + do_rename_sub = do_rename + do_newnuc_sub = do_newnuc + do_coag_sub = do_coag + end if + do_map_gas_sub = do_cond_sub .or. do_newnuc_sub + + +! map incoming sub-area mix-ratios to gas/aer/num arrays + + qgas1(:) = 0.0_r8 + qgas2(:) = 0.0_r8 + qgas3(:) = 0.0_r8 + qgas4(:) = 0.0_r8 + if ( do_map_gas_sub .eqv. .true. ) then +! for cldy subarea, only do gases if doing gaexch + do igas = 1, ngas + l = lmap_gas(igas) + qgas1(igas) = qsub1(l,jsub)*fcvt_gas(igas) + qgas2(igas) = qsub2(l,jsub)*fcvt_gas(igas) + qgas3(igas) = qsub3(l,jsub)*fcvt_gas(igas) + qgas4(igas) = qgas3(igas) + end do + end if + + qaer2(:,:) = 0.0_r8 + qnum2(:) = 0.0_r8 + qaer3(:,:) = 0.0_r8 + qnum3(:) = 0.0_r8 + qaer4(:,:) = 0.0_r8 + qnum4(:) = 0.0_r8 + qwtr3(:) = 0.0_r8 + qwtr4(:) = 0.0_r8 + do n = 1, ntot_amode + l = lmap_num(n) + qnum2(n) = qsub2(l,jsub)*fcvt_num + qnum3(n) = qsub3(l,jsub)*fcvt_num + qnum4(n) = qnum3(n) + do iaer = 1, naer + l = lmap_aer(iaer,n) + if (l > 0) then + qaer2(iaer,n) = qsub2(l,jsub)*fcvt_aer(iaer) + qaer3(iaer,n) = qsub3(l,jsub)*fcvt_aer(iaer) + qaer4(iaer,n) = qaer3(iaer,n) + end if + end do + qwtr3(n) = qaerwatsub3(n,jsub)*fcvt_wtr + qwtr4(n) = qwtr3(n) + end do ! n + + if ( iscldy_subarea(jsub) .eqv. .true. ) then +! only do cloud-borne for cloudy + qaercw2(:,:) = 0.0_r8 + qnumcw2(:) = 0.0_r8 + qaercw3(:,:) = 0.0_r8 + qnumcw3(:) = 0.0_r8 + qaercw4(:,:) = 0.0_r8 + qnumcw4(:) = 0.0_r8 + do n = 1, ntot_amode + l = lmap_numcw(n) + qnumcw2(n) = qqcwsub2(l,jsub)*fcvt_num + qnumcw3(n) = qqcwsub3(l,jsub)*fcvt_num + qnumcw4(n) = qnumcw3(n) + do iaer = 1, naer + l = lmap_aercw(iaer,n) + if (l > 0) then + qaercw2(iaer,n) = qqcwsub2(l,jsub)*fcvt_aer(iaer) + qaercw3(iaer,n) = qqcwsub3(l,jsub)*fcvt_aer(iaer) + qaercw4(iaer,n) = qaercw3(iaer,n) + end if + end do + end do ! n + end if + + + if ( iscldy_subarea(jsub) .eqv. .true. ) then + + call mam_amicphys_1subarea_cloudy( & + do_cond_sub, do_rename_sub, & + do_newnuc_sub, do_coag_sub, & + nstep, lchnk, i, k, & + latndx, lonndx, lund, & + loffset, deltat, & + jsub, nsubarea, & + iscldy_subarea(jsub), afracsub(jsub), & + temp, pmid, pdel, & + zmid, pblh, relhumsub(jsub), & + dgn_a, dgn_awet, wetdens, & + qgas1, qgas3, qgas4, & + qgas_delaa, & + qnum3, qnum4, & + qnum_delaa, & + qaer2, qaer3, qaer4, & + qaer_delaa, & + qwtr3, qwtr4, & + qnumcw3, qnumcw4, & + qnumcw_delaa, & + qaercw2, qaercw3, qaercw4, & + qaercw_delaa, & + misc_vars_aa_sub(jsub) ) + + else + + call mam_amicphys_1subarea_clear( & + do_cond_sub, do_rename_sub, & + do_newnuc_sub, do_coag_sub, & + nstep, lchnk, i, k, & + latndx, lonndx, lund, & + loffset, deltat, & + jsub, nsubarea, & + iscldy_subarea(jsub), afracsub(jsub), & + temp, pmid, pdel, & + zmid, pblh, relhumsub(jsub), & + dgn_a, dgn_awet, wetdens, & + qgas1, qgas3, qgas4, & + qgas_delaa, & + qnum3, qnum4, qnum_delaa, & + qaer3, qaer4, qaer_delaa, & + qwtr3, qwtr4, & + misc_vars_aa_sub(jsub) ) + + end if + + if ((nsubarea == 1) .or. (iscldy_subarea(jsub) .eqv. .false.)) then + misc_vars_aa%ncluster_tend_nnuc_1grid = misc_vars_aa%ncluster_tend_nnuc_1grid & + + misc_vars_aa_sub(jsub)%ncluster_tend_nnuc_1grid*afracsub(jsub) +#if ( defined ( MOSAIC_SPECIES ) ) + misc_vars_aa%cnvrg_fail_1grid = misc_vars_aa_sub(jsub)%cnvrg_fail_1grid + misc_vars_aa%max_kelvin_iter_1grid = misc_vars_aa_sub(jsub)%max_kelvin_iter_1grid + misc_vars_aa%xnerr_astem_negative_1grid(1:5,1:4) = misc_vars_aa_sub(jsub)%xnerr_astem_negative_1grid(1:5,1:4) +#endif + end if + + + +! map gas/aer/num arrays (mix-ratio and del=change) back to sub-area arrays + + if ( do_map_gas_sub .eqv. .true. ) then + do igas = 1, ngas + l = lmap_gas(igas) + qsub4(l,jsub) = qgas4(igas)/fcvt_gas(igas) + qsub_tendaa(l,:,jsub) = qgas_delaa(igas,:)/(fcvt_gas(igas)*deltat) + end do + end if + + do n = 1, ntot_amode + l = lmap_num(n) + qsub4(l,jsub) = qnum4(n)/fcvt_num + qsub_tendaa(l,:,jsub) = qnum_delaa(n,:)/(fcvt_num*deltat) + do iaer = 1, naer + l = lmap_aer(iaer,n) + if (l > 0) then + qsub4(l,jsub) = qaer4(iaer,n)/fcvt_aer(iaer) + qsub_tendaa(l,:,jsub) = qaer_delaa(iaer,n,:)/(fcvt_aer(iaer)*deltat) + end if + end do + qaerwatsub4(n,jsub) = qwtr4(n)/fcvt_wtr + + if ( iscldy_subarea(jsub) ) then + l = lmap_numcw(n) + qqcwsub4(l,jsub) = qnumcw4(n)/fcvt_num + qqcwsub_tendaa(l,:,jsub) = qnumcw_delaa(n,:)/(fcvt_num*deltat) + do iaer = 1, naer + l = lmap_aercw(iaer,n) + if (l > 0) then + qqcwsub4(l,jsub) = qaercw4(iaer,n)/fcvt_aer(iaer) + qqcwsub_tendaa(l,:,jsub) = qaercw_delaa(iaer,n,:)/(fcvt_aer(iaer)*deltat) + end if + end do + end if + end do ! n + + + end do main_jsub_loop + + + + return + end subroutine mam_amicphys_1gridcell + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + subroutine mam_amicphys_1subarea_cloudy( & + do_cond, do_rename, & + do_newnuc, do_coag, & + nstep, lchnk, i, k, & + latndx, lonndx, lund, & + loffset, deltat, & + jsub, nsubarea, & + iscldy_subarea, afracsub, & + temp, pmid, pdel, & + zmid, pblh, relhum, & + dgn_a, dgn_awet, wetdens, & + qgas1, qgas3, qgas4, & + qgas_delaa, & + qnum3, qnum4, & + qnum_delaa, & + qaer2, qaer3, qaer4, & + qaer_delaa, & + qwtr3, qwtr4, & + qnumcw3, qnumcw4, & + qnumcw_delaa, & + qaercw2, qaercw3, qaercw4, & + qaercw_delaa, & + misc_vars_aa_sub ) +! +! calculates changes to gas and aerosol sub-area TMRs (tracer mixing ratios) +! for a single cloudy sub-area (with indices = lchnk,i,k,jsub) +! qgas3, qaer3, qaercw3, qnum3, qnumcw3 are the current incoming TMRs +! qgas4, qaer4, qaercw4, qnum4, qnumcw4 are the updated outgoing TMRs +! +! when do_cond = false, this routine only calculates changes involving +! growth from smaller to larger modes (renaming) following cloud chemistry +! so gas TMRs are not changed +! when do_cond = true, this routine also calculates changes involving +! gas-aerosol exchange (condensation/evaporation) +! transfer of particles from hydrophobic modes to hydrophilic modes (aging) +! due to condensation +! currently this routine does not do +! new particle nucleation - because h2so4 gas conc. should be very low in cloudy air +! coagulation - because cloud-borne aerosol would need to be included +! + use physconst, only: r_universal + + logical, intent(in) :: do_cond, do_rename, do_newnuc, do_coag + logical, intent(in) :: iscldy_subarea ! true if sub-area is cloudy + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: i, k ! column and level indices + integer, intent(in) :: latndx, lonndx ! lat and lon indices + integer, intent(in) :: lund ! logical unit for diagnostic output + integer, intent(in) :: loffset + integer, intent(in) :: jsub, nsubarea ! sub-area index, number of sub-areas + + real(r8), intent(in) :: afracsub ! fractional area of sub-area (0-1) + real(r8), intent(in) :: deltat ! time step (s) + + real(r8), intent(in) :: temp ! temperature at model levels (K) + real(r8), intent(in) :: pmid ! pressure at layer center (Pa) + real(r8), intent(in) :: pdel ! pressure thickness of layer (Pa) + real(r8), intent(in) :: zmid ! altitude (above ground) at layer center (m) + real(r8), intent(in) :: pblh ! planetary boundary layer depth (m) + real(r8), intent(in) :: relhum ! relative humidity (0-1) + + real(r8), intent(inout) :: dgn_a(max_mode) + real(r8), intent(inout) :: dgn_awet(max_mode) + ! dry & wet geo. mean dia. (m) of number distrib. + real(r8), intent(inout) :: wetdens(max_mode) + ! interstitial aerosol wet density (kg/m3) + ! dry & wet geo. mean dia. (m) of number distrib. + +! qXXXN (X=gas,aer,wat,num; N=1:4) are sub-area mixing ratios +! XXX=gas - gas species +! XXX=aer - aerosol mass species (excluding water) +! XXX=wat - aerosol water +! XXX=num - aerosol number +! N=1 - before gas-phase chemistry +! N=2 - before cloud chemistry +! N=3 - current incoming values (before gas-aerosol exchange, newnuc, coag) +! N=4 - updated outgoing values (after gas-aerosol exchange, newnuc, coag) +! +! qXXX_delaa are TMR changes (not tendencies) +! for different processes, which are used to produce history output +! for a clear sub-area, the processes are condensation/evaporation (and associated aging), +! renaming, coagulation, and nucleation + real(r8), intent(in ), dimension( 1:max_gas ) :: & + qgas1, qgas3 + real(r8), intent(inout), dimension( 1:max_gas ) :: & + qgas4 + real(r8), intent(inout), dimension( 1:max_gas, 1:nqtendaa ) :: & + qgas_delaa + + real(r8), intent(in ), dimension( 1:max_mode ) :: & + qnum3 + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qnum4 + real(r8), intent(inout), dimension( 1:max_mode, 1:nqtendaa ) :: & + qnum_delaa + + real(r8), intent(in ), dimension( 1:max_aer, 1:max_mode ) :: & + qaer2, qaer3 + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode ) :: & + qaer4 + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode, 1:nqtendaa ) :: & + qaer_delaa + + real(r8), intent(in ), dimension( 1:max_mode ) :: & + qwtr3 + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qwtr4 + + real(r8), intent(in ), dimension( 1:max_mode ) :: & + qnumcw3 + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qnumcw4 + real(r8), intent(inout), dimension( 1:max_mode, 1:nqqcwtendaa ) :: & + qnumcw_delaa + + real(r8), intent(in ), dimension( 1:max_aer, 1:max_mode ) :: & + qaercw2, qaercw3 + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode ) :: & + qaercw4 + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode, 1:nqqcwtendaa ) :: & + qaercw_delaa + + type ( misc_vars_aa_type ), intent(inout) :: misc_vars_aa_sub + +! local + integer, parameter :: ntot_poaspec = npoa + integer, parameter :: ntot_soaspec = nsoa + + integer :: iaer, igas, ip + integer :: jtsubstep + integer :: ll + integer :: modefrm, modetoo +! if mtoo_renamexf(n) > 0, then mode n gets renamed into mode mtoo_renamexf(n) +! if mtoo_renamexf(n) <= 0, then mode n does not have renaming + integer :: mtoo_renamexf(max_mode) + integer :: n, ntsubstep + integer :: n_mode + integer :: ntot_soamode + + logical, parameter :: flag_pcarbon_opoa_frac_zero = .true. + logical, parameter :: flag_nh4_lt_2so4_each_step = .false. + + logical :: skip_soamode(max_mode) ! true if this mode does not have soa + + real(r8), dimension( 1:max_gas ) :: & + qgas_cur, qgas_sv1, qgas_avg + real(r8), dimension( 1:max_gas ) :: & + qgas_del_cond, qgas_del_nnuc, qgas_netprod_otrproc + ! qgas_netprod_otrproc = gas net production rate from other processes + ! such as gas-phase chemistry and emissions (mol/mol/s) + ! this allows the condensation (gasaerexch) routine to apply production and condensation loss + ! together, which is more accurate numerically + ! NOTE - must be >= zero, as numerical method can fail when it is negative + ! NOTE - currently only the values for h2so4 and nh3 should be non-zero + +! qxxx_del_yyyy are mix-ratio changes over full time step (deltat) +! qxxx_delsub_yyyy are mix-ratio changes over time sub-step (dtsubstep) + real(r8), dimension( 1:max_mode ) :: & + qnum_cur, qnum_sv1 + real(r8), dimension( 1:max_mode ) :: & + qnum_del_cond, qnum_del_rnam, qnum_del_nnuc, qnum_del_coag, & + qnum_delsub_cond, qnum_delsub_coag + + real(r8), dimension( 1:max_mode ) :: & + qnumcw_cur, qnumcw_sv1 + real(r8), dimension( 1:max_mode ) :: & + qnumcw_del_rnam + + real(r8), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_cur, qaer_sv1 + real(r8), dimension( 1:max_aer, 1:max_agepair ) :: & + qaer_delsub_coag_in + real(r8), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_del_cond, qaer_del_rnam, qaer_del_nnuc, qaer_del_coag, & + qaer_delsub_grow4rnam, & + qaer_delsub_cond, qaer_delsub_coag + + real(r8), dimension( 1:max_aer, 1:max_mode ) :: & + qaercw_cur, qaercw_sv1 + real(r8), dimension( 1:max_aer, 1:max_mode ) :: & + qaercw_del_rnam, & + qaercw_delsub_grow4rnam + + real(r8), dimension( 1:max_mode ) :: & + qwtr_cur + + real(r8) :: aircon ! air molar density (kmol/m3) + real(r8) :: del_h2so4_gasprod + real(r8) :: del_h2so4_aeruptk + real(r8) :: dnclusterdt + real(r8) :: dtsubstep ! time sub-step + real(r8) :: gas_diffus(max_gas) ! gas diffusivity at current temp and pres (m2/s) + real(r8) :: gas_freepath(max_gas) ! gas mean free path at current temp and pres (m) + + real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf + real(r8) :: tmp_relhum + real(r8) :: uptkaer(max_gas,max_mode) + real(r8) :: uptkrate_h2so4 + + + +! air molar density (kmol/m3) + aircon = pmid/(r_universal*temp) + + n_mode = ntot_amode + + qgas_cur = qgas3 + qaer_cur = qaer3 + qnum_cur = qnum3 + qwtr_cur = qwtr3 + qnumcw_cur = qnumcw3 + qaercw_cur = qaercw3 + + + qgas_netprod_otrproc(:) = 0.0_r8 + if ( ( do_cond ) .and. & + ( gaexch_h2so4_uptake_optaa == 2 ) ) then + do igas = 1, ngas + if ((igas == igas_h2so4) .or. (igas == igas_nh3)) then +! if gaexch_h2so4_uptake_optaa == 2, then +! if qgas increases from pre-gaschem to post-cldchem, +! start from the pre-gaschem mix-ratio and add in the production +! during the integration +! if it decreases, +! start from post-cldchem mix-ratio +! *** currently just do this for h2so4 and nh3 + qgas_netprod_otrproc(igas) = (qgas3(igas) - qgas1(igas))/deltat + if ( qgas_netprod_otrproc(igas) >= 0.0_r8 ) then + qgas_cur(igas) = qgas1(igas) + else + qgas_netprod_otrproc(igas) = 0.0_r8 + end if + end if + end do ! igas + end if + + + qgas_del_cond = 0.0_r8 + qgas_del_nnuc = 0.0_r8 + + qaer_del_cond = 0.0_r8 + qaer_del_rnam = 0.0_r8 + qaer_del_nnuc = 0.0_r8 + qaer_del_coag = 0.0_r8 + qaer_delsub_cond = 0.0_r8 + + qaercw_del_rnam = 0.0_r8 + + qnum_del_cond = 0.0_r8 + qnum_del_rnam = 0.0_r8 + qnum_del_nnuc = 0.0_r8 + qnum_del_coag = 0.0_r8 + qnum_delsub_cond = 0.0_r8 + + qnumcw_del_rnam = 0.0_r8 + + dnclusterdt = 0.0_r8 + + + ntsubstep = 1 + dtsubstep = deltat + if (ntsubstep > 1) dtsubstep = deltat/ntsubstep + + del_h2so4_gasprod = max( qgas3(igas_h2so4)-qgas1(igas_h2so4), 0.0_r8 )/ntsubstep + +! +! +! loop over multiple time sub-steps +! +! +jtsubstep_loop: & + do jtsubstep = 1, ntsubstep + + +! +! +! gas-aerosol exchange +! +! + uptkrate_h2so4 = 0.0_r8 +do_cond_if_block10: & + if ( do_cond ) then + + qgas_sv1 = qgas_cur + qnum_sv1 = qnum_cur + qaer_sv1 = qaer_cur + +#if ( defined( MOSAIC_SPECIES ) ) + if ( mosaic ) then + tmp_relhum = min( relhum, 0.98_r8 ) + call mosaic_gasaerexch_1subarea_intr( nstep, &!Intent(ins) + lchnk, i, k, jsub, & + temp, tmp_relhum, pmid, & + aircon, dtsubstep, n_mode, & + dgn_a, dgn_awet, qaer_cur, &!Intent(inouts) + qgas_cur, qnum_cur, qwtr_cur, & + qgas_avg, qgas_netprod_otrproc, & + uptkrate_h2so4, misc_vars_aa_sub ) + else +#endif + call mam_gasaerexch_1subarea( & + nstep, lchnk, & + i, k, jsub, & + jtsubstep, ntsubstep, & + latndx, lonndx, lund, & + dtsubstep, & + temp, pmid, aircon, & + n_mode, & + qgas_cur, qgas_avg, & + qgas_netprod_otrproc, & + qaer_cur, & + qnum_cur, & + qwtr_cur, & + dgn_a, dgn_awet, wetdens, & + uptkaer, uptkrate_h2so4 ) +#if ( defined( MOSAIC_SPECIES ) ) + end if +#endif + + if (newnuc_h2so4_conc_optaa == 11) then + qgas_avg(igas_h2so4) = 0.5_r8*(qgas_sv1(igas_h2so4) + qgas_cur(igas_h2so4)) + else if (newnuc_h2so4_conc_optaa == 12) then + qgas_avg(igas_h2so4) = qgas_cur(igas_h2so4) + end if + + qgas_del_cond = qgas_del_cond + (qgas_cur - (qgas_sv1 + qgas_netprod_otrproc*dtsubstep)) + qnum_delsub_cond = qnum_cur - qnum_sv1 + qaer_delsub_cond = qaer_cur - qaer_sv1 +! qaer_delsub_grow4rnam = change in qaer_del_cond during latest condensation calculations + qaer_delsub_grow4rnam = qaer_cur - qaer_sv1 + + del_h2so4_aeruptk = qgas_cur(igas_h2so4) & + - (qgas_sv1(igas_h2so4) + qgas_netprod_otrproc(igas_h2so4)*dtsubstep) + + else ! do_cond_if_block10 + + qgas_avg(1:ngas) = qgas_cur(1:ngas) + qaer_delsub_grow4rnam(:,:) = 0.0_r8 + + del_h2so4_aeruptk = 0.0_r8 + + end if do_cond_if_block10 + + +! +! +! renaming after "continuous growth" +! +! +do_rename_if_block30: & + if ( do_rename ) then + + mtoo_renamexf(:) = 0 + mtoo_renamexf(nait) = nacc + +! qaer_delsub_grow4rnam = change in qaer from cloud chemistry and gas condensation +! qaercw_delsub_grow4rnam = change in qaercw from cloud chemistry + qaer_delsub_grow4rnam = (qaer3 - qaer2)/ntsubstep + qaer_delsub_grow4rnam + qaercw_delsub_grow4rnam = (qaercw3 - qaercw2)/ntsubstep + + qnum_sv1 = qnum_cur + qaer_sv1 = qaer_cur + qnumcw_sv1 = qnumcw_cur + qaercw_sv1 = qaercw_cur + + call mam_rename_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + iscldy_subarea, & + mtoo_renamexf, & + n_mode, & + qnum_cur, & + qaer_cur, qaer_delsub_grow4rnam, & + qwtr_cur, & + qnumcw_cur, & + qaercw_cur, qaercw_delsub_grow4rnam ) + + qnum_del_rnam = qnum_del_rnam + (qnum_cur - qnum_sv1) + qaer_del_rnam = qaer_del_rnam + (qaer_cur - qaer_sv1) + qnumcw_del_rnam = qnumcw_del_rnam + (qnumcw_cur - qnumcw_sv1) + qaercw_del_rnam = qaercw_del_rnam + (qaercw_cur - qaercw_sv1) + + end if do_rename_if_block30 + + +! +! +! primary carbon aging +! +! + if ( ( n_agepair > 0 ) .and. & + ( do_cond .eqv. .true. ) ) then + + qaer_delsub_coag_in = 0.0_r8 + qaer_delsub_coag = 0.0_r8 + qnum_delsub_coag = 0.0_r8 + + call mam_pcarbon_aging_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + dtsubstep, dgn_a, do_cond, & + n_mode, & + qnum_cur, qnum_delsub_cond, qnum_delsub_coag, & + qaer_cur, qaer_delsub_cond, qaer_delsub_coag, & + qaer_delsub_coag_in, & + qwtr_cur ) + + end if + + +! accumulate sub-step q-dels + if ( do_cond ) then + qnum_del_cond = qnum_del_cond + qnum_delsub_cond + qaer_del_cond = qaer_del_cond + qaer_delsub_cond + end if + + end do jtsubstep_loop + + +! +! +! final mix ratios +! +! + qgas4 = qgas_cur + qaer4 = qaer_cur + qnum4 = qnum_cur + qwtr4 = qwtr_cur + qnumcw4 = qnumcw_cur + qaercw4 = qaercw_cur + +! final mix ratio changes + + qgas_delaa(:,iqtend_cond) = qgas_del_cond(:) + qgas_delaa(:,iqtend_rnam) = 0.0_r8 + qgas_delaa(:,iqtend_nnuc) = 0.0_r8 + qgas_delaa(:,iqtend_coag) = 0.0_r8 + + qnum_delaa(:,iqtend_cond) = qnum_del_cond(:) + qnum_delaa(:,iqtend_rnam) = qnum_del_rnam(:) + qnum_delaa(:,iqtend_nnuc) = 0.0_r8 + qnum_delaa(:,iqtend_coag) = 0.0_r8 + + qaer_delaa(:,:,iqtend_cond) = qaer_del_cond(:,:) + qaer_delaa(:,:,iqtend_rnam) = qaer_del_rnam(:,:) + qaer_delaa(:,:,iqtend_nnuc) = 0.0_r8 + qaer_delaa(:,:,iqtend_coag) = 0.0_r8 + + qnumcw_delaa(:,iqqcwtend_rnam) = qnumcw_del_rnam(:) + + qaercw_delaa(:,:,iqqcwtend_rnam) = qaercw_del_rnam(:,:) + + misc_vars_aa_sub%ncluster_tend_nnuc_1grid = dnclusterdt + + return + end subroutine mam_amicphys_1subarea_cloudy + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + subroutine mam_amicphys_1subarea_clear( & + do_cond, do_rename, & + do_newnuc, do_coag, & + nstep, lchnk, i, k, & + latndx, lonndx, lund, & + loffset, deltat, & + jsub, nsubarea, & + iscldy_subarea, afracsub, & + temp, pmid, pdel, & + zmid, pblh, relhum, & + dgn_a, dgn_awet, wetdens, & + qgas1, qgas3, qgas4, & + qgas_delaa, & + qnum3, qnum4, qnum_delaa, & + qaer3, qaer4, qaer_delaa, & + qwtr3, qwtr4, & + misc_vars_aa_sub ) +! +! calculates changes to gas and aerosol sub-area TMRs (tracer mixing ratios) +! for a single clear sub-area (with indices = lchnk,i,k,jsub) +! qgas3, qaer3, qnum3 are the current incoming TMRs +! qgas4, qaer4, qnum4 are the updated outgoing TMRs +! +! this routine calculates changes involving +! gas-aerosol exchange (condensation/evaporation) +! growth from smaller to larger modes (renaming) due to condensation +! new particle nucleation +! coagulation +! transfer of particles from hydrophobic modes to hydrophilic modes (aging) +! due to condensation and coagulation +! + use physconst, only: r_universal + + logical, intent(in) :: do_cond, do_rename, do_newnuc, do_coag + logical, intent(in) :: iscldy_subarea ! true if sub-area is cloudy + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: i, k ! column and level indices + integer, intent(in) :: latndx, lonndx ! lat and lon indices + integer, intent(in) :: lund ! logical unit for diagnostic output + integer, intent(in) :: loffset + integer, intent(in) :: jsub, nsubarea ! sub-area index, number of sub-areas + + real(r8), intent(in) :: afracsub ! fractional area of sub-area (0-1) + real(r8), intent(in) :: deltat ! time step (s) + + real(r8), intent(in) :: temp ! temperature at model levels (K) + real(r8), intent(in) :: pmid ! pressure at layer center (Pa) + real(r8), intent(in) :: pdel ! pressure thickness of layer (Pa) + real(r8), intent(in) :: zmid ! altitude (above ground) at layer center (m) + real(r8), intent(in) :: pblh ! planetary boundary layer depth (m) + real(r8), intent(in) :: relhum ! relative humidity (0-1) + + real(r8), intent(inout) :: dgn_a(max_mode) + real(r8), intent(inout) :: dgn_awet(max_mode) + ! dry & wet geo. mean dia. (m) of number distrib. + real(r8), intent(inout) :: wetdens(max_mode) + ! interstitial aerosol wet density (kg/m3) + ! dry & wet geo. mean dia. (m) of number distrib. + +! qXXXN (X=gas,aer,wat,num; N=1:4) are sub-area mixing ratios +! XXX=gas - gas species +! XXX=aer - aerosol mass species (excluding water) +! XXX=wat - aerosol water +! XXX=num - aerosol number +! N=1 - before gas-phase chemistry +! N=2 - before cloud chemistry +! N=3 - current incoming values (before gas-aerosol exchange, newnuc, coag) +! N=4 - updated outgoing values (after gas-aerosol exchange, newnuc, coag) +! +! qXXX_delaa are TMR changes (not tendencies) +! for different processes, which are used to produce history output +! for a clear sub-area, the processes are condensation/evaporation (and associated aging), +! renaming, coagulation, and nucleation + real(r8), intent(in ), dimension( 1:max_gas ) :: & + qgas1, qgas3 + real(r8), intent(inout), dimension( 1:max_gas ) :: & + qgas4 + real(r8), intent(inout), dimension( 1:max_gas, 1:nqtendaa ) :: & + qgas_delaa + + real(r8), intent(in ), dimension( 1:max_mode ) :: & + qnum3 + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qnum4 + real(r8), intent(inout), dimension( 1:max_mode, 1:nqtendaa ) :: & + qnum_delaa + + real(r8), intent(in ), dimension( 1:max_aer, 1:max_mode ) :: & + qaer3 + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode ) :: & + qaer4 + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode, 1:nqtendaa ) :: & + qaer_delaa + + real(r8), intent(in ), dimension( 1:max_mode ) :: & + qwtr3 + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qwtr4 + + type ( misc_vars_aa_type ), intent(inout) :: misc_vars_aa_sub + +! local + integer, parameter :: ntot_poaspec = npoa + integer, parameter :: ntot_soaspec = nsoa + + integer :: iaer, igas, ip + integer :: jtsubstep + integer :: ll + integer :: modefrm, modetoo +! if mtoo_renamexf(n) > 0, then mode n gets renamed into mode mtoo_renamexf(n) +! if mtoo_renamexf(n) <= 0, then mode n does not have renaming + integer :: mtoo_renamexf(max_mode) + integer :: n, ntsubstep + integer :: n_mode + integer :: ntot_soamode + + logical, parameter :: flag_pcarbon_opoa_frac_zero = .true. + logical, parameter :: flag_nh4_lt_2so4_each_step = .false. + + logical :: skip_soamode(max_mode) ! true if this mode does not have soa + + real(r8), dimension( 1:max_gas ) :: & + qgas_cur, qgas_sv1, qgas_avg + real(r8), dimension( 1:max_gas ) :: & + qgas_del_cond, qgas_del_nnuc, qgas_netprod_otrproc + ! qgas_netprod_otrproc = gas net production rate from other processes + ! such as gas-phase chemistry and emissions (mol/mol/s) + ! this allows the condensation (gasaerexch) routine to apply production and condensation loss + ! together, which is more accurate numerically + ! NOTE - must be >= zero, as numerical method can fail when it is negative + ! NOTE - currently only the values for h2so4 and nh3 should be non-zero + +! qxxx_del_yyyy are mix-ratio changes over full time step (deltat) +! qxxx_delsub_yyyy are mix-ratio changes over time sub-step (dtsubstep) + real(r8), dimension( 1:max_mode ) :: & + qnum_cur, qnum_sv1 + real(r8), dimension( 1:max_mode ) :: & + qnum_del_cond, qnum_del_rnam, qnum_del_nnuc, qnum_del_coag, & + qnum_delsub_cond, qnum_delsub_coag + + real(r8), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_cur, qaer_sv1 + real(r8), dimension( 1:max_aer, 1:max_agepair ) :: & + qaer_delsub_coag_in + real(r8), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_del_cond, qaer_del_rnam, qaer_del_nnuc, qaer_del_coag, & + qaer_delsub_grow4rnam, & + qaer_delsub_cond, qaer_delsub_coag + + real(r8), dimension( 1:max_mode ) :: & + qwtr_cur + + real(r8) :: aircon ! air molar density (kmol/m3) + real(r8) :: del_h2so4_gasprod + real(r8) :: del_h2so4_aeruptk + real(r8) :: dnclusterdt, dnclusterdt_substep + real(r8) :: dtsubstep ! time sub-step + real(r8) :: gas_diffus(max_gas) ! gas diffusivity at current temp and pres (m2/s) + real(r8) :: gas_freepath(max_gas) ! gas mean free path at current temp and pres (m) + + real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf + real(r8) :: uptkaer(max_gas,max_mode) + real(r8) :: uptkrate_h2so4 + + + +! air molar density (kmol/m3) + aircon = pmid/(r_universal*temp) + + n_mode = ntot_amode + + qgas_cur = qgas3 + qaer_cur = qaer3 + qnum_cur = qnum3 + qwtr_cur = qwtr3 + + qgas_netprod_otrproc(:) = 0.0_r8 + if ( ( do_cond ) .and. & + ( gaexch_h2so4_uptake_optaa == 2 ) ) then + do igas = 1, ngas + if ((igas == igas_h2so4) .or. (igas == igas_nh3)) then +! if gaexch_h2so4_uptake_optaa == 2, then +! if qgas increases from pre-gaschem to post-cldchem, +! start from the pre-gaschem mix-ratio and add in the production +! during the integration +! if it decreases, +! start from post-cldchem mix-ratio +! *** currently just do this for h2so4 and nh3 + qgas_netprod_otrproc(igas) = (qgas3(igas) - qgas1(igas))/deltat + if ( qgas_netprod_otrproc(igas) >= 0.0_r8 ) then + qgas_cur(igas) = qgas1(igas) + else + qgas_netprod_otrproc(igas) = 0.0_r8 + end if + end if + end do ! igas + end if + + qgas_del_cond = 0.0_r8 + qgas_del_nnuc = 0.0_r8 + + qaer_del_cond = 0.0_r8 + qaer_del_rnam = 0.0_r8 + qaer_del_nnuc = 0.0_r8 + qaer_del_coag = 0.0_r8 + qaer_delsub_coag_in = 0.0_r8 + qaer_delsub_cond = 0.0_r8 + qaer_delsub_coag = 0.0_r8 + + qnum_del_cond = 0.0_r8 + qnum_del_rnam = 0.0_r8 + qnum_del_nnuc = 0.0_r8 + qnum_del_coag = 0.0_r8 + qnum_delsub_cond = 0.0_r8 + qnum_delsub_coag = 0.0_r8 + + dnclusterdt = 0.0_r8 + + + ntsubstep = 1 + dtsubstep = deltat + if (ntsubstep > 1) dtsubstep = deltat/ntsubstep + + del_h2so4_gasprod = max( qgas3(igas_h2so4)-qgas1(igas_h2so4), 0.0_r8 )/ntsubstep + +! +! +! loop over multiple time sub-steps +! +! +jtsubstep_loop: & + do jtsubstep = 1, ntsubstep + + +! +! +! gas-aerosol exchange +! +! + uptkrate_h2so4 = 0.0_r8 +do_cond_if_block10: & + if ( do_cond ) then + + qgas_sv1 = qgas_cur + qnum_sv1 = qnum_cur + qaer_sv1 = qaer_cur + +#if ( defined( MOSAIC_SPECIES ) ) + if ( mosaic ) then + call mosaic_gasaerexch_1subarea_intr( nstep, &!Intent(ins) + lchnk, i, k, jsub, & + temp, relhum, pmid, & + aircon, dtsubstep, n_mode, & + dgn_a, dgn_awet, qaer_cur, &!Intent(inouts) + qgas_cur, qnum_cur, qwtr_cur, & + qgas_avg, qgas_netprod_otrproc, & + uptkrate_h2so4, misc_vars_aa_sub ) + else +#endif + call mam_gasaerexch_1subarea( & + nstep, lchnk, & + i, k, jsub, & + jtsubstep, ntsubstep, & + latndx, lonndx, lund, & + dtsubstep, & + temp, pmid, aircon, & + n_mode, & + qgas_cur, qgas_avg, & + qgas_netprod_otrproc, & + qaer_cur, & + qnum_cur, & + qwtr_cur, & + dgn_a, dgn_awet, wetdens, & + uptkaer, uptkrate_h2so4 ) +#if ( defined( MOSAIC_SPECIES ) ) + end if +#endif + + if (newnuc_h2so4_conc_optaa == 11) then + qgas_avg(igas_h2so4) = 0.5_r8*(qgas_sv1(igas_h2so4) + qgas_cur(igas_h2so4)) + else if (newnuc_h2so4_conc_optaa == 12) then + qgas_avg(igas_h2so4) = qgas_cur(igas_h2so4) + end if + + qgas_del_cond = qgas_del_cond + (qgas_cur - (qgas_sv1 + qgas_netprod_otrproc*dtsubstep)) + qnum_delsub_cond = qnum_cur - qnum_sv1 + qaer_delsub_cond = qaer_cur - qaer_sv1 +! qaer_del_grow4rnam = change in qaer_del_cond during latest condensation calculations + qaer_delsub_grow4rnam = qaer_cur - qaer_sv1 + + del_h2so4_aeruptk = qgas_cur(igas_h2so4) & + - (qgas_sv1(igas_h2so4) + qgas_netprod_otrproc(igas_h2so4)*dtsubstep) + + else ! do_cond_if_block10 + + qgas_avg(1:ngas) = qgas_cur(1:ngas) + qaer_delsub_grow4rnam(:,:) = 0.0_r8 + + del_h2so4_aeruptk = 0.0_r8 + + end if do_cond_if_block10 + + +! +! +! renaming after "continuous growth" +! +! +do_rename_if_block30: & + if ( do_rename ) then + + mtoo_renamexf(:) = 0 + mtoo_renamexf(nait) = nacc + + qnum_sv1 = qnum_cur + qaer_sv1 = qaer_cur + + call mam_rename_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + iscldy_subarea, & + mtoo_renamexf, & + n_mode, & + qnum_cur, & + qaer_cur, qaer_delsub_grow4rnam, & + qwtr_cur ) + + qnum_del_rnam = qnum_del_rnam + (qnum_cur - qnum_sv1) + qaer_del_rnam = qaer_del_rnam + (qaer_cur - qaer_sv1) + + end if do_rename_if_block30 + + +! +! +! new particle formation (nucleation) +! +! +do_newnuc_if_block50: & + if ( do_newnuc ) then + + qgas_sv1 = qgas_cur + qnum_sv1 = qnum_cur + qaer_sv1 = qaer_cur + + call mam_newnuc_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + dtsubstep, & + temp, pmid, aircon, & + zmid, pblh, relhum, & + uptkrate_h2so4, del_h2so4_gasprod, del_h2so4_aeruptk, & + n_mode, & + qgas_cur, qgas_avg, & + qnum_cur, & + qaer_cur, & + qwtr_cur, & + dnclusterdt_substep ) + + qgas_del_nnuc = qgas_del_nnuc + (qgas_cur - qgas_sv1) + qnum_del_nnuc = qnum_del_nnuc + (qnum_cur - qnum_sv1) + qaer_del_nnuc = qaer_del_nnuc + (qaer_cur - qaer_sv1) + dnclusterdt = dnclusterdt + dnclusterdt_substep*(dtsubstep/deltat) + + end if do_newnuc_if_block50 + + +! +! +! coagulation part +! +! + if ( do_coag ) then + + qnum_sv1 = qnum_cur + qaer_sv1 = qaer_cur + + call mam_coag_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + dtsubstep, & + temp, pmid, aircon, & + dgn_a, dgn_awet, wetdens, & + n_mode, & + qnum_cur, & + qaer_cur, qaer_delsub_coag_in, & + qwtr_cur ) + + qnum_delsub_coag = qnum_cur - qnum_sv1 + qaer_delsub_coag = qaer_cur - qaer_sv1 + + end if + + +! +! +! primary carbon aging +! +! + if ( n_agepair > 0 ) then + + call mam_pcarbon_aging_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + dtsubstep, dgn_a, do_cond, & + n_mode, & + qnum_cur, qnum_delsub_cond, qnum_delsub_coag, & + qaer_cur, qaer_delsub_cond, qaer_delsub_coag, & + qaer_delsub_coag_in, & + qwtr_cur ) + + end if + + +! accumulate sub-step q-dels + if ( do_coag ) then + qnum_del_coag = qnum_del_coag + qnum_delsub_coag + qaer_del_coag = qaer_del_coag + qaer_delsub_coag + end if + if ( do_cond ) then + qnum_del_cond = qnum_del_cond + qnum_delsub_cond + qaer_del_cond = qaer_del_cond + qaer_delsub_cond + end if + + end do jtsubstep_loop + + +! +! +! final mix ratios +! +! + qgas4 = qgas_cur + qaer4 = qaer_cur + qnum4 = qnum_cur + qwtr4 = qwtr_cur + +! final mix ratio changes + + qgas_delaa(:,iqtend_cond) = qgas_del_cond(:) + qgas_delaa(:,iqtend_rnam) = 0.0_r8 + qgas_delaa(:,iqtend_nnuc) = qgas_del_nnuc(:) + qgas_delaa(:,iqtend_coag) = 0.0_r8 + + qnum_delaa(:,iqtend_cond) = qnum_del_cond(:) + qnum_delaa(:,iqtend_rnam) = qnum_del_rnam(:) + qnum_delaa(:,iqtend_nnuc) = qnum_del_nnuc(:) + qnum_delaa(:,iqtend_coag) = qnum_del_coag(:) + + qaer_delaa(:,:,iqtend_cond) = qaer_del_cond(:,:) + qaer_delaa(:,:,iqtend_rnam) = qaer_del_rnam(:,:) + qaer_delaa(:,:,iqtend_nnuc) = qaer_del_nnuc(:,:) + qaer_delaa(:,:,iqtend_coag) = qaer_del_coag(:,:) + + misc_vars_aa_sub%ncluster_tend_nnuc_1grid = dnclusterdt + + return + end subroutine mam_amicphys_1subarea_clear + + +!--------------------------------------------------------------------- +!--------------------------------------------------------------------- +#if ( defined( MOSAIC_SPECIES ) ) + subroutine mosaic_gasaerexch_1subarea_intr( nstep, &!Intent(ins) + lchnk, i_in, k_in, jsub_in, & + temp, relhum, pmid, & + aircon, dtsubstep, n_mode, & + dgn_a, dgn_awet, qaer_cur, &!Intent(inouts) + qgas_cur, qnum_cur, qwtr_cur, & + qgas_avg, qgas_netprod_otrproc, & + uptkrate_h2so4, misc_vars_aa_sub ) + !------------------------------------------------------------------------------! + !Purpose: This routine acts as an interface between Mosaic and CAM + !Future work: + !=========== + !1. Clean Mosaic code and get rid of the arguments which stays constant + ! for the entire simulation + !3. Please handle the Mosaic counters, either use pbuf or make them internal to + ! Mosaic + !4. Use get_nstep() for it_mosaic or pull out the it_mosaic .eq. 1 computation + ! to the init routines + !5. SOA from CAM is stored in LIM2 of Mosaic. Rest of the 7 SOA species in + ! Mosaic are populated with zeros + !6. Some variables in Mosaic had to be initialized to zero. Please revisit and + ! fix whatever is necessary + !7. jhyst_leg is constant for now and is equal to jhyst_up + ! + !Author: Balwinder Singh (PNNL) + !------------------------------------------------------------------------------! + !Use statements + use module_mosaic_box_aerchem, only: mosaic_box_aerchemistry + use infnan, only: nan, bigint + use physconst, only: mwh2o + use module_data_mosaic_aero, only: naer_mosaic => naer, & + inh4_a, ilim2_a, iso4_a, ina_a, icl_a, ibc_a, ioin_a, ioc_a, & + ino3_a, icl_a, ica_a, ico3_a, & + ilim2_g, ih2so4_g, inh3_g, ihno3_g, ihcl_g, & + jhyst_up, jtotal, & + nbin_a, nbin_a_max, ngas_volatile, nmax_astem, nmax_mesa, nsalt, & + mosaic_vars_aa_type +#ifdef SPMD + use spmd_dyn, only: mpicom_xy, iam + use units, only: getunit, freeunit +#endif + + implicit none + + !Args: intent(in) + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: i_in, k_in ! column and level indices + integer, intent(in) :: jsub_in ! subarea index + + real(r8), intent(in) :: temp !Temperature at model levels (K) + real(r8), intent(in) :: relhum !Relative humidity (0-1) + real(r8), intent(in) :: pmid !Pressure at layer center (Pa) + real(r8), intent(in) :: aircon !Air molar density (kmol/m3) + real(r8), intent(in) :: dtsubstep !Time sub-step (s) + integer, intent(in) :: n_mode !current number of active modes + + !Args: intent(inout) + real(r8), intent(inout) :: dgn_a(max_mode) !Dry geo. mean dia. (m) of number distrib. + real(r8), intent(inout) :: dgn_awet(max_mode) !Wet geo. mean dia. (m) of number distrib. + real(r8), intent(inout) :: qaer_cur(max_aer,max_mode) !Current aerosol mass mix ratios (mol/mol) + real(r8), intent(inout) :: qgas_cur(max_gas) !Current gas mix ratios (mol/mol) + real(r8), intent(inout) :: qnum_cur(max_mode) !Current aerosol number mix ratios (#/kmol) + real(r8), intent(inout) :: qwtr_cur(max_mode) !Current aerosol water mix ratios (mol/mol) + real(r8), intent(inout) :: qgas_avg(max_gas) !average gas conc. over dtchem time step (mol/mol) + real(r8), intent(inout) :: qgas_netprod_otrproc(max_gas) + ! qgas_netprod_otrproc = gas net production rate from other processes + ! such as gas-phase chemistry and emissions (mol/mol/s) + ! this allows the condensation (gasaerexch) routine to apply production and condensation loss + ! together, which is more accurate numerically + ! NOTE - must be >= zero, as numerical method can fail when it is negative + ! NOTE - currently only the values for h2so4 and nh3 should be non-zero + real(r8), intent(inout) :: uptkrate_h2so4 ! rate of h2so4 uptake by aerosols (1/s) + type ( misc_vars_aa_type ), intent(inout) :: misc_vars_aa_sub + + !Local Variables - [To be sent as args to Mosaic code] + integer :: ierr +! integer :: it_mosaic !Time step counter for Mosaic +! integer :: jASTEM_fail !Counter to indicate if the ASTEM convergence failed in Mosaic + real(r8) :: dtchem !Timestep in seconds + real(r8) :: T_K !Temperature in K + + + integer :: mcall_load_mosaic_parameters !Flag to decide whether to call 'load_mosaic_parameters' or not(*BALLI not used anymore) + integer :: mcall_print_aer_in !Flag to decide whether to call 'print_aer' or not + + integer, dimension(nbin_a_max) :: jaerosolstate !Aerosol state (solid, liquid, gas) +! integer, dimension(nbin_a_max) :: iter_mesa !MESA iterations counters + integer, dimension(nbin_a_max) :: jaerosolstate_bgn !Aerosol state at the begining (solid, liquid, gas) + integer, dimension(nbin_a_max) :: jhyst_leg + + + real(r8) :: aH2O !Relative humidity in fraction(variaes between 0 and 1) + real(r8) :: P_atm !Pressure in atm units + real(r8) :: RH_pc !Relative humidity in %age(variaes between 0 and 100) + real(r8) :: cair_mol_m3 !Air molar density (mol/m3) + + real(r8), dimension(nbin_a_max) :: water_a !Current aerosol water mix ratios (kg/m3) + real(r8), dimension(nbin_a_max) :: sigmag_a !Geometric standard deviation for aerosol mode + real(r8), dimension(nbin_a_max) :: Dp_dry_a !Dry geo. mean dia. (cm) of number distrib. + + real(r8), dimension(nbin_a_max) :: num_a !Current aerosol number mix ratios (#/cm3) + real(r8), dimension(nbin_a_max) :: dp_wet_a !Diameter of aerosol in (cm) + real(r8), dimension(nbin_a_max) :: mass_dry_a_bgn !g/cc(air) **BALLI*** comment missing + real(r8), dimension(nbin_a_max) :: mass_dry_a !g/cc(air) **BALLI*** comment missing + real(r8), dimension(nbin_a_max) :: dens_dry_a_bgn !g/cc **BALLI*** comment missing + real(r8), dimension(nbin_a_max) :: dens_dry_a !g/cc **BALLI*** comment missing + real(r8), dimension(nbin_a_max) :: water_a_hyst !kg(water)/m^3(air) hysteresis (at 60% RH) **BALLI*** comment missing + real(r8), dimension(nbin_a_max) :: aH2O_a !Relative humidity in fraction(variaes between 0 and 1) + real(r8), dimension(nbin_a_max) :: gam_ratio + + real(r8), dimension(ngas_volatile) :: gas !Current gas mix ratios (nano mol/m3) + real(r8), dimension(ngas_volatile) :: gas_avg ! average gas conc. over dtchem time step (nmol/m3) + real(r8), dimension(ngas_volatile) :: gas_netprod_otrproc + ! gas_netprod_otrproc = gas net production rate from other processes + ! such as gas-phase chemistry and emissions (mol/mol/s) + ! NOTE - must be >= zero, as numerical method can fail when it is negative + ! NOTE - currently for mosaic, only the value for h2so4 can be non-zero + real(r8), dimension(naer_mosaic,3,nbin_a_max) :: aer !Current aerosol mass mix ratios (nano mol/m3) + + !Local Variables - [other local variables] + character(len=500) :: tmp_str, nlfile, sballi +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + character(len=500) :: infile + logical, parameter :: debug_mosaic = .false. + integer, parameter :: iam = 0 +#endif +! logical :: zero_water_flag, flag_itr_kel + integer :: imode, ibin, iaer, igas, istate, isalt, ibin_in, iaer_in, istate_in + integer :: unitn + + !BALLI - Following should be in the modules as parameter + real(r8), parameter :: oneatminv = 1.0_r8/1.01325e5_r8 + !BALLI - Following should be in the modules as parameter - ENDS + + !BSINGH - For converting CAM units to Mosaic units + real(r8) :: nano_mult_cair, aer_tmp + real(r8) :: num_cam_to_mos_units, wtr_cam_to_mos_units + + !BSINGH - For converting Mosaic units to CAM units + real(r8) :: nano_mult_cair_inv + real(r8) :: num_mos_to_cam_units, wtr_mos_to_cam_units + + !BSINGH - For debugging mosiac code +! integer, dimension(6) :: hostgridinfo + integer, dimension(nbin_a_max) :: jaerosolstate_in + integer, dimension(nbin_a_max) :: jhyst_leg_in + + real(r8), dimension(nbin_a_max) :: num_a_in + real(r8), dimension(nbin_a_max) :: dp_wet_a_in + real(r8), dimension(nbin_a_max) :: water_a_in + real(r8), dimension(nbin_a_max) :: sigmag_a_in + real(r8), dimension(nbin_a_max) :: Dp_dry_a_in + + real(r8), dimension(ngas_volatile) :: gas_in, gas_netprod_otrproc_in, gas_avg_in + + real(r8), dimension(naer_mosaic,3,nbin_a_max) :: aer_in + + real(r8), dimension(naer_mosaic) :: kappa_nonelectro + + type (mosaic_vars_aa_type) :: mosaic_vars_aa + + !BSINGH - For storing points having trouble converging + logical,parameter :: convergence_pt_trk = .true. !For tracking points where convergence failed, let the run proceed +! logical :: f_neg_vol_tmp + + + ! allocate the allocatable parts of mosaic_vars_aa + allocate( mosaic_vars_aa%iter_mesa(nbin_a_max), stat=ierr ) + if (ierr /= 0) then + print *, '*** subr mosaic_gasaerexch_1subarea_intr - allocate error for mosaic_vars_aa%iter_mesa' + stop + end if + + + !if(nstep>17 .and. i_in == 14)write(202,*)'AMICPHYS I K:',i_in,k_in,nstep,lchnk + !------------------------------------------------------------! + !------------------------------------------------------------! + !Populate MOSAIC variables + !------------------------------------------------------------! + !------------------------------------------------------------! + + !Counters: + !BSINGH - This counter is internal to Mosaic model. + ! It indicates if ASTEM convergence failed in Mosaic +! jASTEM_fail = 0 + mosaic_vars_aa%jastem_fail = 0 + + !BSINGH - This is time step number in Mosaic +! it_mosaic = nstep + mosaic_vars_aa%it_mosaic = nstep + + !Inputs for Mosaic model (Should be intent-ins for Mosaic model) + aH2O = relhum !Relative humidity [fraction between 0 and 1] + T_K = temp !Temperature in K + P_atm = pmid * oneatminv !Pressure (atm) + RH_pc = aH2O * 100.0_r8 !Relative humidity [%age between 0 and 100] + cair_mol_m3 = aircon * 1000.0_r8 !Air molar density (mol/m3){units conversion: aircon[kmol/m3] * 1.0e3[mol/kmol]} + dtchem = dtsubstep !timestep (s) + + jhyst_leg(1:nbin_a_max) = jhyst_up + + !Flags to control Mosaic model + mcall_load_mosaic_parameters = 1 !**BALLI.. This flag is not used anymore + mcall_print_aer_in = 0 !**BALLI...insert a dummy call to print_aer + + + !Populate aersols + nbin_a = n_mode ! current number of modes + + aer(:,:,:) = 0.0_r8 !initialized to zero + + !Populate aerosol numbers and water species + num_a(:) = 0.0_r8 !Initialized to zero + water_a(:) = 0.0_r8 !initialized to zero + + !BSINGH - units of qnum_cur in CAM are #/kmol of air. In Mosaic, units are #/cm3 + !Units conversion: qnum_cur[#/kmol] * 1.0e-3[kmol/mol] * cair_mol_m3[mol/m3] * 1.0e-6[m3/cm3] + + num_cam_to_mos_units = 1.0e-3_r8 * cair_mol_m3 * 1.0e-6_r8 + + !BSINGH - units for water in CAM are mol/mol. In Mosaic, units are kg/m3 + !Units conversion: qwtr_cur[mol/mol] * mwh2o[g/mol] * cair_mol_m3[mol/m3] * 1.0e-3[kg/g] + + wtr_cam_to_mos_units = mwh2o * cair_mol_m3 * 1.0e-3_r8 + + + nano_mult_cair = cair_mol_m3 * 1.0e9_r8 + + do imode = 1, n_mode + !Notes: + !1. NCL(sea salt) of CAM is mapped in NA and CL of MOSAIC + !2. SOA of CAM is lumped into LIM2 species of MOSAIC !BALLI *ASK RAHUL and Dick + !3. Species NO3, MSA, CO3, Ca do not exist in CAM therefore not mapped here + !4. Species ARO1, ARO2, ALK1, OLE1, API1, API2, LIM1 are SOA species in MOSAIC + ! which are not used in CAM-MOSAIC framework as of now + !5. CAM units are (mol/mol of air) which are converted to Mosaic units (nano mol/m3). + + !Units conversion:qaer_cur[mol/mol] * cair_mol_m3[mol/m3] * 1.0e9[nmol/mol] + aer(inh4_a, jtotal, imode) = qaer_cur(iaer_nh4, imode) * nano_mult_cair + aer(ilim2_a, jtotal, imode) = qaer_cur(iaer_soa, imode) * nano_mult_cair + aer(iso4_a, jtotal, imode) = qaer_cur(iaer_so4, imode) * nano_mult_cair + aer(ina_a, jtotal, imode) = qaer_cur(iaer_ncl, imode) * nano_mult_cair + if (iaer_cl > 0) then + aer(icl_a, jtotal, imode) = qaer_cur(iaer_cl, imode) * nano_mult_cair + else + aer(icl_a, jtotal, imode) = qaer_cur(iaer_ncl, imode) * nano_mult_cair + end if + if (iaer_no3 > 0) & + aer(ino3_a, jtotal, imode) = qaer_cur(iaer_no3, imode) * nano_mult_cair + if (iaer_ca > 0) & + aer(ica_a, jtotal, imode) = qaer_cur(iaer_ca, imode) * nano_mult_cair + if (iaer_co3 > 0) & + aer(ico3_a, jtotal, imode) = qaer_cur(iaer_co3, imode) * nano_mult_cair + + !Units of BC, OC and DST in CAM are (mol/mol of air) and nano-g/m3 in MOSAIC + !Units conversion:qaer_cur[mol/mol] * mw_aer[g/mol] * cair_mol_m3[mol/m3] * 1.0e9[nano-g/g] + aer(ibc_a, jtotal, imode) = qaer_cur(iaer_bc, imode) * mw_aer(iaer_bc) * nano_mult_cair + aer(ioin_a, jtotal, imode) = qaer_cur(iaer_dst, imode) * mw_aer(iaer_dst) * nano_mult_cair !BSINGH - "Other inorganic(oin)" in Mosaic is DST in CAM + aer(ioc_a, jtotal, imode) = qaer_cur(iaer_pom, imode) * mw_aer(iaer_pom) * nano_mult_cair + + !Populate aerosol number and water species + num_a(imode) = qnum_cur(imode) * num_cam_to_mos_units + water_a(imode) = qwtr_cur(imode) * wtr_cam_to_mos_units + end do + + !Populate gases + gas(:) = 0.0_r8 !Initialized to zero + !BSINGH - only 3 gases are avialble in CAM (SOAG, H2SO4, NH3). + !SOAG is stored in LIM2 gas species as of now + !CAM units are (mol/mol of air) which are converted to Mosaic units (nano mol/m3). + gas_avg(:) = 0.0_r8 + + !Units conversion:qgas_cur[mol/mol] * cair_mol_m3[mol/m3] * 10.0e9[nmol/mol] + gas(ilim2_g) = qgas_cur(igas_soa) * nano_mult_cair + gas(ih2so4_g) = qgas_cur(igas_h2so4) * nano_mult_cair + gas(inh3_g) = qgas_cur(igas_nh3) * nano_mult_cair + if (igas_hno3 > 0) & + gas(ihno3_g) = qgas_cur(igas_hno3) * nano_mult_cair + if (igas_hcl > 0) & + gas(ihcl_g) = qgas_cur(igas_hcl) * nano_mult_cair + + !Populate gas_netprod_otrproc + gas_netprod_otrproc(:) = 0.0_r8 + gas_netprod_otrproc(ih2so4_g) = qgas_netprod_otrproc(igas_h2so4) * nano_mult_cair + ! nh3 gas-phase chem production should be zero (unless we include emissions) + ! and doing simultaneous production and condensation in mosaic is more complicated + ! for nh3 that for h2so4 + ! so for now, just add in the production here + gas(inh3_g) = gas(inh3_g) + max( qgas_netprod_otrproc(igas_nh3)*dtchem, 0.0_r8 ) * nano_mult_cair + + + !BSINGH - Initialize the following variables as 'nan' and then assign values to a subset of their dimesions + Dp_dry_a(:) = nan + sigmag_a(:) = nan + dp_wet_a(:) = nan + + sigmag_a(1:n_mode) = sigmag_aer(1:n_mode) !Geometric standard deviation for aerosol mode + !Dry geo. mean dia.(cm) of number distrib [convert from m to cm]!**BALLI: check if it meant to be in,inout or out only and units also + Dp_dry_a(1:n_mode) = dgn_a(1:n_mode) * 100.0_r8 * fcvt_dgnum_dvolmean(1:n_mode) + !Wet geo. mean dia.(cm) of number distrib [convert from m to cm]!**BALLI: check if it meant to be in,inout or out only and untis also + dp_wet_a(1:n_mode) = dgn_awet(1:n_mode) * 100.0_r8 * fcvt_dgnum_dvolmean(1:n_mode) + + + !BSINGH - These are output variables from Mosaic. + !Declared as nan to make sure that they are not inadvertently 'used' before assignment. +! iter_mesa(:) = bigint + mosaic_vars_aa%iter_mesa(1:nbin_a_max) = 0 + jaerosolstate_bgn(:) = bigint + jaerosolstate(:) = bigint + + mass_dry_a_bgn(:) = nan + mass_dry_a(:) = nan + dens_dry_a_bgn(:) = nan + dens_dry_a(:) = nan + water_a_hyst(:) = nan + aH2O_a(:) = nan + gam_ratio(:) = nan + + + !------------------------------------------------------------! + !------------------------------------------------------------! + !END [Populate MOSAIC variables] + !------------------------------------------------------------! + !------------------------------------------------------------! + + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + !BSINGH - This section is required ONLY for the MAM box model + ! to see if it can reproduce errors encountered by the + ! CAM model during runtime(e.g. convergence errors). + ! This block repopulate all the information which is + ! going into the mosaic box (intent-ins and intent-inouts). + ! It is a binary read to preserve the accuracy. + + if(debug_mosaic) then + !Read a binary file which has all the inputs to the mosaic box + !and stop the model + + unitn = 101 + infile = 'mosaic_error_7.bin' + open( unitn, file=trim(infile), status='old', form='unformatted', CONVERT = 'BIG_ENDIAN' ) + + read(unitn)aH2O + read(unitn)T_K + read(unitn)P_atm + read(unitn)RH_pc + read(unitn)dtchem + + do ibin = 1, ntot_amode !nbin_a_max + read(unitn)num_a(ibin),water_a(ibin),Dp_dry_a(ibin), & + sigmag_a(ibin),dp_wet_a(ibin),jhyst_leg(ibin), & + jaerosolstate(ibin) + end do + + + do igas = 1, ngas_volatile + read(unitn) gas(igas), gas_avg(igas), gas_netprod_otrproc(igas) + enddo + + do ibin = 1, ntot_amode !nbin_a_max + do istate = 1, 3 + do iaer = 1 , naer + read(unitn)iaer_in,istate_in,ibin_in, aer_tmp + aer(iaer_in,istate_in,ibin_in) = aer_tmp + end do + end do + end do + close(unitn) + endif + !BSINGH -----xxx ENDS reading file for debugging mosaic xxxx---- +#endif + + + !Store the variables which are intent(inout) to Mosaic box model + !for debuging purposes + aer_in(:,:,:) = aer(:,:,:) + num_a_in(:) = num_a(:) + water_a_in(:) = water_a(:) + gas_in(:) = gas(:) + Dp_dry_a_in(:) = Dp_dry_a(:) + sigmag_a_in(:) = sigmag_a(:) + dp_wet_a_in(:) = dp_wet_a(:) + jhyst_leg_in(:) = jhyst_leg(:) + jaerosolstate_in(:) = jaerosolstate(:) + gas_netprod_otrproc_in(:) = gas_netprod_otrproc(:) + gas_avg_in(:) = gas_avg(:) + + + !BSINGH - zero_water_flag becomes .true. if water is zero in liquid phase +! zero_water_flag = .false. + mosaic_vars_aa%zero_water_flag = .false. + !BSINGH - flag_itr_kel becomes true when kelvin iteration in mdofule_mosaic_ext.F90 are greater then 100 +! flag_itr_kel = .false. + mosaic_vars_aa%flag_itr_kel = .false. + + + !Store grid info +! hostgridinfo(1) = i_in +! hostgridinfo(2) = k_in +! hostgridinfo(3) = lchnk +! hostgridinfo(4:6) = bigint + mosaic_vars_aa%hostgridinfo(1) = i_in + mosaic_vars_aa%hostgridinfo(2) = k_in + mosaic_vars_aa%hostgridinfo(3) = lchnk + mosaic_vars_aa%hostgridinfo(4:6) = bigint + mosaic_vars_aa%it_host = 0 + + + ! *** maybe these should be bigint or nan ??? + mosaic_vars_aa%f_mos_fail = -1 + mosaic_vars_aa%isteps_astem = 0 + mosaic_vars_aa%isteps_astem_max = 0 + mosaic_vars_aa%jastem_call = 0 + mosaic_vars_aa%jmesa_call = 0 + mosaic_vars_aa%jmesa_fail = 0 + mosaic_vars_aa%niter_mesa_max = 0 + mosaic_vars_aa%nmax_astem = nmax_astem + mosaic_vars_aa%nmax_mesa = nmax_mesa + mosaic_vars_aa%cumul_steps_astem = 0.0_r8 + mosaic_vars_aa%niter_mesa = 0.0_r8 + mosaic_vars_aa%xnerr_astem_negative(:,:) = 0.0_r8 + + + ! set kappa values for non-electrolyte species + ! reason for doing this here is that if cam eventually has multiple varieties of dust and/or pom, + ! then the dust hygroscopicity may vary spatially and temporally, + ! and the kappa values cannot be constants + kappa_nonelectro(:) = 0.0_r8 + kappa_nonelectro(ibc_a ) = 0.0001 ! previously kappa_poa = 0.0001 + kappa_nonelectro(ioc_a ) = 0.0001 ! previously kappa_bc = 0.0001 + kappa_nonelectro(ilim2_a) = 0.1 ! previously kappa_soa = 0.1 + kappa_nonelectro(ioin_a ) = 0.06 ! previously kappa_oin = 0.06 + + + !Call MOSAIC parameterization + !BSINGH - jASTEM_fail is in arg list to know if the mosiac model converged or not + !BSINGH - Following variables are not required by CAM but they still exist in the + ! calling arguments as intent-outs as Mosaic model needs them to be in the + ! arg list: + ! gam_ratio, iter_mesa, aH2O_a,jaerosolstate, mass_dry_a_bgn, mass_dry_a, + ! dens_dry_a_bgn, dens_dry_a, water_a_hyst, jaerosolstate_bgn + +! *** ff03h version *** +! call mosaic_box_aerchemistry( & +! hostgridinfo, it_mosaic, aH2O, T_K, &!Intent-ins +! P_atm, RH_pc, dtchem, & +! mcall_load_mosaic_parameters, mcall_print_aer_in, sigmag_a, & +! jaerosolstate, aer, &!Intent-inouts +! num_a, water_a, gas, & +! gas_avg, gas_netprod_otrproc, Dp_dry_a, & +! dp_wet_a, jhyst_leg, zero_water_flag, flag_itr_kel, & +! mass_dry_a_bgn, mass_dry_a, &!Intent-outs +! dens_dry_a_bgn, dens_dry_a, water_a_hyst, aH2O_a, & +! gam_ratio, jaerosolstate_bgn, jASTEM_fail, & +! iter_MESA, f_neg_vol_tmp ) + +! *** ff04a version *** + call mosaic_box_aerchemistry( aH2O, T_K, &!Intent-ins + P_atm, RH_pc, dtchem, & + mcall_load_mosaic_parameters, mcall_print_aer_in, sigmag_a, & + kappa_nonelectro, & + jaerosolstate, aer, &!Intent-inouts + num_a, water_a, gas, & + gas_avg, gas_netprod_otrproc, Dp_dry_a, & + dp_wet_a, jhyst_leg, & + mosaic_vars_aa, & + mass_dry_a_bgn, mass_dry_a, &!Intent-outs + dens_dry_a_bgn, dens_dry_a, water_a_hyst, aH2O_a, & + uptkrate_h2so4, gam_ratio, jaerosolstate_bgn ) + +! *** ff04a version *** +! subr mosaic_box_aerchemistry( aH2O, T_K, &!Intent-ins +! P_atm, RH_pc, dtchem, & +! mcall_load_mosaic_parameters, mcall_print_aer_in, sigmag_a, & +! kappa_nonelectro, & +! jaerosolstate, aer, &!Intent-inouts +! num_a, water_a, gas, & +! gas_avg, gas_netprod_otrproc, Dp_dry_a, & +! dp_wet_a, jhyst_leg, & +! mosaic_vars_aa, & +! mass_dry_a_bgn, mass_dry_a, &!Intent-outs +! dens_dry_a_bgn, dens_dry_a, water_a_hyst, aH2O_a, & +! uptkrate_h2so4, gam_ratio, jaerosolstate_bgn ) + + if (mosaic_vars_aa%flag_itr_kel) then + misc_vars_aa_sub%max_kelvin_iter_1grid = misc_vars_aa_sub%max_kelvin_iter_1grid + 1.0_r8 + endif + + if (mosaic_vars_aa%jASTEM_fail > 0 .or. mosaic_vars_aa%zero_water_flag .or. mosaic_vars_aa%f_mos_fail > 0 ) then !solver in ASTEM didn't converge + + !Let the run proceed and track the points(i,k) where the run fails convergence + if(convergence_pt_trk .and. mosaic_vars_aa%jASTEM_fail > 0 ) then + misc_vars_aa_sub%cnvrg_fail_1grid = misc_vars_aa_sub%cnvrg_fail_1grid + 1.0_r8 + else + !Printout a binary file which has all the inputs to the mosaic box + !and stop the model + + !Generate a unit number and form file name based on process number +#ifdef SPMD + unitn = getunit() + write(tmp_str,*)iam + write(nlfile,*)'mosaic_error_',trim(adjustl(tmp_str)),'.bin' +#else + unitn = 101 + nlfile = 'mosiac_error.txt' +#endif + !Open a binary file, remember it is written out as BIG ENDIAN + open( unitn, file=trim(nlfile), status='unknown', form = 'unformatted' ) + + write(unitn)aH2O !Write relative humidity + write(unitn)T_K !Write relative temp + write(unitn)P_atm !Write relative pressure + write(unitn)RH_pc + write(unitn)dtchem + !Write variables with 'nbin_a_max' dimension + do ibin = 1, ntot_amode!nbin_a_max + write(unitn)num_a_in(ibin),water_a_in(ibin),Dp_dry_a_in(ibin), & + sigmag_a_in(ibin),dp_wet_a_in(ibin),jhyst_leg_in(ibin), & + jaerosolstate_in(ibin) + end do + + !Write gas array + do igas = 1, ngas_volatile + write(unitn) gas_in(igas), gas_avg_in(igas), gas_netprod_otrproc_in(igas) + enddo + + !Write aerosols + do ibin = 1, ntot_amode !nbin_a_max + do istate = 1, 3 + do iaer = 1 , naer_mosaic + write(unitn)iaer,istate,ibin,aer_in(iaer,istate,ibin) + end do + end do + end do + !Close the file + close(unitn) +#ifdef SPMD + !free unit number + call freeunit(unitn) +#endif + !Write error message and stop the model. + write(tmp_str,*) 'Error in Mosaic, jASTEM_fail= ', mosaic_vars_aa%jASTEM_fail, & + ' zero_water_flag: ', mosaic_vars_aa%zero_water_flag, & + ' f_mos_fail:', mosaic_vars_aa%f_mos_fail + call endrun (tmp_str) + endif + endif + + + ! copy other diagnostic outputs (that are written to history) from mosaic_vars_aa to misc_vars_aa_sub + misc_vars_aa_sub%xnerr_astem_negative_1grid(:,:) = mosaic_vars_aa%xnerr_astem_negative(:,:) + + ! deallocate the allocatable parts of mosaic_vars_aa + deallocate( mosaic_vars_aa%iter_mesa, stat=ierr ) + if (ierr /= 0) then + print *, '*** subr mosaic_gasaerexch_1subarea_intr - deallocate error for mosaic_vars_aa%iter_mesa' + stop + end if + + + !------------------------------------------------------------! + !------------------------------------------------------------! + !Process MOSAIC output and store it in CAM data structures + !------------------------------------------------------------! + !------------------------------------------------------------! + !BSINGH - units of qnum_cur in CAM are #/kmol of air. In Mosaic, units are #/cm3 + num_mos_to_cam_units = 1.0_r8/num_cam_to_mos_units !Take inverse of cam_to_mos units + num_cam_to_mos_units = nan !To avoid inadvertent use + + !BSINGH - units for water in CAM are mol/mol. In Mosaic, units are kg/m3 + wtr_mos_to_cam_units = 1.0_r8/wtr_cam_to_mos_units !Take inverse of cam_to_mos units + wtr_cam_to_mos_units = nan !To avoid inadvertent use + + nano_mult_cair_inv = 1.0_r8/nano_mult_cair !Take inverse of cam to mosaic units + nano_mult_cair = nan !To avoid inadvertent use + + do imode = 1, n_mode + !Notes: + !1. NCL(sea salt) of CAM is mapped in NA and CL of MOSAIC + !2. SOA of CAM is lumped into LIM2 species of MOSAIC !BALLI *ASK RAHUL and Dick + !3. Species NO3, MSA, CO3, Ca do not exist in CAM therefore not mapped here + !4. Species ARO1, ARO2, ALK1, OLE1, API1, API2, LIM1 are SOA species in MOSAIC + ! which are not used in CAM-MOSAIC framework as of now + !5. CAM units are (mol/mol of air) and Mosaic units are (nano mol/m3). + + qaer_cur(iaer_nh4, imode) = aer(inh4_a, jtotal , imode) * nano_mult_cair_inv + qaer_cur(iaer_soa, imode) = aer(ilim2_a, jtotal , imode) * nano_mult_cair_inv + qaer_cur(iaer_so4, imode) = aer(iso4_a, jtotal , imode) * nano_mult_cair_inv + qaer_cur(iaer_ncl, imode) = aer(ina_a, jtotal , imode) * nano_mult_cair_inv + if (iaer_cl > 0) & + qaer_cur(iaer_cl, imode) = aer(icl_a, jtotal , imode) * nano_mult_cair_inv + if (iaer_no3 > 0) & + qaer_cur(iaer_no3, imode) = aer(ino3_a, jtotal , imode) * nano_mult_cair_inv + if (iaer_ca > 0) & + qaer_cur(iaer_ca, imode) = aer(ica_a, jtotal , imode) * nano_mult_cair_inv + if (iaer_co3 > 0) & + qaer_cur(iaer_co3, imode) = aer(ico3_a, jtotal , imode) * nano_mult_cair_inv + + !Units of BC, OC and DST in CAM are (mol/mol of air) and nano-g/m3 in MOSAIC + qaer_cur(iaer_bc, imode) = (aer(ibc_a, jtotal , imode)/mw_aer(iaer_bc)) * nano_mult_cair_inv + qaer_cur(iaer_dst, imode) = (aer(ioin_a, jtotal , imode)/mw_aer(iaer_dst)) * nano_mult_cair_inv !BSINGH - "Other inorganic" in Mosaic is DST in CAM + qaer_cur(iaer_pom, imode) = (aer(ioc_a, jtotal , imode)/mw_aer(iaer_pom)) * nano_mult_cair_inv + + !Populate aerosol number and water species + qnum_cur(imode) = num_a(imode) * num_mos_to_cam_units + qwtr_cur(imode) = water_a(imode) * wtr_mos_to_cam_units + end do + + !BSINGH - only 3 gases are avialble in CAM (SOAG, H2SO4, NH3). + !SOAG is stored in LIM2 gas species as of now + + qgas_cur(igas_soa) = gas(ilim2_g) * nano_mult_cair_inv + qgas_cur(igas_h2so4) = gas(ih2so4_g) * nano_mult_cair_inv + qgas_cur(igas_nh3) = gas(inh3_g) * nano_mult_cair_inv + + qgas_avg(igas_soa) = gas_avg(ilim2_g) * nano_mult_cair_inv + qgas_avg(igas_h2so4) = gas_avg(ih2so4_g) * nano_mult_cair_inv + qgas_avg(igas_nh3) = gas_avg(inh3_g) * nano_mult_cair_inv + + if (igas_hno3 > 0) then + qgas_cur(igas_hno3) = gas( ihno3_g) * nano_mult_cair_inv + qgas_avg(igas_hno3) = gas_avg(ihno3_g) * nano_mult_cair_inv + end if + if (igas_hcl > 0) then + qgas_cur(igas_hcl) = gas( ihcl_g) * nano_mult_cair_inv + qgas_avg(igas_hcl) = gas_avg(ihcl_g) * nano_mult_cair_inv + end if + + !update mode diameters + !Dry geo. mean dia.(m) of number distrib [convert from cm to m] + dgn_a(1:n_mode) = Dp_dry_a(1:n_mode) * 0.01_r8 / fcvt_dgnum_dvolmean(1:n_mode) + !Wet geo. mean dia.(m) of number distrib [convert from cm to m] + dgn_awet(1:n_mode) = dp_wet_a(1:n_mode) * 0.01_r8 / fcvt_dgnum_dvolmean(1:n_mode) + + !------------------------------------------------------------! + !------------------------------------------------------------! + !END [Process MOSAIC output ....] + !------------------------------------------------------------! + !------------------------------------------------------------! + + + end subroutine mosaic_gasaerexch_1subarea_intr +#endif + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + subroutine mam_gasaerexch_1subarea( & + nstep, lchnk, & + i, k, jsub, & + jtsubstep, ntsubstep, & + latndx, lonndx, lund, & + dtsubstep, & + temp, pmid, aircon, & + n_mode, & + qgas_cur, qgas_avg, & + qgas_netprod_otrproc, & + qaer_cur, & + qnum_cur, & + qwtr_cur, & + dgn_a, dgn_awet, wetdens, & + uptkaer, uptkrate_h2so4 ) + +! uses + + implicit none + +! arguments + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: i, k ! column and level indices + integer, intent(in) :: jsub ! sub-area index + integer, intent(in) :: jtsubstep, ntsubstep ! time substep info from calling routine + integer, intent(in) :: latndx, lonndx ! lat and lon indices + integer, intent(in) :: lund ! logical unit for diagnostic output + integer, intent(in) :: n_mode ! current number of modes (including temporary) + + real(r8), intent(in) :: dtsubstep ! integration timestep (s) + real(r8), intent(in) :: temp ! air temperature (K) + real(r8), intent(in) :: pmid ! air pressure at model levels (Pa) + real(r8), intent(in) :: aircon ! air molar concentration (kmol/m3) + + real(r8), intent(inout), dimension( 1:max_gas ) :: & + qgas_cur, & ! current gas mix ratios (mol/mol) + qgas_avg ! average gas mix ratios over the dtsubstep integration + real(r8), intent(in ), dimension( 1:max_gas ) :: & + qgas_netprod_otrproc + ! qgas_netprod_otrproc = gas net production rate from other processes + ! such as gas-phase chemistry and emissions (mol/mol/s) + ! this allows the condensation (gasaerexch) routine to apply production and condensation loss + ! together, which is more accurate numerically + ! NOTE - must be >= zero, as numerical method can fail when it is negative + ! NOTE - currently only the values for h2so4 and nh3 should be non-zero + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_cur ! current aerosol mass mix ratios (mol/mol) + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qnum_cur ! current aerosol number mix ratios (#/kmol) + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qwtr_cur ! current aerosol water mix ratios (mol/mol) +! qgas/aer/num/wtr_cur values are updated during the dtsubstep integration + + real(r8), intent(inout), dimension( 1:max_mode ) :: & + dgn_a, & ! dry geo. mean dia. (m) of number distrib. + dgn_awet, & ! wet geo. mean dia. (m) of number distrib. + wetdens ! interstitial aerosol wet density (kg/m3) + real(r8), intent(inout), dimension( 1:max_gas, 1:max_mode ) :: & + uptkaer ! gas to aerosol mass transfer rate (1/s) + real(r8), intent(inout) :: uptkrate_h2so4 + ! h2so4(g) to aerosol mass transfer rate, summed over all modes (1/s) + ! this is needed by the nucleation routine (mam_newnuc_1subarea) + +! local + integer :: iaer, igas, ip + integer :: ll + integer :: n + + logical, parameter :: flag_nh4_lt_2so4_each_step = .false. + + real(r8), dimension( 1:max_gas ) :: & + gas_diffus, & ! gas diffusivity at current temp and pres (m2/s) + gas_freepath ! gas mean free path at current temp and pres (m) + + real(r8), dimension( 1:max_gas ) :: & + qgas_prv + + real(r8), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_prv + + real(r8) :: tmpa, tmpb, tmpc + real(r8) :: tmp_kxt, tmp_kxt2, tmp_pxt, tmp_pok + real(r8) :: tmp_q1, tmp_q2, tmp_q3, tmp_q4, tmp_q5 + real(r8) :: tmp_qdel_cond + real(r8) :: uptkrate(max_mode) + + + qgas_avg(1:ngas) = 0.0_r8 + + +! calc gas uptake (mass transfer) rates + if (jtsubstep == 1) then + + tmpa = pmid/1.013e5_r8 + do igas = 1, ngas + gas_diffus(igas) = gas_diffusivity( & + temp, tmpa, mw_gas(igas), vol_molar_gas(igas) ) + + tmpb = mean_molecular_speed( temp, mw_gas(igas) ) + + gas_freepath(igas) = 3.0_r8 * gas_diffus(igas) / tmpb + +! subr gas_aer_uptkrates_1box1gas( & +! accom, gasdiffus, gasfreepath, & +! beta, nmode, dgncur_awet, lnsg, uptkrate ) + call gas_aer_uptkrates_1box1gas( & + accom_coef_gas(igas), gas_diffus(igas), gas_freepath(igas), & + 0.0_r8, ntot_amode, dgn_awet, alnsg_aer, uptkrate ) + + iaer = igas + do n = 1, ntot_amode + if ( lmap_aer(iaer,n) > 0 .or. & + mode_aging_optaa(n) > 0 ) then + ! uptkrate is for number = 1 #/m3, so mult. by number conc. (#/m3) + uptkaer(igas,n) = uptkrate(n) * (qnum_cur(n) * aircon) + else + ! mode does not contain this species + uptkaer(igas,n) = 0.0_r8 + end if + end do + end do ! igas + + do igas = 1, ngas + ! use cam5.1.00 uptake rates + if (igas <= nsoa ) uptkaer(igas,1:ntot_amode) = uptkaer(igas_h2so4,1:ntot_amode)*0.81 + if (igas == igas_nh3) uptkaer(igas,1:ntot_amode) = uptkaer(igas_h2so4,1:ntot_amode)*2.08 + end do ! igas + uptkrate_h2so4 = sum( uptkaer(igas_h2so4,1:ntot_amode) ) + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( k == pver .and. ldiagd1 ) write(lund,'(a,2i4,1p,10e11.3)') 'i,k,h2so4_uprt', i, k, uptkaer(igas_h2so4,1:ntot_amode) +! if (i==1 .and. k==4) then +! write(*,*) 'uptake rates at i=1, k=4, igas down, nmode across' +! do igas = 1, ngas +! write(*,'(1p,10e10.2)') uptkaer(igas,1:ntot_amode) +! end do +! write(*,*) 'dgn_awet then sigmag then qnum' +! write(*,'(1p,10e10.2)') dgn_awet(1:ntot_amode) +! write(*,'(1p,10e10.2)') sigmag_aer(1:ntot_amode) +! write(*,'(1p,10e10.2)') qnum_cur(1:ntot_amode) +! end if +#endif + + end if ! (jtsubstep == 1) + + +! do soa + call mam_soaexch_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + dtsubstep, & + temp, pmid, aircon, & + n_mode, & + qgas_cur, qgas_avg, & + qaer_cur, & + qnum_cur, & + qwtr_cur, & + uptkaer ) + + +! do other gases (that are assumed non-volatile) with no time sub-stepping + do igas = nsoa+1, ngas + iaer = igas + qgas_prv(igas) = qgas_cur(igas) + qaer_prv(iaer,1:n_mode) = qaer_cur(iaer,1:n_mode) + end do + + do igas = nsoa+1, ngas + iaer = igas + if ( (igas == igas_hno3) .or. & + (igas == igas_hcl ) ) cycle + + tmpa = sum( uptkaer(igas,1:n_mode) ) + tmp_kxt = tmpa*dtsubstep + tmp_pxt = qgas_netprod_otrproc(igas)*dtsubstep + tmp_q1 = qgas_prv(igas) + ! tmp_q1 = mix-rat at t=tcur + ! tmp_q3 = mix-rat at t=tcur+dtsubstep + ! tmp_q4 = avg mix-rat between t=tcur and t=tcur+dtsubstep + if (tmp_kxt >= 1.0e-20_r8) then + if (tmp_kxt > 0.001_r8) then + tmp_pok = tmp_pxt/tmp_kxt + tmp_q3 = (tmp_q1 - tmp_pok)*exp(-tmp_kxt) + tmp_pok + tmp_q4 = (tmp_q1 - tmp_pok)*(1.0_r8 - exp(-tmp_kxt))/tmp_kxt + tmp_pok + else + tmp_kxt2 = tmp_kxt*tmp_kxt + tmp_q3 = tmp_q1 *(1.0_r8 - tmp_kxt + tmp_kxt2*0.5_r8) & + + tmp_pxt*(1.0_r8 - tmp_kxt*0.5_r8 + tmp_kxt2/6.0_r8) + tmp_q4 = tmp_q1 *(1.0_r8 - tmp_kxt*0.5_r8 + tmp_kxt2/6.0_r8) & + + tmp_pxt*(0.5_r8 - tmp_kxt/6.0_r8 + tmp_kxt2/24.0_r8) + end if + qgas_cur(igas) = tmp_q3 + tmp_qdel_cond = (tmp_q1 + tmp_pxt) - tmp_q3 + qgas_avg(igas) = tmp_q4 + do n = 1, n_mode + if (uptkaer(igas,n) <= 0.0_r8) cycle + tmpc = tmp_qdel_cond*(uptkaer(igas,n)/tmpa) + qaer_cur(iaer,n) = qaer_prv(iaer,n) + tmpc + end do + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( ldiag82 ) then + if (i==1 .and. k==pver .and. igas==igas_h2so4) then + tmp_q2 = tmp_q1 + tmp_pxt + + write(lun82,'(/a,2i5,1p,8e17.9)') 'gasaer - i, k, sum_uprt_so4, qav', & + i, k, tmpa, -1.0 + tmp_q2 = max( 1.0e-30_r8, tmp_q2 ) + write(lun82,'(/a,2i5,1p,8e17.9)') 'gasaer - i, k, q1, q2, q3, q4 ', & + i, k, tmp_q1, tmp_q2, tmp_q3, tmp_q4 + write(lun82,'(/a,2i5,1p,8e17.9)') 'gasaer - i, k, k*t, p*t, p/k, t ', & + i, k, tmp_kxt, tmp_pxt, tmp_pok, dtsubstep, tmp_qdel_cond + end if + end if +#endif + + else + ! tmp_kxt < 1.0e-20_r8 so uptake to aerosols ~= 0.0 + ! in this case, do not bother to update qaer_cur + tmp_q3 = tmp_q1 + tmp_pxt + tmp_q4 = tmp_q1 + tmp_pxt*0.5_r8 + qgas_cur(igas) = tmp_q3 + qgas_avg(igas) = tmp_q4 + end if + end do ! igas + + if ( igas_nh3 > 0 ) then +! do not allow nh4 to exceed 2*so4 (molar basis) + iaer = iaer_nh4 ; igas = igas_nh3 + do n = 1, n_mode + if (uptkaer(igas,n) <= 0.0_r8) cycle + tmpa = qaer_cur(iaer,n) - 2.0_r8*qaer_cur(iaer_so4,n) + if (tmpa > 0.0_r8) then + qaer_cur(iaer,n) = qaer_cur(iaer,n) - tmpa + qgas_cur(igas) = qgas_cur(igas) + tmpa + qgas_avg(igas) = qgas_avg(igas) + tmpa*0.5_r8 + end if + end do + end if + + + return + end subroutine mam_gasaerexch_1subarea + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + subroutine mam_soaexch_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + dtsubstep, & + temp, pmid, aircon, & + n_mode, & + qgas_cur, qgas_avg, & + qaer_cur, & + qnum_cur, & + qwtr_cur, & + uptkaer ) +! +! calculate soa condensation/evaporation for i,k,jsub over time dtsubstep +! + +! uses + use modal_aero_data, only: lptr2_soa_a_amode + + + implicit none + +! arguments + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: i, k ! column and level indices + integer, intent(in) :: jsub ! sub-area index + integer, intent(in) :: latndx, lonndx ! lat and lon indices + integer, intent(in) :: lund ! logical unit for diagnostic output + integer, intent(in) :: n_mode ! current number of modes (including temporary) + + real(r8), intent(in) :: dtsubstep ! current integration timestep (s) + real(r8), intent(in) :: temp ! temperature (K) + real(r8), intent(in) :: pmid ! pressure at model levels (Pa) + real(r8), intent(in) :: aircon ! air molar concentration (kmol/m3) + + real(r8), intent(inout), dimension( 1:max_gas ) :: & + qgas_cur, qgas_avg + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_cur + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qnum_cur + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qwtr_cur + real(r8), intent(in ), dimension( 1:max_gas, 1:max_mode ) :: & + uptkaer + +! local + integer, parameter :: ntot_poaspec = npoa + integer, parameter :: ntot_soaspec = nsoa + + integer :: iaer, igas, ip + integer :: ll + integer :: n, niter, niter_max + integer :: ntot_soamode + + logical, parameter :: flag_pcarbon_opoa_frac_zero = .true. + + logical :: skip_soamode(max_mode) ! true if this mode does not have soa + + real(r8), dimension( 1:max_gas ) :: & + qgas_prv + + real(r8), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_prv + + real(r8) :: uptkaer_soag_tmp(nsoa,max_mode) + + real(r8), parameter :: a_min1 = 1.0e-20 + real(r8), parameter :: g_min1 = 1.0e-20 + real(r8), parameter :: alpha_astem = 0.05_r8 ! parameter used in calc of time step + real(r8), parameter :: dtsub_fixed = -1.0 ! fixed sub-step for time integration (s) +! real(r8), parameter :: dtsub_fixed = 10.0 ! fixed sub-step for time integration (s) + real(r8), parameter :: rgas = 8.3144_r8 ! gas constant in J/K/mol + + real(r8) :: a_ooa_sum_tmp(max_mode) ! total ooa (=soa+opoa) in a mode + real(r8) :: a_opoa(max_mode) ! oxidized-poa aerosol mixrat (mol/mol at actual mw) + real(r8) :: a_soa(ntot_soaspec,max_mode) ! soa aerosol mixrat (mol/mol at actual mw) + real(r8) :: a_soa_tmp(ntot_soaspec,max_mode) ! temporary soa aerosol mixrat (mol/mol) + real(r8) :: beta(ntot_soaspec,max_mode) ! dtcur*xferrate + real(r8) :: delh_vap_soa(ntot_soaspec) ! delh_vap_soa = heat of vaporization for gas soa (J/mol) + real(r8) :: del_g_soa_tmp(ntot_soaspec) + real(r8) :: dtcur ! current time step (s) + real(r8) :: dtfull ! full time step (s) + real(r8) :: dtmax ! = (dtfull-tcur) + real(r8) :: dtsum_qgas_avg + real(r8) :: g0_soa(ntot_soaspec) ! ambient soa gas equilib mixrat (mol/mol at actual mw) + real(r8) :: g_soa(ntot_soaspec) ! soa gas mixrat (mol/mol at actual mw) + real(r8) :: g_star(ntot_soaspec,max_mode) ! soa gas mixrat that is in equilib + ! with each aerosol mode (mol/mol) + real(r8) :: mw_poa(ntot_poaspec) ! actual molec wght of poa + real(r8) :: mw_soa(ntot_soaspec) ! actual molec wght of soa + real(r8) :: opoa_frac(ntot_poaspec,max_mode) ! fraction of poa that is opoa + real(r8) :: phi(ntot_soaspec,max_mode) ! "relative driving force" + real(r8) :: p0_soa(ntot_soaspec) ! soa gas equilib vapor presssure (atm) + real(r8) :: p0_soa_298(ntot_soaspec) ! p0_soa_298 = soa gas equilib vapor presssure (atm) at 298 k + real(r8) :: sat(ntot_soaspec,max_mode) ! sat(m,ll) = g0_soa(ll)/a_ooa_sum_tmp(m) = g_star(m,ll)/a_soa(m,ll) + ! used by the numerical integration scheme -- it is not a saturation rato! + real(r8) :: tcur ! current integration time (from 0 s) + + real(r8) :: tmpa, tmpb, tmpc + + real(r8) :: tot_soa(ntot_soaspec) ! g_soa + sum( a_soa(:) ) + + +! calc ntot_soamode = "last" mode on which soa is allowed to condense + ntot_soamode = 0 + do n = 1, ntot_amode + if (n == nufi) cycle + if (mode_aging_optaa(n) > 0) ntot_soamode = n + if (lptr2_soa_a_amode(n,1) > 0) ntot_soamode = n + end do +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( i*k == top_lev .and. ldiagd1 ) write(lund,'(/a,5i5)') & + 'ntot_amode, ntot_amode_extd, n_mode, ntot_soamode', & + ntot_amode, ntot_amode_extd, n_mode, ntot_soamode +#endif + + opoa_frac = 0.1_r8 +! for primary carbon mode, set opoa_frac=0 for consistency with older code +! (this could be changed) + if ( flag_pcarbon_opoa_frac_zero ) then + if (npca > 0) opoa_frac(:,npca) = 0.0_r8 + end if + + delh_vap_soa = 156.0e3 +! delh_vap_soa = 30.0e3 ! 11-jun-2012 + p0_soa_298 = 1.0e-10 + +! calc ambient equilibrium soa gas + do ll = 1, ntot_soaspec + p0_soa(ll) = p0_soa_298(ll) * & + exp( -(delh_vap_soa(ll)/rgas)*((1.0/temp)-(1.0/298.0)) ) + g0_soa(ll) = 1.01325e5*p0_soa(ll)/pmid + end do + + niter_max = 1000 + niter = 0 + dtfull = dtsubstep + tcur = 0.0 + dtcur = 0.0 + phi(:,:) = 0.0 + g_star(:,:) = 0.0 + g_soa(:) = 0.0 + a_opoa(:) = 0.0 + a_soa(:,:) = 0.0 + +! +! main integration loop -- does multiple substeps to reach dtfull +! + qgas_avg(1:nsoa) = 0.0_r8 + dtsum_qgas_avg = 0.0_r8 + +time_loop: & + do while (tcur < dtfull-1.0e-3_r8 ) + + niter = niter + 1 + if (niter > niter_max) exit + + +! set qxxx_prv to be current value + qgas_prv(1:nsoa) = qgas_cur(1:nsoa) + qaer_prv = qaer_cur +! qaer_num = qnum_cur + + +! determine which modes have non-zero transfer rates +! and are involved in the soa gas-aerosol transfer +! for diameter = 1 nm and number = 1 #/cm3, xferrate ~= 1e-9 s-1 + do n = 1, ntot_soamode + skip_soamode(n) = .true. + do ll = 1, ntot_soaspec + if (uptkaer(ll,n) > 1.0e-15_r8) then + uptkaer_soag_tmp(ll,n) = uptkaer(ll,n) + skip_soamode(n) = .false. + else + uptkaer_soag_tmp(ll,n) = 0.0_r8 + end if + end do + end do + +! load incoming soag and soaa into temporary arrays +! force things to be non-negative +! calc tot_soa(ll) +! calc a_opoa (always slightly >0) +! +! *** questions *** +! > why not use qgas and qaer instead of g_soa and a_soa +! > why not calc the following on every substep because +! nuc and coag may change things: +! skip)soamode, uptkaer_soag_tmp, tot_soa, a_opoa +! > include gasprod for soa ?? +! > create qxxx_bgn = qxxx_cur at the very beginning (is it needed) +! + do ll = 1, ntot_soaspec + g_soa(ll) = max( qgas_prv(ll), 0.0_r8 ) + tot_soa(ll) = g_soa(ll) + do n = 1, ntot_soamode + if ( skip_soamode(n) ) cycle + a_soa(ll,n) = max( qaer_prv(ll,n), 0.0_r8 ) + tot_soa(ll) = tot_soa(ll) + a_soa(ll,n) + end do + end do + + do n = 1, ntot_soamode + if ( skip_soamode(n) ) cycle + a_opoa(n) = 0.0_r8 + do ll = 1, ntot_poaspec + a_opoa(n) = a_opoa(n) + opoa_frac(ll,n) * max( qaer_prv(iaer_pom+ll-1,n), 0.0_r8 ) + end do + end do + + +! determine time step + tmpa = 0.0 ! time integration parameter for all soa species + do n = 1, ntot_soamode + if ( skip_soamode(n) ) cycle + a_ooa_sum_tmp(n) = a_opoa(n) + sum( a_soa(1:ntot_soaspec,n) ) + end do + do ll = 1, ntot_soaspec + tmpb = 0.0 ! time integration parameter for a single soa species + do n = 1, ntot_soamode + if ( skip_soamode(n) ) cycle + sat(ll,n) = g0_soa(ll)/max( a_ooa_sum_tmp(n), a_min1 ) + g_star(ll,n) = sat(ll,n)*a_soa(ll,n) + phi(ll,n) = (g_soa(ll) - g_star(ll,n))/max( g_soa(ll), g_star(ll,n), g_min1 ) + tmpb = tmpb + uptkaer_soag_tmp(ll,n)*abs(phi(ll,n)) + end do + tmpa = max( tmpa, tmpb ) + end do + + if (dtsub_fixed > 0.0_r8) then + dtcur = dtsub_fixed + tcur = tcur + dtcur + else + dtmax = dtfull-tcur + if (dtmax*tmpa <= alpha_astem) then +! here alpha_astem/tmpa >= dtmax, so this is final substep + dtcur = dtmax + tcur = dtfull + else + dtcur = alpha_astem/tmpa + tcur = tcur + dtcur + end if + end if + + +! step 1 - for modes where soa is condensing, estimate "new" a_soa(ll,n) +! using an explicit calculation with "old" g_soa +! and g_star(ll,n) calculated using "old" a_soa(ll,n) +! do this to get better estimate of "new" a_soa(ll,n) and sat(ll,n) + do n = 1, ntot_soamode + if ( skip_soamode(n) ) cycle + do ll = 1, ntot_soaspec + ! first ll loop calcs a_soa_tmp(ll,n) & a_ooa_sum_tmp + a_soa_tmp(ll,n) = a_soa(ll,n) + beta(ll,n) = dtcur*uptkaer_soag_tmp(ll,n) + del_g_soa_tmp(ll) = g_soa(ll) - g_star(ll,n) + if (del_g_soa_tmp(ll) > 0.0_r8) then + a_soa_tmp(ll,n) = a_soa(ll,n) + beta(ll,n)*del_g_soa_tmp(ll) + end if + end do + a_ooa_sum_tmp(n) = a_opoa(n) + sum( a_soa_tmp(1:ntot_soaspec,n) ) + do ll = 1, ntot_soaspec + ! second ll loop calcs sat & g_star + if (del_g_soa_tmp(ll) > 0.0_r8) then + sat(ll,n) = g0_soa(ll)/max( a_ooa_sum_tmp(n), a_min1 ) + g_star(ll,n) = sat(ll,n)*a_soa_tmp(ll,n) ! this just needed for diagnostics + end if + end do + end do + + +! step 2 - implicit in g_soa and semi-implicit in a_soa, +! with g_star(ll,n) calculated semi-implicitly + do ll = 1, ntot_soaspec + tmpa = 0.0 + tmpb = 0.0 + do n = 1, ntot_soamode + if ( skip_soamode(n) ) cycle + tmpa = tmpa + a_soa(ll,n)/(1.0_r8 + beta(ll,n)*sat(ll,n)) + tmpb = tmpb + beta(ll,n)/(1.0_r8 + beta(ll,n)*sat(ll,n)) + end do + + g_soa(ll) = (tot_soa(ll) - tmpa)/(1.0_r8 + tmpb) + g_soa(ll) = max( 0.0_r8, g_soa(ll) ) + do n = 1, ntot_soamode + if ( skip_soamode(n) ) cycle + a_soa(ll,n) = (a_soa(ll,n) + beta(ll,n)*g_soa(ll))/ & + (1.0_r8 + beta(ll,n)*sat(ll,n)) + end do + end do + + +! update mix ratios for soa species + do igas = 1, nsoa + iaer = igas + qgas_cur(igas) = g_soa(igas) + tmpc = qgas_cur(igas) - qgas_prv(igas) + qgas_avg(igas) = qgas_avg(igas) + dtcur*(qgas_prv(igas) + 0.5_r8*tmpc) + do n = 1, ntot_soamode + qaer_cur(iaer,n) = a_soa(iaer,n) + tmpc = qaer_cur(iaer,n) - qaer_prv(iaer,n) + end do + end do + + + dtsum_qgas_avg = dtsum_qgas_avg + dtcur + + end do time_loop + +! convert qgas_avg from sum_over[ qgas*dt_cut ] to an average + do igas = 1, nsoa + qgas_avg(igas) = max( 0.0_r8, qgas_avg(igas)/dtsum_qgas_avg ) + end do + + + return + end subroutine mam_soaexch_1subarea + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + subroutine mam_rename_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + iscldy_subarea, & + mtoo_renamexf, & + n_mode, & + qnum_cur, & + qaer_cur, qaer_del_grow4rnam, & + qwtr_cur, & + qnumcw_cur, & + qaercw_cur, qaercw_del_grow4rnam ) + +#if ( defined CAM_VERSION_IS_ACME ) + use shr_spfn_mod, only: erfc => shr_spfn_erfc ! acme version of cam +#else + use error_function, only: erfc ! mozart-mosaic version of cam +#endif + + logical, intent(in) :: iscldy_subarea ! true if sub-area is cloudy + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: i, k ! column and level indices + integer, intent(in) :: jsub ! sub-area index + integer, intent(in) :: latndx, lonndx ! lat and lon indices + integer, intent(in) :: lund ! logical unit for diagnostic output + integer, intent(in) :: mtoo_renamexf(max_mode) + integer, intent(in) :: n_mode ! current number of modes (including temporary) + + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qnum_cur + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_cur + real(r8), intent(in ), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_del_grow4rnam + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qwtr_cur + + real(r8), intent(inout), optional, dimension( 1:max_mode ) :: & + qnumcw_cur + real(r8), intent(inout), optional, dimension( 1:max_aer, 1:max_mode ) :: & + qaercw_cur + real(r8), intent(in ), optional, dimension( 1:max_aer, 1:max_mode ) :: & + qaercw_del_grow4rnam + + +! !DESCRIPTION: +! computes TMR (tracer mixing ratio) tendencies for "mode renaming" +! during a continuous growth process +! currently this transfers number and mass (and surface) from the aitken +! to accumulation mode after gas condensation or stratiform-cloud +! aqueous chemistry +! (convective cloud aqueous chemistry not yet implemented) +! +! !REVISION HISTORY: +! + +! local variables + integer :: iaer + integer :: mfrm, mtoo + integer :: n, npair + + integer, parameter :: ldiag1 = 0 + + real(r8), parameter :: frelax = 27.0_r8 + real(r8), parameter :: onethird = 1.0_r8/3.0_r8 + + real(r8) :: deldryvol_a(ntot_amode) + real(r8) :: deldryvol_c(ntot_amode) + real(r8) :: dp_belowcut(max_mode) + real(r8) :: dp_cut(max_mode) + real(r8) :: dgn_aftr, dgn_xfer + real(r8) :: dgn_t_new, dgn_t_old, dgn_t_oldaa + real(r8) :: dryvol_t_del, dryvol_t_new + real(r8) :: dryvol_t_old, dryvol_t_oldaa, dryvol_t_oldbnd + real(r8) :: dryvol_a(ntot_amode) + real(r8) :: dryvol_c(ntot_amode) + real(r8) :: dryvol_smallest(ntot_amode) + real(r8) :: factoraa(ntot_amode) + real(r8) :: factoryy(ntot_amode) + real(r8) :: lndp_cut(max_mode) + real(r8) :: lndgn_new, lndgn_old + real(r8) :: lndgv_new, lndgv_old + real(r8) :: num_t_old, num_t_oldbnd + real(r8) :: tailfr_volnew, tailfr_volold + real(r8) :: tailfr_numnew, tailfr_numold + real(r8) :: tmpa, tmpb, tmpd + real(r8) :: tmp_alnsg2(max_mode) + real(r8) :: v2nhirlx(ntot_amode), v2nlorlx(ntot_amode) + real(r8) :: xfercoef, xfertend + real(r8) :: xferfrac_vol, xferfrac_num, xferfrac_max + real(r8) :: yn_tail, yv_tail + + + xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps + +! calculate variable used in the renamingm mode" of each renaming pair +! also compute dry-volume change during the continuous growth process + npair = 0 + do n = 1, ntot_amode + mtoo = mtoo_renamexf(n) + if (mtoo <= 0) cycle + + npair = npair + 1 + mfrm = n + factoraa(mfrm) = (pi/6.)*exp(4.5*(alnsg_aer(mfrm)**2)) + factoraa(mtoo) = (pi/6.)*exp(4.5*(alnsg_aer(mtoo)**2)) + factoryy(mfrm) = sqrt( 0.5 )/alnsg_aer(mfrm) +! dryvol_smallest is a very small volume mixing ratio (m3-AP/kmol-air) +! used for avoiding overflow. it corresponds to dp = 1 nm +! and number = 1e-5 #/mg-air ~= 1e-5 #/cm3-air + dryvol_smallest(mfrm) = 1.0e-25 +! v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax +! v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax + v2nlorlx(mfrm) = ( 1._r8 / ( (pi/6._r8)* & + (dgnumlo_aer(mfrm)**3._r8)*exp(4.5_r8*alnsg_aer(mfrm)**2._r8) ) ) * frelax + v2nhirlx(mfrm) = ( 1._r8 / ( (pi/6._r8)* & + (dgnumhi_aer(mfrm)**3._r8)*exp(4.5_r8*alnsg_aer(mfrm)**2._r8) ) ) / frelax + + tmp_alnsg2(mfrm) = 3.0 * (alnsg_aer(mfrm)**2) + dp_cut(mfrm) = sqrt( & + dgnum_aer(mfrm)*exp(1.5*(alnsg_aer(mfrm)**2)) * & + dgnum_aer(mtoo)*exp(1.5*(alnsg_aer(mtoo)**2)) ) + lndp_cut(mfrm) = log( dp_cut(mfrm) ) + dp_belowcut(mfrm) = 0.99*dp_cut(mfrm) + end do + if (npair <= 0) return + +! compute aerosol dry-volume for the "from mode" of each renaming pair +! also compute dry-volume change during the continuous growth process + do n = 1, ntot_amode + mtoo = mtoo_renamexf(n) + if (mtoo <= 0) cycle + + tmpa = 0.0_r8 ; tmpb = 0.0_r8 + do iaer = 1, naer +! fac_m2v_aer converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) + tmpa = tmpa + qaer_cur(iaer,n)*fac_m2v_aer(iaer) + tmpb = tmpb + qaer_del_grow4rnam(iaer,n)*fac_m2v_aer(iaer) + end do + dryvol_a(n) = tmpa-tmpb ! dry volume before growth + deldryvol_a(n) = tmpb ! change to dry volume due to growth + + if ( iscldy_subarea ) then + tmpa = 0.0_r8 ; tmpb = 0.0_r8 + do iaer = 1, naer +! fac_m2v_aer converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) + tmpa = tmpa + qaercw_cur(iaer,n)*fac_m2v_aer(iaer) + tmpb = tmpb + qaercw_del_grow4rnam(iaer,n)*fac_m2v_aer(iaer) + end do + dryvol_c(n) = tmpa-tmpb + deldryvol_c(n) = tmpb + end if ! ( iscldy_subarea ) then + + end do + + +! +! loop over renaming pairs +! +mainloop1_ipair: do n = 1, ntot_amode + + mfrm = n + mtoo = mtoo_renamexf(n) + if (mtoo <= 0) cycle mainloop1_ipair + +! dryvol_t_old is the old total (a+c) dry-volume for the "from" mode +! in m^3-AP/kmol-air +! dryvol_t_new is the new total dry-volume +! (old/new = before/after the continuous growth) +! num_t_old is total number in particles/kmol-air + if ( iscldy_subarea ) then + dryvol_t_old = dryvol_a(mfrm) + dryvol_c(mfrm) + dryvol_t_del = deldryvol_a(mfrm) + deldryvol_c(mfrm) + num_t_old = (qnum_cur(mfrm) + qnumcw_cur(mfrm)) + else + dryvol_t_old = dryvol_a(mfrm) + dryvol_t_del = deldryvol_a(mfrm) + num_t_old = qnum_cur(mfrm) + end if + dryvol_t_new = dryvol_t_old + dryvol_t_del + +! no renaming if dryvol_t_new ~ 0 or dryvol_t_del ~ 0 + if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_ipair + dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) ) + if (rename_method_optaa .ne. 40) then + if (dryvol_t_del .le. 1.0e-6*dryvol_t_oldbnd) cycle mainloop1_ipair + end if + + num_t_old = max( 0.0_r8, num_t_old ) + dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) ) + num_t_oldbnd = min( dryvol_t_oldbnd*v2nlorlx(mfrm), num_t_old ) + num_t_oldbnd = max( dryvol_t_oldbnd*v2nhirlx(mfrm), num_t_oldbnd ) + +! no renaming if dgnum < "base" dgnum, + dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird + if (dgn_t_new .le. dgnum_aer(mfrm)) cycle mainloop1_ipair + +! compute new fraction of number and mass in the tail (dp > dp_cut) + lndgn_new = log( dgn_t_new ) + lndgv_new = lndgn_new + tmp_alnsg2(mfrm) + yn_tail = (lndp_cut(mfrm) - lndgn_new)*factoryy(mfrm) + yv_tail = (lndp_cut(mfrm) - lndgv_new)*factoryy(mfrm) + tailfr_numnew = 0.5_r8*erfc( yn_tail ) + tailfr_volnew = 0.5_r8*erfc( yv_tail ) + +! compute old fraction of number and mass in the tail (dp > dp_cut) + dgn_t_old = & + (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird + dgn_t_oldaa = dgn_t_old + dryvol_t_oldaa = dryvol_t_old + + if (rename_method_optaa .eq. 40) then + if (dgn_t_old .gt. dp_belowcut(mfrm)) then + ! this revised volume corresponds to dgn_t_old == dp_belowcut, and same number conc + dryvol_t_old = dryvol_t_old * (dp_belowcut(mfrm)/dgn_t_old)**3 + dgn_t_old = dp_belowcut(mfrm) + end if + if ((dryvol_t_new-dryvol_t_old) .le. 1.0e-6_r8*dryvol_t_oldbnd) cycle mainloop1_ipair + else if (dgn_t_new .ge. dp_cut(mfrm)) then +! if dgn_t_new exceeds dp_cut, use the minimum of dgn_t_old and +! dp_belowcut to guarantee some transfer + dgn_t_old = min( dgn_t_old, dp_belowcut(mfrm) ) + end if + lndgn_old = log( dgn_t_old ) + lndgv_old = lndgn_old + tmp_alnsg2(mfrm) + yn_tail = (lndp_cut(mfrm) - lndgn_old)*factoryy(mfrm) + yv_tail = (lndp_cut(mfrm) - lndgv_old)*factoryy(mfrm) + tailfr_numold = 0.5_r8*erfc( yn_tail ) + tailfr_volold = 0.5_r8*erfc( yv_tail ) + +! transfer fraction is difference between new and old tail-fractions +! transfer fraction for number cannot exceed that of mass + tmpa = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_old + if (tmpa .le. 0.0_r8) cycle mainloop1_ipair + + xferfrac_vol = min( tmpa, dryvol_t_new )/dryvol_t_new + xferfrac_vol = min( xferfrac_vol, xferfrac_max ) + xferfrac_num = tailfr_numnew - tailfr_numold + xferfrac_num = max( 0.0_r8, min( xferfrac_num, xferfrac_vol ) ) +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( ldiag98 ) write(lun98,'(/a,2i3,1p,10e11.3)') & + 'rename i,k, xf n/v', i, k, xferfrac_num, xferfrac_vol +#endif + +#if ( defined( CAMBOX_NEVER_ACTIVATE_THIS ) ) +! diagnostic output start ---------------------------------------- + if (ldiag1 > 0) then + icol_diag = -1 + if ((lonndx(i) == 37) .and. (latndx(i) == 23)) icol_diag = i + if ((i == icol_diag) .and. (mod(k-1,5) == 0)) then + ! write(lund,97010) fromwhere, nstep, lchnk, i, k, ipair + write(lund,97010) fromwhere, nstep, latndx(i), lonndx(i), k, ipair + write(lund,97020) 'drv olda/oldbnd/old/new/del', & + dryvol_t_oldaa, dryvol_t_oldbnd, dryvol_t_old, dryvol_t_new, dryvol_t_del + write(lund,97020) 'num old/oldbnd, dgnold/new ', & + num_t_old, num_t_oldbnd, dgn_t_old, dgn_t_new + write(lund,97020) 'tailfr v_old/new, n_old/new', & + tailfr_volold, tailfr_volnew, tailfr_numold, tailfr_numnew + tmpa = max(1.0d-10,xferfrac_vol) / max(1.0d-10,xferfrac_num) + dgn_xfer = dgn_t_new * tmpa**onethird + tmpa = max(1.0d-10,(1.0d0-xferfrac_vol)) / & + max(1.0d-10,(1.0d0-xferfrac_num)) + dgn_aftr = dgn_t_new * tmpa**onethird + write(lund,97020) 'xferfrac_v/n; dgn_xfer/aftr', & + xferfrac_vol, xferfrac_num, dgn_xfer, dgn_aftr + !97010 format( / 'RENAME ', a, ' nx,lc,i,k,ip', i8, 4i4 ) + 97010 format( / 'RENAME ', a, ' nx,lat,lon,k,ip', i8, 4i4 ) + 97020 format( a, 6(1pe15.7) ) + end if + end if ! (ldiag1 > 0) +! diagnostic output end ------------------------------------------ +#endif + + +! +! compute changes to number and species masses +! + tmpd = qnum_cur(mfrm)*xferfrac_num + qnum_cur(mfrm) = qnum_cur(mfrm) - tmpd + qnum_cur(mtoo) = qnum_cur(mtoo) + tmpd + do iaer = 1, naer + tmpd = qaer_cur(iaer,mfrm)*xferfrac_vol + qaer_cur(iaer,mfrm) = qaer_cur(iaer,mfrm) - tmpd + qaer_cur(iaer,mtoo) = qaer_cur(iaer,mtoo) + tmpd + end do ! iaer + + if ( iscldy_subarea ) then + tmpd = qnumcw_cur(mfrm)*xferfrac_num + qnumcw_cur(mfrm) = qnumcw_cur(mfrm) - tmpd + qnumcw_cur(mtoo) = qnumcw_cur(mtoo) + tmpd + do iaer = 1, naer + tmpd = qaercw_cur(iaer,mfrm)*xferfrac_vol + qaercw_cur(iaer,mfrm) = qaercw_cur(iaer,mfrm) - tmpd + qaercw_cur(iaer,mtoo) = qaercw_cur(iaer,mtoo) + tmpd + end do ! iaer + end if ! ( iscldy_subarea ) then + + +#if ( defined( CAMBOX_NEVER_ACTIVATE_THIS ) ) +! diagnostic output start ---------------------------------------- + if (ldiag1 > 0) then + if ((i == icol_diag) .and. (mod(k-1,5) == 0)) then + if (lstooa .gt. 0) then + write(lund,'(a,i4,2(2x,a),1p,10e14.6)') 'RENAME qdels', iq, & + cnst_name(lsfrma+loffset), cnst_name(lstooa+loffset), & + deltat*dqdt(i,k,lsfrma), deltat*(dqdt(i,k,lsfrma) - xfertend), & + deltat*dqdt(i,k,lstooa), deltat*(dqdt(i,k,lstooa) + xfertend) + else + write(lund,'(a,i4,2(2x,a),1p,10e14.6)') 'RENAME qdels', iq, & + cnst_name(lsfrma+loffset), cnst_name(lstooa+loffset), & + deltat*dqdt(i,k,lsfrma), deltat*(dqdt(i,k,lsfrma) - xfertend) + end if + end if + end if +! diagnostic output end ------------------------------------------ +#endif + + + end do mainloop1_ipair + + + return + end subroutine mam_rename_1subarea + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + subroutine mam_newnuc_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + deltat, & + temp, pmid, aircon, & + zmid, pblh, relhum, & + uptkrate_h2so4, del_h2so4_gasprod, del_h2so4_aeruptk, & + n_mode, & + qgas_cur, qgas_avg, & + qnum_cur, & + qaer_cur, & + qwtr_cur, & + dnclusterdt ) + +! uses + use chem_mods, only: adv_mass + + use modal_aero_newnuc, only: & + mer07_veh02_nuc_mosaic_1box, qh2so4_cutoff + + implicit none + +! arguments + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: i, k ! column and level indices + integer, intent(in) :: jsub ! sub-area index + integer, intent(in) :: latndx, lonndx ! lat and lon indices + integer, intent(in) :: lund ! logical unit for diagnostic output + integer, intent(in) :: n_mode ! current number of modes (including temporary) + + real(r8), intent(in) :: deltat ! model timestep (s) + real(r8), intent(in) :: temp ! temperature (K) + real(r8), intent(in) :: pmid ! pressure at model levels (Pa) + real(r8), intent(in) :: aircon ! air molar concentration (kmol/m3) + real(r8), intent(in) :: zmid ! midpoint height above surface (m) + real(r8), intent(in) :: pblh ! pbl height (m) + real(r8), intent(in) :: relhum ! relative humidity (0-1) + real(r8), intent(in) :: uptkrate_h2so4 + real(r8), intent(in) :: del_h2so4_gasprod + real(r8), intent(in) :: del_h2so4_aeruptk + + real(r8), intent(inout) :: dnclusterdt ! cluster nucleation rate (#/m3/s) + + real(r8), intent(inout), dimension( 1:max_gas ) :: & + qgas_cur + real(r8), intent(in ), dimension( 1:max_gas ) :: & + qgas_avg + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qnum_cur + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_cur + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qwtr_cur + +! DESCRIPTION: +! computes changes due to aerosol nucleation (new particle formation) +! treats both nucleation and subsequent growth of new particles +! to aitken mode size +! uses the following parameterizations +! vehkamaki et al. (2002) parameterization for binary +! homogeneous nucleation (h2so4-h2o) plus +! kerminen and kulmala (2002) parameterization for +! new particle loss during growth to aitken size +! +! REVISION HISTORY: +! R.Easter 2007.09.14: Adapted from MIRAGE2 code and CMAQ V4.6 code +! + +! local variables + integer, parameter :: ldiag1=-1, ldiag2=-1, ldiag3=-1, ldiag4=-1 + integer, parameter :: newnuc_method_flagaa = 11 +! integer, parameter :: newnuc_method_flagaa = 12 + ! 1=merikanto et al (2007) ternary 2=vehkamaki et al (2002) binary + ! 11=merikanto ternary + first-order boundary layer + ! 12=merikanto ternary + second-order boundary layer + + integer :: itmp + integer :: l + integer :: ldiagveh02 + integer :: m + + real(r8) :: dens_nh4so4a + real(r8) :: dmdt_ait, dmdt_aitsv1, dmdt_aitsv2, dmdt_aitsv3 + real(r8) :: dndt_ait, dndt_aitsv1, dndt_aitsv2, dndt_aitsv3 + real(r8) :: dnh4dt_ait, dso4dt_ait + real(r8) :: dpnuc + real(r8) :: dplom_mode(1), dphim_mode(1) + real(r8) :: mass1p + real(r8) :: mass1p_aithi, mass1p_aitlo + real(r8) :: qh2so4_cur, qh2so4_avg, qh2so4_del + real(r8) :: qnh3_cur, qnh3_del, qnh4a_del + real(r8) :: qnuma_del + real(r8) :: qso4a_del + real(r8) :: relhumnn + real(r8) :: tmpa, tmpb, tmpc + real(r8) :: tmp_q2, tmp_q3 + real(r8) :: tmp_q_del + real(r8) :: tmp_frso4, tmp_uptkrate + + character(len=1) :: tmpch1, tmpch2, tmpch3 + + +! begin + dnclusterdt = 0.0_r8 + +! qh2so4_cur = current qh2so4, after aeruptk +! qh2so4_avg = average qh2so4 over time-step + qh2so4_cur = qgas_cur(igas_h2so4) + + if ( (gaexch_h2so4_uptake_optaa == 1) .and. & + (newnuc_h2so4_conc_optaa == 1) ) then +! estimate qh2so4_avg using the method in standard cam5.2 modal_aero_newnuc + + ! skip if h2so4 vapor < qh2so4_cutoff + if (qh2so4_cur <= qh2so4_cutoff) goto 80000 + + tmpa = max( 0.0_r8, del_h2so4_gasprod ) + tmp_q3 = qh2so4_cur + ! tmp_q2 = qh2so4 before aeruptk + ! (note tmp_q3, tmp_q2 both >= 0.0) + tmp_q2 = tmp_q3 + max( 0.0_r8, -del_h2so4_aeruptk ) + + ! tmpb = log( tmp_q2/tmp_q3 ) BUT with some checks added + if (tmp_q2 <= tmp_q3) then + tmpb = 0.0_r8 + else + tmpc = tmp_q2 * exp( -20.0_r8 ) + if (tmp_q3 <= tmpc) then + tmp_q3 = tmpc + tmpb = 20.0_r8 + else + tmpb = log( tmp_q2/tmp_q3 ) + end if + end if + ! d[ln(qh2so4)]/dt (1/s) from uptake (condensation) to aerosol + tmp_uptkrate = tmpb/deltat + +! qh2so4_avg = estimated average qh2so4 +! when production & loss are done simultaneously + if (tmpb <= 0.1_r8) then + qh2so4_avg = tmp_q3*(1.0_r8 + 0.5_r8*tmpb) - 0.5_r8*tmpa + else + tmpc = tmpa/tmpb + qh2so4_avg = (tmp_q3 - tmpc)*((exp(tmpb)-1.0_r8)/tmpb) + tmpc + end if + else +! use qh2so4_avg and first-order loss rate calculated in mam_gasaerexch_1subarea + qh2so4_avg = qgas_avg(igas_h2so4) + tmp_uptkrate = uptkrate_h2so4 + end if + + if (qh2so4_avg <= qh2so4_cutoff) goto 80000 + + if (igas_nh3 > 0) then + qnh3_cur = max( 0.0_r8, qgas_cur(igas_nh3) ) + else + qnh3_cur = 0.0_r8 + end if + +! dry-diameter limits for "grown" new particles + dplom_mode(1) = exp( 0.67_r8*log(dgnumlo_aer(nait)) & + + 0.33_r8*log(dgnum_aer(nait)) ) + dphim_mode(1) = dgnumhi_aer(nait) + +! mass1p_... = mass (kg) of so4 & nh4 in a single particle of diameter ... +! (assuming same dry density for so4 & nh4) +! mass1p_aitlo - dp = dplom_mode(1) +! mass1p_aithi - dp = dphim_mode(1) + tmpa = dens_so4a_host*pi/6.0_r8 + mass1p_aitlo = tmpa*(dplom_mode(1)**3) + mass1p_aithi = tmpa*(dphim_mode(1)**3) + +! limit RH to between 0.1% and 99% + relhumnn = max( 0.01_r8, min( 0.99_r8, relhum ) ) + + +! call ... routine to get nucleation rates + ldiagveh02 = -1 +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if (ldiag2 > 0) then + if ((lonndx == 37) .and. (latndx == 23)) then + if ((k >= 24) .or. (mod(k,4) == 0)) then + ldiagveh02 = +1 + write(lund,'(/a,i8,3i4,f8.2,1p,4e10.2)') & + 'veh02 call - nstep,lat,lon,k; tk,rh,p,cair', & + nstep, latndx, lonndx, k, & + temp, relhumnn, pmid, aircon*1.0e3_r8 + ! output aircon at (mol/m3) + end if + end if + end if ! (ldiag2 > 0) +#endif + + call mer07_veh02_nuc_mosaic_1box( & + newnuc_method_flagaa, & + deltat, temp, relhumnn, pmid, & + zmid, pblh, & + qh2so4_cur, qh2so4_avg, qnh3_cur, tmp_uptkrate, & + mw_so4a_host, & + 1, 1, dplom_mode, dphim_mode, & + itmp, qnuma_del, qso4a_del, qnh4a_del, & + qh2so4_del, qnh3_del, dens_nh4so4a, & + ldiagveh02, dnclusterdt ) +!---------------------------------------------------------------------- +! subr mer07_veh02_nuc_mosaic_1box( & +! newnuc_method_flagaa, & +! dtnuc, temp_in, rh_in, press_in, & +! qh2so4_cur, qh2so4_avg, qnh3_cur, h2so4_uptkrate, & +! nsize, maxd_asize, dplom_sect, dphim_sect, & +! isize_nuc, qnuma_del, qso4a_del, qnh4a_del, & +! qh2so4_del, qnh3_del, dens_nh4so4a ) +! +!! subr arguments (in) +! real(r8), intent(in) :: dtnuc ! nucleation time step (s) +! real(r8), intent(in) :: temp_in ! temperature, in k +! real(r8), intent(in) :: rh_in ! relative humidity, as fraction +! real(r8), intent(in) :: press_in ! air pressure (pa) +! +! real(r8), intent(in) :: qh2so4_cur, qh2so4_avg +! ! gas h2so4 mixing ratios (mol/mol-air) +! real(r8), intent(in) :: qnh3_cur ! gas nh3 mixing ratios (mol/mol-air) +! ! qxxx_cur = current value (after gas chem and condensation) +! ! qxxx_avg = estimated average value (for simultaneous source/sink calcs) +! real(r8), intent(in) :: h2so4_uptkrate ! h2so4 uptake rate to aerosol (1/s) + +! +! integer, intent(in) :: nsize ! number of aerosol size bins +! integer, intent(in) :: maxd_asize ! dimension for dplom_sect, ... +! real(r8), intent(in) :: dplom_sect(maxd_asize) ! dry diameter at lower bnd of bin (m) +! real(r8), intent(in) :: dphim_sect(maxd_asize) ! dry diameter at upper bnd of bin (m) +! +!! subr arguments (out) +! integer, intent(out) :: isize_nuc ! size bin into which new particles go +! real(r8), intent(out) :: qnuma_del ! change to aerosol number mixing ratio (#/mol-air) +! real(r8), intent(out) :: qso4a_del ! change to aerosol so4 mixing ratio (mol/mol-air) +! real(r8), intent(out) :: qnh4a_del ! change to aerosol nh4 mixing ratio (mol/mol-air) +! real(r8), intent(out) :: qh2so4_del ! change to gas h2so4 mixing ratio (mol/mol-air) +! real(r8), intent(out) :: qnh3_del ! change to gas nh3 mixing ratio (mol/mol-air) +! ! aerosol changes are > 0; gas changes are < 0 +! real(r8), intent(out) :: dens_nh4so4a ! dry-density of the new nh4-so4 aerosol mass (kg/m3) +!---------------------------------------------------------------------- + + +! convert qnuma_del from (#/mol-air) to (#/kmol-air) + qnuma_del = qnuma_del*1.0e3_r8 +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( ldiag97 ) then + write(lun97,'(/a,2i5,1p,3e11.3,2x,3e11.3)') & + 'newnuc - i, k, qavg s/n, uprt, rh 1/2', & + i, k, qh2so4_avg, qh2so4_cur, qnh3_cur, & + tmp_uptkrate, relhum, relhumnn + write(lun97,'( a,10x,1p,3e11.3,2x,3e11.3)') & + ' del qn, qso4a, qnh4a ', & + qnuma_del, qso4a_del, qnh4a_del + end if +#endif + +! number nuc rate (#/kmol-air/s) from number nuc amt + dndt_ait = qnuma_del/deltat + +! fraction of mass nuc going to so4 + tmpa = qso4a_del*mw_so4a_host + if (igas_nh3 > 0) then + tmpb = tmpa + qnh4a_del*mw_nh4a_host + tmp_frso4 = max( tmpa, 1.0e-35_r8 )/max( tmpb, 1.0e-35_r8 ) + else + tmpb = tmpa + tmp_frso4 = 1.0_r8 + end if + +! mass nuc rate (kg/kmol-air/s) from mass nuc amts + dmdt_ait = max( 0.0_r8, (tmpb/deltat) ) + + dndt_aitsv1 = dndt_ait + dmdt_aitsv1 = dmdt_ait + dndt_aitsv2 = 0.0 + dmdt_aitsv2 = 0.0 + dndt_aitsv3 = 0.0 + dmdt_aitsv3 = 0.0 + tmpch1 = ' ' + tmpch2 = ' ' + + if (dndt_ait < 1.0e2) then +! ignore newnuc if number rate < 100 #/kmol-air/s ~= 0.3 #/mg-air/d + dndt_ait = 0.0 + dmdt_ait = 0.0 + tmpch1 = 'A' + + else + dndt_aitsv2 = dndt_ait + dmdt_aitsv2 = dmdt_ait + tmpch1 = 'B' + +! mirage2 code checked for complete h2so4 depletion here, +! but this is now done in mer07_veh02_nuc_mosaic_1box + mass1p = dmdt_ait/dndt_ait + dndt_aitsv3 = dndt_ait + dmdt_aitsv3 = dmdt_ait + +! apply particle size constraints + if (mass1p < mass1p_aitlo) then +! reduce dndt to increase new particle size + dndt_ait = dmdt_ait/mass1p_aitlo + tmpch1 = 'C' + else if (mass1p > mass1p_aithi) then +! reduce dmdt to decrease new particle size + dmdt_ait = dndt_ait*mass1p_aithi + tmpch1 = 'E' + end if + end if + +! *** apply adjustment factor to avoid unrealistically high +! aitken number concentrations in mid and upper troposphere + dndt_ait = dndt_ait * newnuc_adjust_factor_dnaitdt + dmdt_ait = dmdt_ait * newnuc_adjust_factor_dnaitdt + + tmp_q_del = dndt_ait*deltat + qnum_cur( nait) = qnum_cur( nait) + tmp_q_del + +! dso4dt_ait, dnh4dt_ait are (kmol/kmol-air/s) + dso4dt_ait = dmdt_ait*tmp_frso4/mw_so4a_host + dnh4dt_ait = dmdt_ait*(1.0_r8 - tmp_frso4)/mw_nh4a_host + + if (dso4dt_ait > 0.0_r8) then + tmp_q_del = dso4dt_ait*deltat + qaer_cur( iaer_so4,nait) = qaer_cur( iaer_so4,nait) + tmp_q_del + + tmp_q_del = min( tmp_q_del, qgas_cur(igas_h2so4) ) + qgas_cur( igas_h2so4) = qgas_cur( igas_h2so4) - tmp_q_del + end if + + if ((igas_nh3 > 0) .and. (dnh4dt_ait > 0.0_r8)) then + tmp_q_del = dnh4dt_ait*deltat + qaer_cur( iaer_nh4,nait) = qaer_cur( iaer_nh4,nait) + tmp_q_del + + tmp_q_del = min( tmp_q_del, qgas_cur(igas_nh3) ) + qgas_cur( igas_nh3) = qgas_cur( igas_nh3) - tmp_q_del + end if + +!! temporary diagnostic +! if (ldiag3 > 0) then +! if ((dndt_ait /= 0.0_r8) .or. (dmdt_ait /= 0.0_r8)) then +! write(lund,'(3a,1x,i7,3i5,1p,5e12.4)') & +! 'newnucxx', tmpch1, tmpch2, nstep, lchnk, i, k, & +! dndt_ait, dmdt_ait, cldx +!! call endrun( 'modal_aero_newnuc_sub' ) +! end if +! end if + + +#if ( defined( CAMBOX_NEVER_ACTIVATE_THIS ) ) +! diagnostic output start ---------------------------------------- + if (ldiag4 > 0) then + if ((lonndx == 37) .and. (latndx == 23)) then + if ((k >= 24) .or. (mod(k,4) == 0)) then + write(lund,97010) nstep, latndx, lonndx, k, temp, aircon*1.0e3_r8 + write(lund,97020) 'pmid ', & + pmid + write(lund,97030) 'qv,qvsw, rh_av, rh_clr ', & + qv(i,k), qvswtr, relhumav, relhum + write(lund,97020) 'h2so4_cur, _av, nh3_cur', & + qh2so4_cur, qh2so4_avg, qnh3_cur + write(lund,97020) 'del_h2so4_gasprod, _aeruptk ', & + del_h2so4_gasprod(i,k), del_h2so4_aeruptk(i,k), & + tmp_uptkrate*3600.0 + write(lund,97020) ' ' + write(lund,97050) 'tmpch1, tmpch2 ', tmpch1, tmpch2 + write(lund,97020) 'dndt_, dmdt_aitsv1 ', & + dndt_aitsv1, dmdt_aitsv1 + write(lund,97020) 'dndt_, dmdt_aitsv2 ', & + dndt_aitsv2, dmdt_aitsv2 + write(lund,97020) 'dndt_, dmdt_aitsv3 ', & + dndt_aitsv3, dmdt_aitsv3 + write(lund,97020) 'dndt_, dmdt_ait ', & + dndt_ait, dmdt_ait + write(lund,97020) 'dso4dt_, dnh4dt_ait ', & + dso4dt_ait, dnh4dt_ait + write(lund,97020) 'qso4a_del, qh2so4_del ', & + qso4a_del, qh2so4_del + write(lund,97020) 'qnh4a_del, qnh3_del ', & + qnh4a_del, qnh3_del + write(lund,97020) 'dqdt(h2so4), (nh3) ', & + dqdt(i,k,l_h2so4), dqdt(i,k,l_nh3) + write(lund,97020) 'dqdt(so4a), (nh4a), (numa) ', & + dqdt(i,k,lso4ait), dqdt(i,k,lnh4ait), dqdt(i,k,lnumait) + + dpnuc = 0.0 + if (dndt_aitsv1 > 1.0e-5) dpnuc = (6.0*dmdt_aitsv1/ & + (pi*dens_so4a_host*dndt_aitsv1))**0.3333333 + if (dpnuc > 0.0) then + write(lund,97020) 'dpnuc, dp_aitlo, _aithi ', & + dpnuc, dplom_mode(1), dphim_mode(1) + write(lund,97020) 'mass1p, mass1p_aitlo, _aithi ', & + mass1p, mass1p_aitlo, mass1p_aithi + end if + +97010 format( / 'NEWNUC nstep,lat,lon,k,tk,cair', i8, 3i4, f8.2, 1pe12.4 ) +97020 format( a, 1p, 6e12.4 ) +97030 format( a, 1p, 2e12.4, 0p, 5f10.6 ) +97040 format( 29x, 1p, 6e12.4 ) +97050 format( a, 2(3x,a) ) + end if ! ((k >= 24) .or. (mod(k,4) == 0)) + end if ! ((lonndx == 37) .and. (latndx == 23)) + end if ! (ldiag4 > 0) +! diagnostic output end ------------------------------------------ +#endif + + +80000 continue + + + return + end subroutine mam_newnuc_1subarea + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + subroutine mam_coag_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + deltat, & + temp, pmid, aircon, & + dgn_a, dgn_awet, wetdens, & + n_mode, & + qnum_cur, & + qaer_cur, qaer_del_coag_in, & + qwtr_cur ) + +! coag between aitken, pcarbon, and accum modes +! inter-modal coag of ultrafine mode + +! uses + use modal_aero_coag, only: getcoags_wrapper_f + + implicit none + +! arguments + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: i, k ! column and level indices + integer, intent(in) :: jsub ! sub-area index + integer, intent(in) :: latndx, lonndx ! lat and lon indices + integer, intent(in) :: lund ! logical unit for diagnostic output + integer, intent(in) :: n_mode ! current number of modes (including temporary) + + real(r8), intent(in) :: deltat ! model timestep (s) + real(r8), intent(in) :: temp ! temperature at model levels (K) + real(r8), intent(in) :: pmid ! pressure at layer center (Pa) + real(r8), intent(in) :: aircon ! air molar concentration (kmol/m3) + real(r8), intent(in) :: dgn_a(max_mode) + real(r8), intent(in) :: dgn_awet(max_mode) + ! dry & wet geo. mean dia. (m) of number distrib. + real(r8), intent(in) :: wetdens(max_mode) + ! interstitial aerosol wet density (kg/m3) + ! dry & wet geo. mean dia. (m) of number distrib. + + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qnum_cur + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_cur + real(r8), intent(out), dimension( 1:max_aer, 1:max_agepair ) :: & + qaer_del_coag_in + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qwtr_cur + +! local variables + integer :: iaer, ip + integer :: modefrm, modetoo + integer :: n + + real(r8), parameter :: epsilonx1 = epsilon( 1.0_r8 ) + real(r8), parameter :: epsilonx2 = epsilonx1*2.0_r8 + + real(r8) :: tmp1, tmp2, tmp3, tmp4 + real(r8) :: tmpa, tmpb, tmpc, tmpn + real(r8) :: tmp_dq, tmp_xf + real(r8) :: xbetaij2i, xbetaij2j, xbetaii2, xbetajj2 + real(r8) :: ybetaij0(max_coagpair), ybetaij3(max_coagpair), & + ybetaii0(max_coagpair), ybetajj0(max_coagpair) + + real(r8), dimension( 1:max_mode ) :: & + qnum_tmpa, qnum_tmpb, qnum_tmpc + real(r8), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_tmpa, qaer_tmpb, qaer_tmpc + +! DESCRIPTION: + + qnum_tmpa = max( 0.0_r8, qnum_cur ) + qaer_tmpa = max( 0.0_r8, qaer_cur ) + qnum_tmpb = qnum_tmpa + qaer_tmpb = qaer_tmpa + qaer_del_coag_in = 0.0_r8 + +! +! compute coagulation rates using cmaq "fast" method +! (based on E. Whitby's approximation approach) +! here subr. arguments are all in mks unit +! + lun15n = 149 + i +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( ldiag15n ) write(lun15n,'(//a,3i5,1p,e11.3)') 'coag - nstep,i,k', nstep, i, k, aircon +#endif + + do ip = 1, n_coagpair + modefrm = modefrm_coagpair(ip) + modetoo = modetoo_coagpair(ip) + +! call getcoags_wrapper_f( & +! airtemp, airprs, & +! dgatk, dgacc, & +! sgatk, sgacc, & +! xxlsgat, xxlsgac, & +! pdensat, pdensac, & +! betaij0, betaij2i, betaij2j, betaij3, & +! betaii0, betaii2, betajj0, betajj2 ) + call getcoags_wrapper_f( & + temp, pmid, & + dgn_awet(modefrm), dgn_awet(modetoo), & + sigmag_aer(modefrm), sigmag_aer(modetoo), & + alnsg_aer(modefrm), alnsg_aer(modetoo), & + wetdens(modefrm), wetdens(modetoo), & + ybetaij0(ip), xbetaij2i, xbetaij2j, ybetaij3(ip), & + ybetaii0(ip), xbetaii2, ybetajj0(ip), xbetajj2 ) + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) +! short diagnostics for coag coefficients + if ( ldiag15n ) write(lun15n,'(a,i5,1p,10e11.3)') 'ip, ybeta ', ip, & + ybetaij0(ip), ybetaij3(ip), ybetaii0(ip), ybetajj0(ip) + +! long diagnostics for coag coefficients +! if ( ldiag15n ) then +! if ( ip == 1 ) then +! write(lun15n,'(a,1p,2e12.4)') 'temp, pmid', temp, pmid +! write(lun15n,'(a/a/a/a/a)') & +! 'modefrm, modetoo, ip, ', & +! 'ybetaij0(ip), ybetaij3(ip), ybetaii0(ip), ybetajj0(ip), [m3/s]', & +! 'dgn_awet(modefrm)*1.0e6, dgn_awet(modetoo)*1.0e6, ', & +! 'sigmag_aer(modefrm), sigmag_aer(modetoo), ', & +! 'wetdens(modefrm)*1.0e-3, wetdens(modetoo)*1.0e-3 ' +! end if +! write(lun15n,'(a,2i3,i5,1p,4e11.3, 0p,2x,2f7.4,2(2x,2f6.3))') & +! 'ip, ybeta ', modefrm, modetoo, ip, & +! ybetaij0(ip), ybetaij3(ip), ybetaii0(ip), ybetajj0(ip), & +! dgn_awet(modefrm)*1.0e6, dgn_awet(modetoo)*1.0e6, & +! sigmag_aer(modefrm), sigmag_aer(modetoo), & +! wetdens(modefrm)*1.0e-3, wetdens(modetoo)*1.0e-3 +! end if +#endif + + ! convert coag coefficients from (m3/s) to (kmol-air/s) + ybetaij0(ip) = ybetaij0(ip)*aircon + ybetaij3(ip) = ybetaij3(ip)*aircon + ybetaii0(ip) = ybetaii0(ip)*aircon + ybetajj0(ip) = ybetajj0(ip)*aircon + end do ! ip + + +! first calculate changes to number +! use the following order because +! accum number loss depends on accum number +! pcarbon number loss depends on pcarbon and accum number +! maccum number loss depends on maccum, pcarbon, and accum number +! aitken number loss depends on aitken, maccum, pcarbon, and accum number +! maitken number loss depends on maitken, aitken, maccum, pcarbon, and accum number +! the average number concencentrations (over current time step) +! of other modes can thus be used to calculate the number loss of a mode + +! accum mode number loss - analytical solution + tmpa = max( 0.0_r8, deltat*ybetajj0(1) ) + qnum_tmpb(nacc) = qnum_tmpa(nacc) / & + ( 1.0_r8 + ybetajj0(1)*deltat*qnum_tmpa(nacc) ) + qnum_tmpc(nacc) = (qnum_tmpa(nacc) + qnum_tmpb(nacc))*0.5_r8 + +! pcarbon mode number loss - approximate analytical solution +! using average number conc. for accum mode + if (npca > 0) then + tmpa = max( 0.0_r8, deltat*ybetaij0(2)*qnum_tmpc(nacc) ) + tmpb = max( 0.0_r8, deltat*ybetaii0(2) ) + tmpn = qnum_tmpa(npca) + if (tmpa < 1.0e-5_r8) then + qnum_tmpb(npca) = tmpn / & + ( 1.0_r8 + (tmpa+tmpb*tmpn)*(1.0_r8 + 0.5_r8*tmpa) ) + else + tmpc = exp(-tmpa) + qnum_tmpb(npca) = tmpn*tmpc / & + ( 1.0_r8 + (tmpb*tmpn/tmpa)*(1.0_r8-tmpc) ) + end if + qnum_tmpc(npca) = (qnum_tmpa(npca) + qnum_tmpb(npca))*0.5_r8 + end if + +! marine-organics accum mode number loss - approximate analytical solution +! using average number conc. for accum and pcarbon modes + if (nmacc > 0) then + tmpa = ybetaij0( 9)*qnum_tmpc(nacc) & + + ybetaij0(10)*qnum_tmpc(npca) + tmpa = max( 0.0_r8, deltat*tmpa ) + tmpb = max( 0.0_r8, deltat*ybetaii0(9) ) + tmpn = qnum_tmpa(nmacc) + if (tmpa < 1.0e-5_r8) then + qnum_tmpb(nmacc) = tmpn / & + ( 1.0_r8 + (tmpa+tmpb*tmpn)*(1.0_r8 + 0.5_r8*tmpa) ) + else + tmpc = exp(-tmpa) + qnum_tmpb(nmacc) = tmpn*tmpc / & + ( 1.0_r8 + (tmpb*tmpn/tmpa)*(1.0_r8-tmpc) ) + end if + qnum_tmpc(nmacc) = (qnum_tmpa(nmacc) + qnum_tmpb(nmacc))*0.5_r8 + end if + +! aitken mode number loss - approximate analytical solution +! using average number conc. for accum, pcarbon, and marine-org accum modes + tmpa = ybetaij0(1)*qnum_tmpc(nacc) + if (npca > 0) tmpa = tmpa + ybetaij0(3)*qnum_tmpc(npca) + if (nmacc > 0) tmpa = tmpa + ybetaij0(4)*qnum_tmpc(nmacc) + tmpa = max( 0.0_r8, deltat*tmpa ) + tmpb = max( 0.0_r8, deltat*ybetaii0(1) ) + tmpn = qnum_tmpa(nait) + if (tmpa < 1.0e-5_r8) then + qnum_tmpb(nait) = tmpn / & + ( 1.0_r8 + (tmpa+tmpb*tmpn)*(1.0_r8 + 0.5_r8*tmpa) ) + else + tmpc = exp(-tmpa) + qnum_tmpb(nait) = tmpn*tmpc / & + ( 1.0_r8 + (tmpb*tmpn/tmpa)*(1.0_r8-tmpc) ) + end if + qnum_tmpc(nait) = (qnum_tmpa(nait) + qnum_tmpb(nait))*0.5_r8 + +! marine-organics aitken mode number loss - approximate analytical solution +! using average number conc. for accum, pcarbon, aitken, and marine-org accum modes + if (nmait > 0) then + tmpa = ybetaij0(5)*qnum_tmpc(nacc) + ybetaij0(7)*qnum_tmpc(nait) & + + ybetaij0(6)*qnum_tmpc(npca) + ybetaij0(8)*qnum_tmpc(nmacc) + tmpa = max( 0.0_r8, deltat*tmpa ) + tmpb = max( 0.0_r8, deltat*ybetaii0(5) ) + tmpn = qnum_tmpa(nmait) + if (tmpa < 1.0e-5_r8) then + qnum_tmpb(nmait) = tmpn / & + ( 1.0_r8 + (tmpa+tmpb*tmpn)*(1.0_r8 + 0.5_r8*tmpa) ) + else + tmpc = exp(-tmpa) + qnum_tmpb(nmait) = tmpn*tmpc / & + ( 1.0_r8 + (tmpb*tmpn/tmpa)*(1.0_r8-tmpc) ) + end if + qnum_tmpc(nmait) = (qnum_tmpa(nmait) + qnum_tmpb(nmait))*0.5_r8 + end if + + +! now calculate mass transfers between modes +! the transfer amounts are calculated using as an exponential decay of +! the initial mass concentrations, +! where the decay rate is calculated using the average (over time step) +! number concentrations for each mode +! the mass transfer calculations are first-order accurate in time, +! because the mass transferred out of a mode does not +! include any mass transferred in during the time step +! with this approach, the ordering is not important, but the mass transfer +! calculations are done in the reverse order of the number loss calculations + +! mass transfer out of marine-organics aitken mode +! uses average number conc. for accum, aitken, pcarbon, and marine-org accum modes + if (nmait > 0) then + tmp1 = max( 0.0_r8, ybetaij3(5)*qnum_tmpc(nacc) ) + tmp2 = max( 0.0_r8, ybetaij3(6)*qnum_tmpc(npca) ) + tmp3 = max( 0.0_r8, ybetaij3(7)*qnum_tmpc(nait) ) + tmp4 = max( 0.0_r8, ybetaij3(8)*qnum_tmpc(nmacc) ) + tmpa = tmp1 + tmp2 + tmp3 + tmp4 + tmpc = deltat*tmpa + if (tmpc > epsilonx2) then + ! calc coag change only when it is not ~= zero + tmp_xf = 1.0_r8 - exp(-tmpc) + tmp2 = tmp2/tmpa + tmp3 = tmp3/tmpa + tmp4 = tmp4/tmpa + tmp1 = 1.0_r8 - (tmp2 + tmp3 + tmp4) + do iaer = 1, naer + tmp_dq = tmp_xf*qaer_tmpa(iaer,nmait) + qaer_tmpb(iaer,nmait) = qaer_tmpb(iaer,nmait) - tmp_dq + qaer_tmpb(iaer,nacc ) = qaer_tmpb(iaer,nacc ) + tmp_dq*tmp1 + qaer_tmpb(iaer,npca ) = qaer_tmpb(iaer,npca ) + tmp_dq*tmp2 + qaer_tmpb(iaer,nait ) = qaer_tmpb(iaer,nait ) + tmp_dq*tmp3 + qaer_tmpb(iaer,nmacc) = qaer_tmpb(iaer,nmacc) + tmp_dq*tmp4 + qaer_del_coag_in(iaer,i_agepair_pca ) & + = qaer_del_coag_in(iaer,i_agepair_pca ) + tmp_dq*tmp2 + qaer_del_coag_in(iaer,i_agepair_macc) & + = qaer_del_coag_in(iaer,i_agepair_macc) + tmp_dq*tmp4 + end do + end if + end if + +! (ip == 2) modefrm = npca ; modetoo = nacc +! (ip == 1) modefrm = nait ; modetoo = nacc +! (ip == 3) modefrm = nait ; modetoo = npca +! (ip == 4) modefrm = nait ; modetoo = nmacc +! (ip == 5) modefrm = nmait ; modetoo = nacc +! (ip == 6) modefrm = nmait ; modetoo = npca +! (ip == 7) modefrm = nmait ; modetoo = nait +! (ip == 8) modefrm = nmait ; modetoo = nmacc +! (ip == 9) modefrm = nmacc ; modetoo = nacc +! (ip ==10) modefrm = nmacc ; modetoo = npca + +! mass transfer out of aitken mode +! uses average number conc. for accum, pcarbon, and marine-org accum modes + tmp1 = max( 0.0_r8, ybetaij3(1)*qnum_tmpc(nacc) ) + if (nmacc > 0) then + tmp2 = max( 0.0_r8, ybetaij3(3)*qnum_tmpc(npca) ) + tmp3 = max( 0.0_r8, ybetaij3(4)*qnum_tmpc(nmacc) ) + else if (npca > 0) then + tmp2 = max( 0.0_r8, ybetaij3(3)*qnum_tmpc(npca) ) + tmp3 = 0.0_r8 + else + tmp2 = 0.0_r8 + tmp3 = 0.0_r8 + end if + tmpa = tmp1 + tmp2 + tmp3 + tmpc = deltat*tmpa + if (tmpc > epsilonx2) then + ! calc coag change only when it is not ~= zero + tmp_xf = 1.0_r8 - exp(-tmpc) + if (nmacc > 0) then + tmp2 = tmp2/tmpa + tmp3 = tmp3/tmpa + tmp1 = 1.0_r8 - (tmp2 + tmp3) + do iaer = 1, naer + tmp_dq = tmp_xf*qaer_tmpa(iaer,nait) + qaer_tmpb(iaer,nait) = qaer_tmpb(iaer,nait) - tmp_dq + qaer_tmpb(iaer,nacc) = qaer_tmpb(iaer,nacc) + tmp_dq*tmp1 + qaer_tmpb(iaer,npca) = qaer_tmpb(iaer,npca) + tmp_dq*tmp2 + qaer_tmpb(iaer,nmacc) = qaer_tmpb(iaer,nmacc) + tmp_dq*tmp3 + qaer_del_coag_in(iaer,i_agepair_pca) & + = qaer_del_coag_in(iaer,i_agepair_pca) + tmp_dq*tmp2 + qaer_del_coag_in(iaer,i_agepair_macc) & + = qaer_del_coag_in(iaer,i_agepair_macc) + tmp_dq*tmp3 + end do + else if (npca > 0) then + tmp2 = tmp2/tmpa + tmp1 = 1.0_r8 - tmp2 + do iaer = 1, naer + tmp_dq = tmp_xf*qaer_tmpa(iaer,nait) + qaer_tmpb(iaer,nait) = qaer_tmpb(iaer,nait) - tmp_dq + qaer_tmpb(iaer,nacc) = qaer_tmpb(iaer,nacc) + tmp_dq*tmp1 + qaer_tmpb(iaer,npca) = qaer_tmpb(iaer,npca) + tmp_dq*tmp2 + qaer_del_coag_in(iaer,i_agepair_pca) & + = qaer_del_coag_in(iaer,i_agepair_pca) + tmp_dq*tmp2 + end do + else + do iaer = 1, naer + tmp_dq = tmp_xf*qaer_tmpa(iaer,nait) + qaer_tmpb(iaer,nait) = qaer_tmpb(iaer,nait) - tmp_dq + qaer_tmpb(iaer,nacc) = qaer_tmpb(iaer,nacc) + tmp_dq + end do + end if + end if + +!! old version for 3 and 7 mode only +!! mass transfer out of aitken mode mass +!! uses average number conc. for accum and pcarbon modes +! tmpa = max( 0.0_r8, ybetaij3(1)*qnum_tmpc(nacc) ) +! if (npca > 0) then +! tmpb = max( 0.0_r8, ybetaij3(3)*qnum_tmpc(npca) ) +! tmpc = tmpa + tmpb +! else +! tmpc = tmpa +! end if +! tmpc = deltat*tmpc +! if (tmpc > epsilonx2) then +! ! calc coag change only when it is not ~= zero +! tmp_xf = 1.0_r8 - exp(-tmpc) +! if (npca > 0) then +! tmp2 = tmpb/(tmpa + tmpb + epsilonx1) +! tmp1 = 1.0_r8 - tmp2 +! do iaer = 1, naer +! tmp_dq = tmp_xf*qaer_tmpa(iaer,nait) +! qaer_tmpb(iaer,nait) = qaer_tmpb(iaer,nait) - tmp_dq +! qaer_tmpb(iaer,nacc) = qaer_tmpb(iaer,nacc) + tmp_dq*tmp1 +! qaer_tmpb(iaer,npca) = qaer_tmpb(iaer,npca) + tmp_dq*tmp2 +! qaer_del_coag_in(iaer,i_agepair_pca) & +! = qaer_del_coag_in(iaer,i_agepair_pca) + tmp_dq*tmp2 +! end do +! else +! do iaer = 1, naer +! tmp_dq = tmp_xf*qaer_tmpa(iaer,nait) +! qaer_tmpb(iaer,nait) = qaer_tmpb(iaer,nait) - tmp_dq +! qaer_tmpb(iaer,nacc) = qaer_tmpb(iaer,nacc) + tmp_dq +! end do +! end if +! end if + +! mass transfer out of marine-organics accum mode +! uses average number conc. for accum and pcarbon modes + if (nmacc > 0) then + tmp1 = max( 0.0_r8, ybetaij3( 9)*qnum_tmpc(nacc) ) + tmp2 = max( 0.0_r8, ybetaij3(10)*qnum_tmpc(npca) ) + tmpa = tmp1 + tmp2 + tmpc = deltat*tmpa + if (tmpc > epsilonx2) then + ! calc coag change only when it is not ~= zero + tmp_xf = 1.0_r8 - exp(-tmpc) + tmp2 = tmp2/tmpa + tmp1 = 1.0_r8 - tmp2 + do iaer = 1, naer + tmp_dq = tmp_xf*qaer_tmpa(iaer,nmacc) + qaer_tmpb(iaer,nmacc) = qaer_tmpb(iaer,nmacc) - tmp_dq + qaer_tmpb(iaer,nacc ) = qaer_tmpb(iaer,nacc ) + tmp_dq*tmp1 + qaer_tmpb(iaer,npca ) = qaer_tmpb(iaer,npca ) + tmp_dq*tmp2 + qaer_del_coag_in(iaer,i_agepair_pca ) & + = qaer_del_coag_in(iaer,i_agepair_pca ) + tmp_dq*tmp2 + end do + end if + end if + +! mass transfer out of pcarbon mode +! uses average number conc. for accum mode + if (npca > 0) then + tmpc = max( 0.0_r8, ybetaij3(2)*qnum_tmpc(nacc) ) + tmpc = deltat*tmpc + if (tmpc > epsilonx2) then + tmp_xf = 1.0_r8 - exp(-tmpc) + do iaer = 1, naer + tmp_dq = tmp_xf*qaer_tmpa(iaer,npca) + qaer_tmpb(iaer,npca) = qaer_tmpb(iaer,npca) - tmp_dq + qaer_tmpb(iaer,nacc) = qaer_tmpb(iaer,nacc) + tmp_dq + end do + end if + end if + +! mass transfer out of accum mode - there is no transfer out of this mode + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + if ( ldiag15n ) then +! diagnostics + do n = 1, 3 + write(lun15n,'(a,i5,1p,10e11.3)') 'n, qnum_tmpa/b/c', n, & + qnum_tmpa(n), qnum_tmpc(n), qnum_tmpb(n), & + qnum_tmpb(n)-qnum_tmpa(n), & + 1.0_r8-qnum_tmpb(n)/max(1.0e-5_r8,qnum_tmpa(n)) + end do + do n = 1, 3 + write(lun15n,'(a,i5,1p,10e11.3)') 'n, dgnd/w, densw', n, & + dgn_a(n), dgn_awet(n), wetdens(n) + end do + end if +#endif + + qnum_cur = qnum_tmpb + qaer_cur = qaer_tmpb + + return + end subroutine mam_coag_1subarea + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + subroutine mam_pcarbon_aging_1subarea( & + nstep, lchnk, & + i, k, jsub, & + latndx, lonndx, lund, & + deltat, dgn_a, do_cond, & + n_mode, & + qnum_cur, qnum_del_cond, qnum_del_coag, & + qaer_cur, qaer_del_cond, qaer_del_coag, & + qaer_del_coag_in, & + qwtr_cur ) + +! uses + + implicit none + +! arguments + integer, intent(in) :: nstep ! model time-step number + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: i, k ! column and level indices + integer, intent(in) :: jsub ! sub-area index + integer, intent(in) :: latndx, lonndx ! lat and lon indices + integer, intent(in) :: lund ! logical unit for diagnostic output + integer, intent(in) :: n_mode ! current number of modes (including temporary) + + logical, intent(in) :: do_cond ! true if condensation (gas-aerosol exch) is on + + real(r8), intent(in) :: deltat ! model timestep (s) + real(r8), intent(in), dimension( 1:max_mode ) :: & + dgn_a ! dgnum_dry of mode + + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qnum_cur, qnum_del_cond, qnum_del_coag + real(r8), intent(inout), dimension( 1:max_aer, 1:max_mode ) :: & + qaer_cur, qaer_del_cond, qaer_del_coag + real(r8), intent(inout), dimension( 1:max_aer, 1:max_agepair ) :: & + qaer_del_coag_in +! *** need to add qaer_del_coag_nmoacc_in + real(r8), intent(inout), dimension( 1:max_mode ) :: & + qwtr_cur + +! local variables + integer :: iaer, ipair, itmpa + integer :: nfrm, ntoo + + real(r8) :: fac_volsfc + real(r8) :: tmpa, tmp1, tmp2, tmp3, tmp4 + real(r8) :: vol_core, vol_shell + real(r8) :: xferfrac_max, xferfrac_pcage + + +! +agepair_loop1: & + do ipair = 1, n_agepair + + nfrm = modefrm_agepair(ipair) + ntoo = modetoo_agepair(ipair) + + vol_shell = qaer_cur(iaer_so4,nfrm)*fac_m2v_aer(iaer_so4) + tmp3 = qaer_del_cond(iaer_so4,nfrm) *fac_m2v_aer(iaer_so4) + tmp4 = qaer_del_coag_in(iaer_so4,ipair)*fac_m2v_aer(iaer_so4) + + do iaer = 1, naer +! species that contribute to aging are +! so4 (but it is already done) +! soa, nh4 and no3 +! ncl and cl (when aging_include_seasalt == .true.) + if ( (iaer <= nsoa ) .or. & + (iaer == iaer_nh4) .or. & + (iaer == iaer_no3) .or. & + (iaer == iaer_cl ) ) then + continue + else if (iaer == iaer_ncl) then + if (aging_include_seasalt .eqv. .false.) cycle + else + cycle + end if + + if ( (iaer == iaer_cl ) .and. & + (aging_include_seasalt .eqv. .false.) ) then + ! special case - only include the cl from condensation + tmp1 = max( qaer_del_cond(iaer,nfrm), 0.0_r8 ) + tmp2 = max( qaer_del_coag_in(iaer,ipair), 0.0_r8 ) + tmp1 + if (tmp2 >= 1.0e-35_r8) then + vol_shell = vol_shell + qaer_cur(iaer,nfrm)*fac_m2v_eqvhyg_aer(iaer)*(tmp1/tmp2) + tmp3 = tmp3 + qaer_del_cond(iaer,nfrm)*fac_m2v_eqvhyg_aer(iaer) + end if + else + vol_shell = vol_shell + qaer_cur(iaer,nfrm)*fac_m2v_eqvhyg_aer(iaer) + tmp3 = tmp3 + qaer_del_cond(iaer,nfrm)*fac_m2v_eqvhyg_aer(iaer) + tmp4 = tmp4 + qaer_del_coag_in(iaer,ipair)*fac_m2v_eqvhyg_aer(iaer) + end if + end do + + if ( do_cond ) then + tmp3 = max( tmp3, 1.0e-35_r8 ) + tmp3 = tmp3/(tmp3 + max( tmp4, 0.0_r8 )) + else + tmp3 = 0.0_r8 + end if + tmp4 = 1.0_r8 - tmp3 + + vol_core = 0.0 + do iaer = 1, naer + ! for core volume, only include the mapped species + ! which are primary and low hygroscopicity + if (lmap_aer(iaer,nfrm) > 0) & + vol_core = vol_core + qaer_cur(iaer,nfrm)*fac_m2v_aer(iaer) + end do +! ratio1 = vol_shell/vol_core = +! actual hygroscopic-shell-volume/carbon-core-volume after gas uptake +! ratio2 = 6.0_r8*dr_so4_monolayers_pcage/(dgncur_a*fac_volsfc) +! = (shell-volume corresponding to n_so4_monolayers_pcage)/core-volume +! The 6.0/(dgncur_a*fac_volsfc) = (mode-surface-area/mode-volume) +! Note that vol_shell includes both so4+nh4 AND soa as "equivalent so4", +! The soa_equivso4_factor accounts for the lower hygroscopicity of soa. +! +! Define xferfrac_pcage = min( 1.0, ratio1/ratio2) +! But ratio1/ratio2 == tmp1/tmp2, and coding below avoids possible overflow +! + fac_volsfc = exp( 2.5*(alnsg_aer(nfrm)**2) ) + xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps + + tmp1 = vol_shell*dgn_a(nfrm)*fac_volsfc + tmp2 = max( 6.0_r8*dr_so4_monolayers_pcage*vol_core, 0.0_r8 ) + if (tmp1 >= tmp2) then + xferfrac_pcage = xferfrac_max + else + xferfrac_pcage = min( tmp1/tmp2, xferfrac_max ) + end if + + do iaer = 1, naer + if (lmap_aer(iaer,nfrm) > 0) then + ! species is pom or bc + ! transfer the aged fraction to accum mode + ! include this transfer change in the cond and/or coag change (for mass budget) + tmpa = qaer_cur(iaer,nfrm)*xferfrac_pcage + qaer_cur(iaer,nfrm) = qaer_cur(iaer,nfrm) - tmpa + qaer_cur(iaer,ntoo) = qaer_cur(iaer,ntoo) + tmpa + qaer_del_cond(iaer,nfrm) = qaer_del_cond(iaer,nfrm) - tmpa*tmp3 + qaer_del_cond(iaer,ntoo) = qaer_del_cond(iaer,ntoo) + tmpa*tmp3 + qaer_del_coag(iaer,nfrm) = qaer_del_coag(iaer,nfrm) - tmpa*tmp4 + qaer_del_coag(iaer,ntoo) = qaer_del_coag(iaer,ntoo) + tmpa*tmp4 + else + ! species is soa, so4, or nh4 produced by condensation or coagulation + ! transfer all of it to accum mode + ! also transfer the condensation and coagulation changes + ! to accum mode (for mass budget) + qaer_cur(iaer,ntoo) = qaer_cur(iaer,ntoo) & + + qaer_cur(iaer,nfrm) + qaer_del_cond(iaer,ntoo) = qaer_del_cond(iaer,ntoo) & + + qaer_del_cond(iaer,nfrm) + qaer_del_coag(iaer,ntoo) = qaer_del_coag(iaer,ntoo) & + + qaer_del_coag(iaer,nfrm) + qaer_cur(iaer,nfrm) = 0.0_r8 + qaer_del_cond(iaer,nfrm) = 0.0_r8 + qaer_del_coag(iaer,nfrm) = 0.0_r8 + end if + end do + ! number - transfer the aged fraction to accum mode + ! include this transfer change in the cond and/or coag change (for mass budget) + tmpa = qnum_cur(nfrm)*xferfrac_pcage + qnum_cur(nfrm) = qnum_cur(nfrm) - tmpa + qnum_cur(ntoo) = qnum_cur(ntoo) + tmpa + qnum_del_cond(nfrm) = qnum_del_cond(nfrm) - tmpa*tmp3 + qnum_del_cond(ntoo) = qnum_del_cond(ntoo) + tmpa*tmp3 + qnum_del_coag(nfrm) = qnum_del_coag(nfrm) - tmpa*tmp4 + qnum_del_coag(ntoo) = qnum_del_coag(ntoo) + tmpa*tmp4 + + end do agepair_loop1 + + return + end subroutine mam_pcarbon_aging_1subarea + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + function mean_molecular_speed( temp, rmw ) + implicit none + real(8) :: mean_molecular_speed ! (m/s) + real(8) :: temp ! temperature (K) + real(8) :: rmw ! molec. weight (g/mol) + mean_molecular_speed = 145.5_8 * sqrt(temp/rmw) + return + end function mean_molecular_speed + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + function gas_diffusivity( t_k, p_atm, rmw, vm ) + implicit none + real(8) :: gas_diffusivity ! (m2/s) + real(8) :: t_k ! temperature (K) + real(8) :: p_atm ! pressure (atmospheres) + real(8) :: rmw ! molec. weight (g/mol) + real(8) :: vm ! molar volume (units = ??) + + real(8) :: dgas + + dgas = (1.0e-3_8 * t_k**1.75_8 * sqrt(1./rmw + 0.035_8))/ & + (p_atm * (vm**0.3333333333333333_8 + 2.7189_8)**2) + gas_diffusivity = dgas*1.0e-4_8 + return + end function gas_diffusivity + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + subroutine gas_aer_uptkrates_1box1gas( & + accom, gasdiffus, gasfreepath, & + beta_inp, n_mode, dgncur_awet, lnsg, uptkrate ) +! +! / +! computes uptkrate = | dx dN/dx gas_conden_rate(Dp(x)) +! / +! using Gauss-Hermite quadrature of order nghq=2 +! +! Dp = particle diameter (cm) +! x = ln(Dp) +! dN/dx = log-normal particle number density distribution +! gas_conden_rate(Dp) = 2 * pi * gasdiffus * Dp * F(Kn,ac) +! F(Kn,ac) = Fuchs-Sutugin correction factor +! Kn = Knudsen number +! ac = accomodation coefficient +! + implicit none + + integer, parameter :: r8 = 8 + + integer, intent(in) :: n_mode ! number of modes + + real(r8), intent(in) :: accom ! accomodation coefficient (--) + real(r8), intent(in) :: gasdiffus ! gas diffusivity (m2/s) + real(r8), intent(in) :: gasfreepath ! gas mean free path (m) + real(r8), intent(in) :: beta_inp ! quadrature parameter (--) + real(r8), intent(in) :: dgncur_awet(n_mode) + ! mode-median wet diameter of number distribution (m) + real(r8), intent(in) :: lnsg(n_mode) + ! ln( sigmag ) (--) + real(r8), intent(out) :: uptkrate(n_mode) + ! gas-to-aerosol mass transfer rates (1/s) + ! for number concentration = 1 #/m3 + + +! local + integer, parameter :: nghq = 2 + integer :: i, iq, k, l1, l2, la, n + + real(r8), parameter :: tworootpi = 3.5449077018110320_r8 + real(r8), parameter :: root2 = 1.4142135623730950_r8 + real(r8), parameter :: one = 1.0_r8 + real(r8), parameter :: two = 2.0_r8 + + real(r8) :: accomxp283, accomxp75 + real(r8) :: beta + real(r8) :: const + real(r8) :: dp, dum_m2v + real(r8) :: fuchs_sutugin + real(r8) :: knudsen + real(r8) :: lndp, lndpgn + real(r8) :: sumghq + real(r8) :: tmpa + real(r8), save :: xghq(nghq), wghq(nghq) ! quadrature abscissae and weights + + data xghq / 0.70710678, -0.70710678 / + data wghq / 0.88622693, 0.88622693 / + + + accomxp283 = accom * 0.283_r8 + accomxp75 = accom * 0.75_r8 + +! outermost loop over all modes + do n = 1, n_mode + + lndpgn = log( dgncur_awet(n) ) ! (m) + +! beta = dln(uptake_rate)/dln(dp) +! = 2.0 in free molecular regime, 1.0 in continuum regime +! if uptake_rate ~= a * (dp**beta), then the 2 point quadrature is very accurate + if (abs(beta_inp-1.5_r8) > 0.5_r8) then +! dp = dgncur_awet(n) * exp( 1.5_r8*(lnsg(n)**2) ) + dp = dgncur_awet(n) + knudsen = two*gasfreepath/dp + ! tmpa = dln(fuchs_sutugin)/d(knudsen) + tmpa = one/(one+knudsen) - (two*knudsen + one + accomxp283) / & + ( knudsen*( knudsen + one + accomxp283 ) + accomxp75 ) + beta = one - knudsen*tmpa + beta = max( one, min( two, beta ) ) + else + beta = beta_inp + end if + + const = tworootpi * exp( beta*lndpgn + 0.5_r8*(beta*lnsg(n))**2 ) + +! sum over gauss-hermite quadrature points + sumghq = 0.0 + do iq = 1, nghq + lndp = lndpgn + beta*lnsg(n)**2 + root2*lnsg(n)*xghq(iq) + dp = exp(lndp) + + knudsen = two*gasfreepath/dp + +! fkn = ( 0.75*accomcoef*(1. + xkn) ) / & +! ( xkn**2 + xkn + 0.283*xkn*accomcoef + 0.75*accomcoef ) + fuchs_sutugin = & + ( accomxp75*(one + knudsen) ) / & + ( knudsen*( knudsen + one + accomxp283 ) + accomxp75 ) + + sumghq = sumghq + wghq(iq)*dp*fuchs_sutugin/(dp**beta) + end do + uptkrate(n) = const * gasdiffus * sumghq + + end do ! "do n = 1, ntot_soamode" + + + return + end subroutine gas_aer_uptkrates_1box1gas + + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + subroutine modal_aero_amicphys_init( imozart, species_class ) + +!----------------------------------------------------------------------- +! +! Purpose: +! set do_adjust and do_aitken flags +! create history fields for column tendencies associated with +! modal_aero_calcsize +! +! Author: R. Easter +! +!----------------------------------------------------------------------- + +use cam_history, only : fieldname_len +use cam_logfile, only : iulog +use chem_mods, only : adv_mass +use constituents, only : pcnst, cnst_get_ind, cnst_name +use mo_chem_utls, only : get_spc_ndx +use mo_tracname, only : solsym +use physconst, only : mwdry, mwh2o +use spmd_utils, only : masterproc +use phys_control,only : phys_getopts + +use modal_aero_data, only : & + cnst_name_cw, & + dgnum_amode, dgnumlo_amode, dgnumhi_amode, & + lmassptr_amode, lmassptrcw_amode, & + modeptr_accum, modeptr_aitken, modeptr_pcarbon, modeptr_ufine, & +#if ( defined MODAL_AERO_9MODE ) + modeptr_maccum, modeptr_maitken, & +#endif + nspec_amode, & + numptr_amode, numptrcw_amode, sigmag_amode + +implicit none + +!----------------------------------------------------------------------- +! arguments + integer, intent(in) :: imozart + integer, intent(in) :: species_class(:) + +!----------------------------------------------------------------------- +! local + integer, parameter :: big_neg_int = -999888777 + integer, parameter :: big_pos_int = 999888777 + integer :: iaer, igas, ip, ipair, itmpa + integer :: j, jac, jsoa + integer :: l, l1, l2, lac + integer :: lmz, lmz2, loffset + integer :: l_so4g, l_nh4g, l_msag + integer :: m + integer :: n, na, nb, nc + integer :: nspec + + real(r8) :: tmp1, tmp2 + + character(len=fieldname_len) :: tmpnamea, tmpnameb + character(128) :: msg, fmtaa + character(2) :: tmpch2 + !----------------------------------------------------------------------- + + +#if ( defined( CAMBOX_ACTIVATE_THIS ) ) + ldiag82 = .true. ; lun82 = 82 + ldiag97 = .true. ; lun97 = 97 + ldiag98 = .true. ; lun98 = 98 + ldiag13n = .true. ; lun13n = 130 + ldiag15n = .true. ; lun15n = 150 + ldiagd1 = .true. +#else + ldiag82 = .false. ; lun82 = iulog + ldiag97 = .false. ; lun97 = iulog + ldiag98 = .false. ; lun98 = iulog + ldiag13n = .false. ; lun13n = iulog + ldiag15n = .false. ; lun15n = iulog + ldiagd1 = .false. +#endif + + + call mam_set_lptr2_and_specxxx2 + + + mwuse_soa(:) = 150.0_r8 + mwuse_poa(:) = 150.0_r8 + +! set ngas, name_gas, and igas_xxx +! set naer, name_aerpfx, and iaer_xxx + name_gas = '???' + name_aerpfx = '???' + name_aer = '???' + name_aercw = '???' + name_num = '???' + name_numcw = '???' + + igas_h2so4 = 0 ; igas_nh3 = 0 + iaer_bc = 0 ; iaer_dst = 0 + iaer_ncl = 0 ; iaer_nh4 = 0 + iaer_pom = 0 ; iaer_soa = 0 + iaer_so4 = 0 + iaer_no3 = 0 ; iaer_cl = 0 + iaer_ca = 0 ; iaer_co3 = 0 + iaer_mpoly = 0 ; iaer_mprot = 0 + iaer_mlip = 0 ; iaer_mhum = 0 + iaer_mproc = 0 ; + + if (nsoa == 1) then + name_gas(1) = 'SOAG' + name_aerpfx(1) = 'soa' + else if (nsoa == 2) then + jsoa = 1 ; name_gas(jsoa) = 'SOAGa' ; name_aerpfx(jsoa) = 'soaa' ! jsoa=1 + jsoa = jsoa+1 ; name_gas(jsoa) = 'SOAGb' ; name_aerpfx(jsoa) = 'soab' ! jsoa=2 + else if (nsoa == 6) then + jsoa = 1 ; name_gas(jsoa) = 'SOAGa1' ; name_aerpfx(jsoa) = 'soaa1' ! jsoa=1 + jsoa = jsoa+1 ; name_gas(jsoa) = 'SOAGa2' ; name_aerpfx(jsoa) = 'soaa2' ! jsoa=2 + jsoa = jsoa+1 ; name_gas(jsoa) = 'SOAGa3' ; name_aerpfx(jsoa) = 'soaa3' ! jsoa=3 + jsoa = jsoa+1 ; name_gas(jsoa) = 'SOAGb1' ; name_aerpfx(jsoa) = 'soab1' ! jsoa=4 + jsoa = jsoa+1 ; name_gas(jsoa) = 'SOAGb2' ; name_aerpfx(jsoa) = 'soab2' ! jsoa=5 + jsoa = jsoa+1 ; name_gas(jsoa) = 'SOAGb3' ; name_aerpfx(jsoa) = 'soab3' ! jsoa=6 + else + call endrun( 'modal_aero_amicphys_init ERROR - bad nsoa' ) + end if + ngas = nsoa + naer = nsoa + igas_soa = 1 + iaer_soa = 1 + + ngas = ngas + 1 + name_gas(ngas) = 'H2SO4' + naer = naer + 1 + name_aerpfx(naer) = 'so4' + igas_h2so4 = ngas + iaer_so4 = naer + + if ( (ntot_amode==7) .or. & + (ntot_amode==8) .or. & + (ntot_amode==9) ) then + ngas = ngas + 1 + name_gas(ngas) = 'NH3' + naer = naer + 1 + name_aerpfx(naer) = 'nh4' + igas_nh3 = ngas + iaer_nh4 = naer + end if + +#if ( ( defined MODAL_AERO_7MODE ) && ( defined MOSAIC_SPECIES ) ) + ngas = ngas + 1 + name_gas(ngas) = 'HNO3' + naer = naer + 1 + name_aerpfx(naer) = 'no3' + igas_hno3 = ngas + iaer_no3 = naer + + ngas = ngas + 1 + name_gas(ngas) = 'HCL' + naer = naer + 1 + name_aerpfx(naer) = 'cl' + igas_hcl = ngas + iaer_cl = naer +#endif + + iaer_pom = naer + 1 + if (npoa == 1) then + naer = naer + 1 + name_aerpfx(naer) = 'pom' + else if (npoa == 2) then + naer = naer + 1 + name_aerpfx(naer) = 'poma' + naer = naer + 1 + name_aerpfx(naer) = 'pomb' + else + call endrun( 'modal_aero_amicphys_init ERROR - bad npoa' ) + end if + + iaer_bc = naer + 1 + if (nbc == 1) then + naer = naer + 1 + name_aerpfx(naer) = 'bc' + else if (nbc == 2) then + naer = naer + 1 + name_aerpfx(naer) = 'bca' + naer = naer + 1 + name_aerpfx(naer) = 'bcb' + else + call endrun( 'modal_aero_amicphys_init ERROR - bad nbc' ) + end if + + naer = naer + 1 + name_aerpfx(naer) = 'ncl' + iaer_ncl = naer + naer = naer + 1 + name_aerpfx(naer) = 'dst' + iaer_dst = naer + +#if ( ( defined MODAL_AERO_7MODE ) && ( defined MOSAIC_SPECIES ) ) + naer = naer + 1 + name_aerpfx(naer) = 'ca' + iaer_ca = naer + naer = naer + 1 + name_aerpfx(naer) = 'co3' + iaer_co3 = naer +#endif + + if (ntot_amode==9) then + naer = naer + 1 + name_aerpfx(naer) = 'mpoly' + iaer_mpoly = naer + naer = naer + 1 + name_aerpfx(naer) = 'mprot' + iaer_mprot = naer + naer = naer + 1 + name_aerpfx(naer) = 'mlip' + iaer_mlip = naer + naer = naer + 1 + name_aerpfx(naer) = 'mhum' + iaer_mhum = naer + naer = naer + 1 + name_aerpfx(naer) = 'mproc' + iaer_mproc = naer + end if + + if ((ngas /= max_gas) .or. (naer /= max_aer)) then + write(iulog,'(a,4i10)') 'ngas, max_gas, naer, max_aer', & + ngas, max_gas, naer, max_aer + call endrun( 'modal_aero_amicphys_init ERROR - bad ngas or naer' ) + end if + + lmapcc_all(:) = 0 + +! set gas mapping + loffset = imozart - 1 + lmap_gas(:) = 0 + mwhost_gas(:) = 1.0_r8 + mw_gas(:) = 1.0_r8 + fcvt_gas(:) = 1.0_r8 + + vol_molar_gas = 42.88_r8 ! value for h2so4 + accom_coef_gas = 0.65_r8 ! value for h2so4 + + do igas = 1, ngas + call cnst_get_ind( name_gas(igas), l, .false. ) + if (l < 1 .or. l > pcnst) then + msg = 'modal_aero_amicphys_init ERROR - lmap_gas for ' // name_gas(igas) + call endrun( msg ) + end if + lmz = l - loffset + lmz2 = get_spc_ndx( name_gas(igas) ) + if (lmz /= lmz2 .or. lmz <= 0) then + msg = 'modal_aero_amicphys_init ERROR - lmz /= lmz2 for ' // name_gas(igas) + call endrun( msg ) + end if + lmapcc_all(lmz) = lmapcc_val_gas + lmap_gas(igas) = lmz + + mwhost_gas(igas) = adv_mass(lmz) + mw_gas(igas) = mwhost_gas(igas) + if (igas <= nsoa) mw_gas(igas) = mwuse_soa(igas) + fcvt_gas(igas) = mwhost_gas(igas)/mw_gas(igas) + + if (igas <= nsoa) then + vol_molar_gas(igas) = vol_molar_gas(igas_h2so4) * (mw_gas(igas)/98.0_r8) + else if (igas == igas_nh3) then + vol_molar_gas(igas) = 14.90_r8 + else if (igas == igas_hno3) then + vol_molar_gas(igas) = 24.11_r8 + else if (igas == igas_hcl) then + vol_molar_gas(igas) = 21.48_r8 + end if +! values from mosaic code +! v_molar(iv)= 42.88_r8 ! h2so4 +! v_molar(iv)= 24.11_r8 ! hno3 +! v_molar(iv)= 21.48_r8 ! hcl +! v_molar(iv)= 14.90_r8 ! nh3 +! v_molar(iv)= 65.0_r8 ! soa + + end do ! igas + +! set aerosol mass and number mapping + lmap_aer(:,:) = 0 + lmap_aercw(:,:) = 0 + lmapbb_aer(:,:) = 0 + dens_aer(:) = 1.0_r8 + hygro_aer(:) = 1.0_r8 + mw_aer(:) = 1.0_r8 + fcvt_aer(:) = 1.0_r8 + + lmap_num(:) = 0 + lmap_numcw(:) = 0 + fcvt_num = 1.0_r8 ! leave number mix-ratios unchanged (#/kmol-air) + + fcvt_wtr = mwdry/mwh2o ! convert aerosol water mix-ratios from (kg/kg) to (mol/mol) + + do n = 1, ntot_amode + do lac = 1, 2 + do l1 = 1, nspec_amode(n) + if (lac == 1) then + l = lmassptr_amode(l1,n) + lmz = l - loffset + tmpnamea = cnst_name(l) + tmpch2 = '_a' + else + l = lmassptrcw_amode(l1,n) + lmz = 0 + tmpnamea = cnst_name_cw(l) + tmpch2 = '_c' + end if + iaer = 0 + do j = 1, naer + if (n <= 9) then + write(tmpnameb,'(2a,i1)') trim(name_aerpfx(j)), tmpch2, n + else + write(tmpnameb,'(2a,i2)') trim(name_aerpfx(j)), tmpch2, n + end if + if (tmpnamea == tmpnameb) then + iaer = j + exit + end if + end do + if (iaer <= 0) then + msg = 'modal_aero_amicphys_init ERROR - lmap_aer for ' // tmpnamea + call endrun( msg ) + end if + if (lac == 1) then + name_aer(iaer,n) = tmpnamea + lmz2 = get_spc_ndx( tmpnamea ) + if (lmz /= lmz2 .or. lmz <= 0) then + msg = 'modal_aero_amicphys_init ERROR - lmz /= lmz2 for ' // tmpnamea + call endrun( msg ) + end if + lmapcc_all(lmz) = lmapcc_val_aer + lmap_aer(iaer,n) = l - loffset + lmapbb_aer(iaer,n) = l1 + + dens_aer(iaer) = specdens2_amode(l1,n) + hygro_aer(iaer) = spechygro2(l1,n) + mwhost_aer(iaer) = specmw2_amode(l1,n) + mw_aer(iaer) = mwhost_aer(iaer) + + itmpa = iaer - iaer_pom + 1 + if (iaer <= nsoa) then + mw_aer(iaer) = mwuse_soa(iaer) + else if ((1 <= itmpa) .and. (itmpa <= npoa)) then + mw_aer(iaer) = mwuse_poa(itmpa) + end if + fcvt_aer(iaer) = mwhost_aer(iaer)/mw_aer(iaer) + fac_m2v_aer(iaer) = mw_aer(iaer)/dens_aer(iaer) + else + name_aercw(iaer,n) = tmpnamea + lmap_aercw(iaer,n) = l - loffset + end if + + end do ! l1 + end do ! lac + + lmap_num(n) = numptr_amode(n) - loffset + name_num(n) = cnst_name(numptr_amode(n)) + lmz = lmap_num(n) + lmz2 = get_spc_ndx( name_num(n) ) + if (lmz /= lmz2 .or. lmz <= 0) then + msg = 'modal_aero_amicphys_init ERROR - lmz /= lmz2 for ' // name_num(n) + call endrun( msg ) + end if + lmapcc_all(lmz) = lmapcc_val_num + + lmap_numcw(n) = numptrcw_amode(n) - loffset + name_numcw(n) = cnst_name_cw(numptrcw_amode(n)) + mwhost_num = 1.0_r8 + + end do ! n + + do iaer = 1, naer + fac_eqvso4hyg_aer(iaer) = hygro_aer(iaer)/hygro_aer(iaer_so4) + fac_m2v_eqvhyg_aer(iaer) = fac_m2v_aer(iaer) * fac_eqvso4hyg_aer(iaer) + end do ! naer + + sigmag_aer(:) = 1.8_r8 + sigmag_aer(1:ntot_amode) = sigmag_amode(1:ntot_amode) + alnsg_aer(1:max_mode) = log(sigmag_aer(1:max_mode)) + + dgnum_aer(:) = 3.0e-9_r8 + dgnumlo_aer(:) = 1.0e-9_r8 + dgnumhi_aer(:) = 10.0e-9_r8 + dgnum_aer(1:ntot_amode) = dgnum_amode(1:ntot_amode) + dgnumhi_aer(1:ntot_amode) = dgnumhi_amode(1:ntot_amode) + dgnumlo_aer(1:ntot_amode) = dgnumlo_amode(1:ntot_amode) + + ! converts number geometric_mean diameter to volume-mean diameter + fcvt_dgnum_dvolmean(1:max_mode) = exp( 1.5_r8*(alnsg_aer(1:max_mode)**2) ) + + dens_so4a_host = dens_aer(iaer_so4) + mw_so4a_host = mwhost_aer(iaer_so4) + if (iaer_nh4 > 0) then + mw_nh4a_host = mwhost_aer(iaer_nh4) + else + mw_nh4a_host = mw_so4a_host + end if + + + nacc = modeptr_accum + nait = modeptr_aitken + npca = modeptr_pcarbon + nufi = modeptr_ufine +#if ( defined MODAL_AERO_9MODE ) + nmacc = modeptr_maccum + nmait = modeptr_maitken +#else + nmacc = big_neg_int + nmait = big_neg_int +#endif + if ( nufi <= 0 .and. & + ntot_amode_extd > ntot_amode ) nufi = ntot_amode_extd + +! aging pairs + ipair = 0 + modefrm_agepair(:) = big_neg_int + modetoo_agepair(:) = big_neg_int + mode_aging_optaa(:) = 0 + i_agepair_pca = big_neg_int ; i_agepair_macc = big_neg_int ; i_agepair_mait = big_neg_int ; + if (npca > 0 .and. nacc > 0) then + ipair = ipair + 1 + modefrm_agepair(ipair) = npca + modetoo_agepair(ipair) = nacc + i_agepair_pca = ipair + mode_aging_optaa(npca) = 1 + end if + if (nmacc > 0 .and. nacc > 0) then + ipair = ipair + 1 + modefrm_agepair(ipair) = nmacc + modetoo_agepair(ipair) = nacc + i_agepair_macc = ipair + mode_aging_optaa(nmacc) = 1 + end if + if (nmait > 0 .and. nait > 0) then + ipair = ipair + 1 + modefrm_agepair(ipair) = nmait + modetoo_agepair(ipair) = nait + i_agepair_mait = ipair + mode_aging_optaa(nmait) = 1 + end if + n_agepair = ipair + +! coagulation pairs +! +! mam version modes involved in coagulation # of coag pairs +! ----------- ----------------------------- --------------- +! 3 mode accum, aitken 1 +! 4,7 mode accum, aitken, pcarbon 3 +! 9 mode accum, aitken, pcarbon, maccum, maitken 10 +! (pcarbon = primary carbon) +! (maccum = primary marine-organics accum) +! (maitken = primary marine-organics aitken) +! +! 9 mode -- 5 participating modes and 10 possible coagulation pairs +! 6 possible coagulation pairs involve a smaller and a larger sized mode +! the resulting particle is placed in the larger-sized mode +! aitken + [ accum, pcarbon, maccum ] +! maitken + [ accum, pcarbon, maccum ] +! 4 possible coagulation pairs involve similar sized modes +! the resulting particle is placed in the mode that is aged +! or contains the largest number of species +! pcarbon + accum --> accum (aged) +! maitken + aitken --> aitken (aged) +! maccum + accum --> accum (aged) +! maccum + pcarbon --> pcarbon (largest number of species) +! note that 2 of the coagulation pairs results in aging, so +! aitken + pcarbon --> pcarbon (temporary) --> accum +! aitken + maccum --> maccum (temporary) --> accum +! each mode also has self-coagulation which only affects number + ipair = 0 + modefrm_coagpair(:) = big_neg_int + modetoo_coagpair(:) = big_neg_int + modeend_coagpair(:) = big_neg_int + do ip = 1, 11 + na = big_neg_int ; nb = big_neg_int + nc = big_pos_int + if (ip == 1) then + na = nait ; nb = nacc + else if (ip == 2) then + na = npca ; nb = nacc + else if (ip == 3) then + na = nait ; nb = npca + nc = nacc + else if (ip == 4) then + na = nait ; nb = nmacc + nc = nacc + else if (ip == 5) then + na = nmait ; nb = nacc + else if (ip == 6) then + na = nmait ; nb = npca + else if (ip == 7) then + na = nmait ; nb = nait + else if (ip == 8) then + na = nmait ; nb = nmacc + else if (ip == 9) then + na = nmacc ; nb = nacc + else if (ip == 10) then + na = nmacc ; nb = npca + end if + if (nc == big_pos_int) nc = nb + + if (na < 1 .or. nb < 1 .or. nc < 1) cycle + ipair = ipair + 1 + modefrm_coagpair(ipair) = na + modetoo_coagpair(ipair) = nb + modeend_coagpair(ipair) = nc + end do + n_coagpair = ipair + + +! diagnostics + if ( masterproc ) then + write(iulog,'(/a)') 'modal_aero_amicphys_init start' + + write(iulog,'(/a,i12)') & + 'mdo_gaexch_cldy_subarea ', mdo_gaexch_cldy_subarea + write(iulog,'( a,i12)') & + 'gaexch_h2so4_uptake_optaa ', gaexch_h2so4_uptake_optaa + write(iulog,'( a,i12)') & + 'newnuc_h2so4_conc_optaa ', newnuc_h2so4_conc_optaa + write(iulog,'( a,i12)') & + 'rename_method_optaa ', rename_method_optaa + write(iulog,'( a,1p,e12.4)') & + 'newnuc_adjust_factor_pbl ', newnuc_adjust_factor_pbl + + write(iulog,'(/a56,10i5)') & + 'ngas, max_gas, naer, max_aer', & + ngas, max_gas, naer, max_aer + write(iulog,'(/a56,10i5)') & + 'nsoa, npoa, nbc', & + nsoa, npoa, nbc + write(iulog,'(/a56,10i5)') & + 'igas_soa, igas_h2so4, igas_nh3, igas_hno3, igas_hcl', & + igas_soa, igas_h2so4, igas_nh3, igas_hno3, igas_hcl + write(iulog,'(/a56,10i5)') & + 'iaer_soa, iaer_so4, iaer_nh4, iaer_no3, iaer_cl', & + iaer_soa, iaer_so4, iaer_nh4, iaer_no3, iaer_cl + write(iulog,'(/a56,10i5)') & + 'iaer_pom, iaer_bc, iaer_ncl, iaer_dst, iaer_ca, iaer_co3', & + iaer_pom, iaer_bc, iaer_ncl, iaer_dst, iaer_ca, iaer_co3 + write(iulog,'(/a56,10i5)') & + 'iaer_mpoly, iaer_mprot, iaer_mlip, iaer_mhum, iaer_mproc', & + iaer_mpoly, iaer_mprot, iaer_mlip, iaer_mhum, iaer_mproc + write(iulog,'(/a)') & + 'fac_eqvso4hyg_aer(1:naer)' + write(iulog,'(4(a,1pe10.3,3x))') & + ( name_aerpfx(iaer)(1:6), fac_eqvso4hyg_aer(iaer), iaer=1,naer ) + + write(iulog,'(/a)') 'igas, lmap, name, mwhost, mw, fcvt, accom, vmol' + do igas = 1, ngas + write(iulog,'(2i4,2x,a,2f10.4,1p,3e12.4)') & + igas, lmap_gas(igas), name_gas(igas), & + mwhost_gas(igas), mw_gas(igas), fcvt_gas(igas), & + accom_coef_gas(igas), vol_molar_gas(igas) + end do + + do n = 1, ntot_amode + write(iulog,'(/a,i5)') & + 'iaer, lmap, name, mwhost, mw, fcvt, dens, fac_m2v, hygro for mode', n + write(iulog,'(2i4,2x,a,20x,1p,e12.4)') & + 0, lmap_num(n), name_num(n), fcvt_num + write(iulog,'(2i4,2x,a,20x,1p,e12.4)') & + 0, lmap_numcw(n), name_numcw(n) + do iaer = 1, naer + if (lmap_aer(iaer,n) > 0) then + if (max(mwhost_aer(iaer),mw_aer(iaer)) <= 9999.9999_r8) then + fmtaa = '(2i4,2x,a,2f10.4,1p,5e12.4)' + else + fmtaa = '(2i4,2x,a,2f10.2,1p,5e12.4)' + end if + write(iulog,fmtaa) & + iaer, lmap_aer(iaer,n), name_aer(iaer,n), & + mwhost_aer(iaer), mw_aer(iaer), fcvt_aer(iaer), & + dens_aer(iaer), fac_m2v_aer(iaer), hygro_aer(iaer) + write(iulog,'(2i4,2x,a,2f10.4,1p,4e12.4)') & + iaer, lmap_aercw(iaer,n), name_aercw(iaer,n) + end if + end do + end do ! n + + write(iulog,'(/a)') 'l, lmz, lmapcc_all, species_class, name' + do lmz = 1, gas_pcnst + l = lmz + loffset + j = -99 + if (l <= pcnst) j = species_class(l) + write(iulog,'(4i5,2x,a)') & + lmz+loffset, lmz, lmapcc_all(lmz), j, solsym(lmz) + end do + + end if ! ( masterproc ) + + + call m_a_amicphys_init_history( loffset ) + + + if ( masterproc ) write(iulog,'(/a)') 'modal_aero_amicphys_init end' + + return + end subroutine modal_aero_amicphys_init + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + subroutine mam_set_lptr2_and_specxxx2 +! +! initializes the following +! lptr2_soa_a_amode, lptr2_soa_g_amode, & +! specdens2_amode, spechygro2, specmw2_amode +! when the multiple nbc/npoa/nsoa flavors is implemented, +! this can be done in modal_aero_initialize_data +! + use cam_logfile, only : iulog + use constituents, only : pcnst, cnst_get_ind, cnst_name + + use modal_aero_data, only : & + lspectype_amode, & + lptr_soa_a_amode, lptr2_soa_a_amode, lptr2_soa_g_amode, & + nspec_amode, ntot_amode, & + specdens_amode, spechygro, specmw_amode + + implicit none + + integer :: jsoa + integer :: l1, l2 + integer :: n + + + if (nsoa == 1) then + jsoa = 1 + call cnst_get_ind( 'SOAG', l1, .false. ) + if (l1 < 1 .or. l1 > pcnst) & + call endrun( 'mam_set_lptr2_and_specxxx2 ERROR - no SOAG' ) + lptr2_soa_g_amode(jsoa) = l1 + do n = 1, ntot_amode + lptr2_soa_a_amode(n,jsoa) = lptr_soa_a_amode(n) + end do + else + call endrun( 'mam_set_lptr2_and_specxxx2 ERROR - expecting nsoa = 1' ) + end if + + do n = 1, ntot_amode + do l1 = 1, nspec_amode(n) + l2 = lspectype_amode(l1,n) + specmw2_amode(l1,n) = specmw_amode(l2) + specdens2_amode(l1,n) = specdens_amode(l2) + spechygro2(l1,n) = spechygro(l2) + end do + end do + + + return + end subroutine mam_set_lptr2_and_specxxx2 + + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + subroutine m_a_amicphys_init_history( loffset ) + +!----------------------------------------------------------------------- +! +! Purpose: +! set do_adjust and do_aitken flags +! create history fields for column tendencies associated with +! modal_aero_calcsize +! +! Author: R. Easter +! +!----------------------------------------------------------------------- + +use cam_history, only : addfld, add_default, fieldname_len, phys_decomp +use cam_logfile, only : iulog +use constituents, only : pcnst, cnst_get_ind, cnst_name +use spmd_utils, only : masterproc +use phys_control,only : phys_getopts + +use modal_aero_data, only : & + cnst_name_cw, & + modeptr_accum, modeptr_aitken, modeptr_pcarbon, modeptr_ufine +!use modal_aero_rename + +implicit none + +!----------------------------------------------------------------------- +! arguments + integer, intent(in) :: loffset + +!----------------------------------------------------------------------- +! local + integer :: iaer, igas, ipair, iok + integer :: lmz, lmza, lmzb, lmzc + integer :: m + integer :: n, na, nb, nc + + real(r8) :: tmp1, tmp2 + + character(len=fieldname_len) :: tmpnamea, tmpnameb + character(len=fieldname_len+3) :: fieldname + character(128) :: long_name + character(128) :: msg + character(8) :: unit + character(2) :: tmpch2 + + logical :: history_aerosol ! Output the MAM aerosol tendencies + logical :: history_aerocom ! Output the aerocom history + !----------------------------------------------------------------------- + + + call phys_getopts( history_aerosol_out = history_aerosol ) +#if ( defined CAM_VERSION_IS_ACME ) + history_aerocom = .false. +#else + call phys_getopts( history_aerocom_out = history_aerocom ) +#endif + + +! +! set the do_q_coltendaa +! + do_q_coltendaa(:,:) = .false. + + +! gas-->aer condensation and resulting aging + do igas = 1, ngas + lmz = lmap_gas(igas) + if (lmz <= 0) cycle + do_q_coltendaa(lmz,iqtend_cond) = .true. + iaer = igas + do n = 1, ntot_amode + lmz = lmap_aer(iaer,n) + if (lmz <= 0) cycle + do_q_coltendaa(lmz,iqtend_cond) = .true. + end do ! n + end do ! igas + + do ipair = 1, n_agepair + na = modefrm_agepair(ipair) + nb = modetoo_agepair(ipair) + if (na < 1 .or. nb < 1) cycle + + lmza = lmap_num(na) + lmzb = lmap_num(nb) + do_q_coltendaa(lmza,iqtend_cond) = .true. + do_q_coltendaa(lmzb,iqtend_cond) = .true. + do iaer = 1, naer + lmza = lmap_aer(iaer,na) + lmzb = lmap_aer(iaer,nb) + if (lmza > 0) then + do_q_coltendaa(lmza,iqtend_cond) = .true. + if (lmzb > 0) do_q_coltendaa(lmzb,iqtend_cond) = .true. + end if + end do ! iaer + end do ! ipair + +! define history fields for gas-->aer condensation and resulting aging + do lmz = 1, gas_pcnst + if ( do_q_coltendaa(lmz,iqtend_cond)) then + tmpnamea = cnst_name(lmz+loffset) + fieldname = trim(tmpnamea) // '_sfgaex1' + long_name = trim(tmpnamea) // ' gas-aerosol-exchange primary column tendency' + unit = 'kg/m2/s' + call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) + if ( history_aerosol ) call add_default( fieldname, 1, ' ' ) + if ( masterproc ) write(iulog,'(3(a,3x))') 'gasaerexch addfld', fieldname, unit + end if + end do ! lmz + +! define history fields for 3d soa production for aerocom + do igas = 1, nsoa + lmz = lmap_gas(igas) + if (lmz <= 0) cycle + if ( .not. do_q_coltendaa(lmz,iqtend_cond)) cycle + if ( .not. history_aerocom ) cycle + + tmpnamea = cnst_name(lmz+loffset) + fieldname = trim(tmpnamea) // '_sfgaex3d' + long_name = trim(tmpnamea) // ' gas-aerosol-exchange primary 3d tendency' + unit = 'kg/m2/s' + call addfld( fieldname, unit, pver, 'A', long_name, phys_decomp ) + call add_default( fieldname, 1, ' ' ) + if ( masterproc ) write(iulog,'(3(a,3x),2i5)') & + 'gasaerexch addfld', fieldname, unit, igas, lmz+loffset + end do + + +! renaming during gas-->aer condensation or cloud chemistry + na = modeptr_aitken + nb = modeptr_accum + if (na > 0 .and. nb > 0) then + lmza = lmap_num(na) + lmzb = lmap_num(nb) + do_q_coltendaa(lmza,iqtend_rnam) = .true. + do_q_coltendaa(lmzb,iqtend_rnam) = .true. + lmza = lmap_numcw(na) + lmzb = lmap_numcw(nb) + do_qqcw_coltendaa(lmza,iqqcwtend_rnam) = .true. + do_qqcw_coltendaa(lmzb,iqqcwtend_rnam) = .true. + do iaer = 1, naer + lmza = lmap_aer(iaer,na) + lmzb = lmap_aer(iaer,nb) + if (lmza > 0) then + do_q_coltendaa(lmza,iqtend_rnam) = .true. + if (lmzb > 0) do_q_coltendaa(lmzb,iqtend_rnam) = .true. + end if + lmza = lmap_aercw(iaer,na) + lmzb = lmap_aercw(iaer,nb) + if (lmza > 0) then + do_qqcw_coltendaa(lmza,iqqcwtend_rnam) = .true. + if (lmzb > 0) do_qqcw_coltendaa(lmzb,iqqcwtend_rnam) = .true. + end if + end do ! iaer + end if ! (na > 0 .and. nb > 0) + +! define history fields for renaming during gas-->aer condensation or cloud chemistry + do lmz = 1, gas_pcnst + if ( do_q_coltendaa(lmz,iqtend_rnam)) then + tmpnamea = cnst_name(lmz+loffset) + fieldname = trim(tmpnamea) // '_sfgaex2' + long_name = trim(tmpnamea) // ' gas-aerosol-exchange renaming column tendency' + unit = 'kg/m2/s' + if (tmpnamea(1:4) == 'num_' .or. tmpnamea(1:4) == 'NUM_') unit = '#/m2/s' + call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) + if ( history_aerosol ) call add_default( fieldname, 1, ' ' ) + if ( masterproc ) write(iulog,'(3(a,3x))') 'gasaerexch addfld', fieldname, unit + end if + if ( do_qqcw_coltendaa(lmz,iqqcwtend_rnam)) then + tmpnamea = cnst_name_cw(lmz+loffset) + fieldname = trim(tmpnamea) // '_sfgaex2' + long_name = trim(tmpnamea) // ' gas-aerosol-exchange renaming column tendency' + unit = 'kg/m2/s' + if (tmpnamea(1:4) == 'num_' .or. tmpnamea(1:4) == 'NUM_') unit = '#/m2/s' + call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) + if ( history_aerosol ) call add_default( fieldname, 1, ' ' ) + if ( masterproc ) write(iulog,'(3(a,3x))') 'gasaerexch addfld', fieldname, unit + end if + end do ! lmz + + + +! coagulation + do ipair = 1, n_coagpair + na = modefrm_coagpair(ipair) + nb = modetoo_coagpair(ipair) + nc = modeend_coagpair(ipair) + if (na < 1 .or. nb < 1 .or. nc < 1) cycle + + lmza = lmap_num(na) + lmzb = lmap_num(nb) + lmzc = lmap_num(nc) + do_q_coltendaa(lmza,iqtend_coag) = .true. + do_q_coltendaa(lmzb,iqtend_coag) = .true. + do_q_coltendaa(lmzc,iqtend_coag) = .true. + do iaer = 1, naer + lmza = lmap_aer(iaer,na) + lmzb = lmap_aer(iaer,nb) + lmzc = lmap_aer(iaer,nc) + if (lmza > 0) then + do_q_coltendaa(lmza,iqtend_coag) = .true. + if (lmzc > 0) do_q_coltendaa(lmzc,iqtend_coag) = .true. + end if + if (nb == nc) cycle + if (lmzb > 0) then + do_q_coltendaa(lmzb,iqtend_coag) = .true. + if (lmzc > 0) do_q_coltendaa(lmzc,iqtend_coag) = .true. + end if + end do ! iaer + end do ! ipair + +! define history fields for coagulation + do lmz = 1, gas_pcnst + if ( do_q_coltendaa(lmz,iqtend_coag)) then + tmpnamea = cnst_name(lmz+loffset) + fieldname = trim(tmpnamea) // '_sfcoag1' + long_name = trim(tmpnamea) // ' modal_aero coagulation column tendency' + unit = 'kg/m2/s' + if (tmpnamea(1:4) == 'num_' .or. tmpnamea(1:4) == 'NUM_') unit = '#/m2/s' + call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) + if ( history_aerosol ) call add_default( fieldname, 1, ' ' ) + if ( masterproc ) write(iulog,'(3(a,3x))') 'modal_aero_coag_init addfld', fieldname, unit + end if + end do ! lmz + + +! nucleation + n = modeptr_aitken + do igas = 1, ngas + iok = 0 + if (igas == igas_h2so4) iok = 1 + if (igas == igas_nh3 ) iok = 1 + if (iok <= 0) cycle + lmz = lmap_gas(igas) + if (lmz > 0) then + do_q_coltendaa(lmz,iqtend_nnuc) = .true. + iaer = igas + lmz = lmap_aer(iaer,n) + if (lmz > 0) do_q_coltendaa(lmz,iqtend_nnuc) = .true. + end if + end do ! igas + lmzc = lmap_num(n) + do_q_coltendaa(lmzc,iqtend_nnuc) = .true. + +! define history fields for nucleation + do lmz = 1, gas_pcnst + if ( do_q_coltendaa(lmz,iqtend_nnuc)) then + tmpnamea = cnst_name(lmz+loffset) + fieldname = trim(tmpnamea) // '_sfnnuc1' + long_name = trim(tmpnamea) // ' modal_aero new particle nucleation column tendency' + unit = 'kg/m2/s' + if (tmpnamea(1:4) == 'num_' .or. tmpnamea(1:4) == 'NUM_') unit = '#/m2/s' + call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) + if ( history_aerosol ) call add_default( fieldname, 1, ' ' ) + if ( masterproc ) write(iulog,'(3(a,3x))') 'modal_aero_newnuc_init addfld', fieldname, unit + end if + end do ! lmz + + if ( history_aerocom ) then + tmpnamea = cnst_name(lmzc+loffset) + fieldname = trim(tmpnamea) // '_nuc1' + long_name = trim(tmpnamea) // ' modal_aero new particle nucleation tendency' + unit = '#/m3/s' + call addfld( fieldname, unit, pver, 'A', long_name, phys_decomp ) + call add_default( fieldname, 1, ' ' ) + if ( masterproc ) write(iulog,'(3(a,2x))') & + 'modal_aero_newnuc_init addfld', fieldname, unit + + fieldname = trim(tmpnamea) // '_nuc2' + long_name = trim(tmpnamea) // ' modal_aero cluster nucleation rate' + unit = '#/m3/s' + call addfld( fieldname, unit, pver, 'A', long_name, phys_decomp ) + call add_default( fieldname, 1, ' ' ) + if ( masterproc ) write(iulog,'(3(a,2x))') & + 'modal_aero_newnuc_init addfld', fieldname, unit + endif + + +#if ( defined( MOSAIC_SPECIES ) ) + if ( mosaic ) then + !BSINGH - Adding addfld and add_default call for tracking convergence failures + call addfld('convergence_fail', 'no units', pver, 'A', 'For tracking MOSAIC convergence failure', phys_decomp ) + call addfld('max_kelvin_iter', 'no units', pver, 'A', 'For tracking when MOSAIC kelvin iterations hit max ', phys_decomp ) + call add_default( 'convergence_fail', 1, ' ' ) + call add_default( 'max_kelvin_iter', 1, ' ' ) + + do n = 1, 4 + do m = 1, 5 + fieldname = ' ' + write( fieldname(1:16), '(a,i1,a,i1)') 'astem_negval_', m, '_', n + call addfld( fieldname, 'no units', pver, 'A', 'For tracking ASTEM negative values', phys_decomp ) + call add_default( fieldname, 1, ' ' ) + end do + end do + end if +#endif + + return + end subroutine m_a_amicphys_init_history + + +!---------------------------------------------------------------------- + +end module modal_aero_amicphys + + diff --git a/components/cam/src/chemistry/modal_aero/modal_aero_coag.F90 b/components/cam/src/chemistry/modal_aero/modal_aero_coag.F90 index 40401256632d..e4a526225273 100644 --- a/components/cam/src/chemistry/modal_aero/modal_aero_coag.F90 +++ b/components/cam/src/chemistry/modal_aero/modal_aero_coag.F90 @@ -11,6 +11,7 @@ module modal_aero_coag ! !USES: use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_logfile, only: iulog use chem_mods, only: gas_pcnst use modal_aero_data, only: maxd_aspectype @@ -19,7 +20,7 @@ module modal_aero_coag save ! !PUBLIC MEMBER FUNCTIONS: - public modal_aero_coag_sub, modal_aero_coag_init + public :: modal_aero_coag_sub, modal_aero_coag_init, getcoags_wrapper_f ! !PUBLIC DATA MEMBERS: integer, parameter :: pcnstxx = gas_pcnst @@ -86,7 +87,7 @@ subroutine modal_aero_coag_sub( & use modal_aero_gasaerexch, only: n_so4_monolayers_pcage, & soa_equivso4_factor - use cam_abortutils, only: endrun + use cam_abortutils, only: endrun use cam_history, only: outfld, fieldname_len use chem_mods, only: adv_mass use constituents, only: pcnst, cnst_name @@ -209,7 +210,7 @@ subroutine modal_aero_coag_sub( & dotend(:) = .false. dqdt(1:ncol,:,:) = 0.0_r8 - lunout = 6 + lunout = iulog ! @@ -759,7 +760,7 @@ subroutine modal_aero_coag_init use modal_aero_gasaerexch, only: & modefrm_pcage, nspecfrm_pcage, lspecfrm_pcage, lspectoo_pcage - use cam_abortutils, only: endrun + use cam_abortutils, only: endrun use cam_history, only: addfld, add_default, fieldname_len, phys_decomp use constituents, only: pcnst, cnst_name use spmd_utils, only: masterproc @@ -785,7 +786,7 @@ subroutine modal_aero_coag_init call phys_getopts( history_aerosol_out = history_aerosol ) - lunout = 6 + lunout = iulog ! ! define "from mode" and "to mode" for each coagulation pairing ! currently just a2-->a1 coagulation @@ -815,9 +816,9 @@ subroutine modal_aero_coag_init modetoo_acoag(3) = modeptr_pcarbon modetooeff_acoag(3) = modeptr_accum if (modefrm_pcage <= 0) then - write(*,*) '*** modal_aero_coag_init error' - write(*,*) ' pair_option_acoag, modefrm_pcage mismatch' - write(*,*) ' pair_option_acoag, modefrm_pcage =', & + write(iulog,*) '*** modal_aero_coag_init error' + write(iulog,*) ' pair_option_acoag, modefrm_pcage mismatch' + write(iulog,*) ' pair_option_acoag, modefrm_pcage =', & pair_option_acoag, modefrm_pcage call endrun( 'modal_aero_coag_init error' ) end if @@ -838,9 +839,9 @@ subroutine modal_aero_coag_init if ( (mfrm < 1) .or. (mfrm > ntot_amode) .or. & (mtoo < 1) .or. (mtoo > ntot_amode) .or. & (mtef < 1) .or. (mtef > ntot_amode) ) then - write(*,*) '*** modal_aero_coag_init error' - write(*,*) ' ipair, ntot_amode =', ipair, ntot_amode - write(*,*) ' mfrm, mtoo, mtef =', mfrm, mtoo, mtef + write(iulog,*) '*** modal_aero_coag_init error' + write(iulog,*) ' ipair, ntot_amode =', ipair, ntot_amode + write(iulog,*) ' mfrm, mtoo, mtef =', mfrm, mtoo, mtef call endrun( 'modal_aero_coag_init error' ) end if @@ -983,9 +984,11 @@ subroutine modal_aero_coag_init if ( history_aerosol ) then call add_default( fieldname, 1, ' ' ) endif - if ( masterproc ) write(*,'(3(a,2x))') & + if ( masterproc ) write(iulog,'(3(a,2x))') & 'modal_aero_coag_init addfld', fieldname, unit end do ! l = ... + if ( masterproc ) write(iulog,'(a)') & + 'modal_aero_coag_init ALL DONE' return diff --git a/components/cam/src/chemistry/modal_aero/modal_aero_convproc.F90 b/components/cam/src/chemistry/modal_aero/modal_aero_convproc.F90 index 2f24ab63ece0..c90954db310b 100644 --- a/components/cam/src/chemistry/modal_aero/modal_aero_convproc.F90 +++ b/components/cam/src/chemistry/modal_aero/modal_aero_convproc.F90 @@ -193,7 +193,8 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & mu, md, du, eu, & ed, dp, dsubcld, & jt, maxg, ideep, lengath, species_class, & - mam_prevap_resusp_optaa ) + mam_prevap_resusp_optaa, & + history_aero_prevap_resusp ) !----------------------------------------------------------------------- ! ! Purpose: @@ -258,6 +259,7 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & integer, intent(in) :: lengath ! Gathered min lon indices over which to operate integer, intent(in) :: species_class(:) integer, intent(in) :: mam_prevap_resusp_optaa + logical, intent(in) :: history_aero_prevap_resusp ! Local variables @@ -473,10 +475,12 @@ subroutine ma_convproc_intr( state, ptend, pbuf, ztodt, & call outfld( trim(cnst_name(l))//'SFWET', aerdepwetis(:,l), pcols, lchnk ) call outfld( trim(cnst_name(l))//'SFSIC', sflxic(:,l), pcols, lchnk ) + if ( history_aero_prevap_resusp ) & call outfld( trim(cnst_name(l))//'SFSEC', sflxec(:,l), pcols, lchnk ) if ( deepconv_wetdep_history ) then call outfld( trim(cnst_name(l))//'SFSID', sflxid(:,l), pcols, lchnk ) + if ( history_aero_prevap_resusp ) & call outfld( trim(cnst_name(l))//'SFSED', sflxed(:,l), pcols, lchnk ) end if end do ! ll diff --git a/components/cam/src/chemistry/modal_aero/modal_aero_data.F90 b/components/cam/src/chemistry/modal_aero/modal_aero_data.F90 index d41c1d1d683e..2b8c1260ace8 100644 --- a/components/cam/src/chemistry/modal_aero/modal_aero_data.F90 +++ b/components/cam/src/chemistry/modal_aero/modal_aero_data.F90 @@ -27,6 +27,12 @@ module modal_aero_data logical, parameter :: rain_evap_to_coarse_aero = .false. #endif + ! carbonaceous species counters - will eventually be set by configuration options + integer, parameter :: nbc = 1 ! number of differently tagged black-carbon aerosol species + integer, parameter :: npoa = 1 ! number of differently tagged primary-organic aerosol species + integer, parameter :: nsoa = 1 ! number of differently tagged secondary-organic aerosol species + integer, parameter :: nsoag = 1 ! number of differently tagged secondary-organic gas species + ! ! definitions for aerosol chemical components ! @@ -178,6 +184,10 @@ module modal_aero_data modeptr_finedust, modeptr_fineseas, & ! modeptr_coardust, modeptr_coarseas + integer & + lptr2_soa_a_amode(ntot_amode,nsoa), & + lptr2_soa_g_amode(nsoag) + real(r8) :: & specmw_so4_amode, specdens_so4_amode, & specmw_nh4_amode, specdens_nh4_amode, & diff --git a/components/cam/src/chemistry/modal_aero/modal_aero_initialize_data.F90 b/components/cam/src/chemistry/modal_aero/modal_aero_initialize_data.F90 index 226658b6cbc5..d186e1128852 100644 --- a/components/cam/src/chemistry/modal_aero/modal_aero_initialize_data.F90 +++ b/components/cam/src/chemistry/modal_aero/modal_aero_initialize_data.F90 @@ -145,9 +145,7 @@ subroutine modal_aero_register(species_class) xname_spectype(:nspec_amode(7),7) = (/ 'dust ', 'sulfate ', 'ammonium ' /) #endif - if(convproc_do_aer .or. convproc_do_gas) then - species_class(:pcnst) = spec_class_undefined - endif + species_class(:pcnst) = spec_class_undefined do m = 1, ntot_amode @@ -277,6 +275,7 @@ subroutine modal_aero_initialize(pbuf2d, imozart, species_class) use constituents, only: pcnst use physconst, only: rhoh2o, mwh2o + use modal_aero_amicphys, only: modal_aero_amicphys_init use modal_aero_calcsize, only: modal_aero_calcsize_init use modal_aero_coag, only: modal_aero_coag_init use modal_aero_deposition, only: modal_aero_deposition_init @@ -302,6 +301,7 @@ subroutine modal_aero_initialize(pbuf2d, imozart, species_class) character(len=3) :: trnum ! used to hold mode number (as characters) integer :: iaerosol, ibulk + integer :: mam_amicphys_optaa integer :: numaerosols ! number of bulk aerosols in climate list character(len=20) :: bulkname real(r8) :: pi @@ -314,7 +314,8 @@ subroutine modal_aero_initialize(pbuf2d, imozart, species_class) pi = 4._r8*atan(1._r8) call phys_getopts(convproc_do_gas_out = convproc_do_gas, & - convproc_do_aer_out = convproc_do_aer) + convproc_do_aer_out = convproc_do_aer, & + mam_amicphys_optaa_out = mam_amicphys_optaa ) ! Mode specific properties. @@ -413,8 +414,6 @@ subroutine modal_aero_initialize(pbuf2d, imozart, species_class) - !BSINGH(09/17/2014): The do-loop in the 'else' of the following if condition is wrong - if (convproc_do_aer .or. convproc_do_gas) then ! At this point, species_class is either undefined or aerosol. ! For the "chemistry species" (imozart <= i <= imozart+gas_pcnst-1), ! set the undefined ones to gas, and leave the aerosol ones as is @@ -428,15 +427,6 @@ subroutine modal_aero_initialize(pbuf2d, imozart, species_class) species_class(i) = spec_class_gas end if end do - else - - ! The following is incorrect because it overwrites values set in modal_aero_register, - ! which is called before modal_aero_init - ! BSINGH: It is not commented out as of now to maintain original code b4b status - do i = 1, pcnst - species_class(i) = spec_class_undefined - end do - endif ! set cnst_name_cw @@ -490,13 +480,19 @@ subroutine modal_aero_initialize(pbuf2d, imozart, species_class) ! ! call other initialization routines ! - call modal_aero_rename_init - ! calcsize call must follow rename call - call modal_aero_calcsize_init( pbuf2d ) - call modal_aero_gasaerexch_init - ! coag call must follow gasaerexch call - call modal_aero_coag_init - call modal_aero_newnuc_init + if ( mam_amicphys_optaa > 0 ) then + call modal_aero_calcsize_init( pbuf2d, species_class ) + call modal_aero_newnuc_init( mam_amicphys_optaa ) + call modal_aero_amicphys_init( imozart, species_class ) + else + call modal_aero_rename_init + ! calcsize call must follow rename call + call modal_aero_calcsize_init( pbuf2d, species_class ) + call modal_aero_gasaerexch_init + ! coag call must follow gasaerexch call + call modal_aero_coag_init + call modal_aero_newnuc_init( mam_amicphys_optaa ) + endif ! call modal_aero_deposition_init only if the user has not specified ! prescribed aerosol deposition fluxes diff --git a/components/cam/src/chemistry/modal_aero/modal_aero_newnuc.F90 b/components/cam/src/chemistry/modal_aero/modal_aero_newnuc.F90 index 792b69009c47..ec8240920cd8 100644 --- a/components/cam/src/chemistry/modal_aero/modal_aero_newnuc.F90 +++ b/components/cam/src/chemistry/modal_aero/modal_aero_newnuc.F90 @@ -13,6 +13,7 @@ module modal_aero_newnuc ! !USES: use shr_kind_mod, only: r8 => shr_kind_r8 use shr_kind_mod, only: r4 => shr_kind_r4 + use cam_logfile, only: iulog use mo_constants, only: pi use chem_mods, only: gas_pcnst @@ -21,14 +22,30 @@ module modal_aero_newnuc save ! !PUBLIC MEMBER FUNCTIONS: - public modal_aero_newnuc_sub, modal_aero_newnuc_init + public :: modal_aero_newnuc_sub, modal_aero_newnuc_init, & + mer07_veh02_nuc_mosaic_1box + ! !PUBLIC DATA MEMBERS: + integer, public :: newnuc_h2so4_conc_flag = 1 + +! min h2so4 vapor for nuc calcs = 4.0e-16 mol/mol-air ~= 1.0e4 molecules/cm3, + real(r8), public, parameter :: qh2so4_cutoff = 4.0e-16_r8 + +! adjustment factors + real(r8), parameter, public :: adjust_factor_dnaitdt = 1.0_r8 ! applied to final dnait/dt + real(r8), parameter, public :: adjust_factor_bin_tern_ratenucl = 1.0_r8 ! applied to binary/ternary nucleation rate +! real(r8), parameter, public :: adjust_factor_pbl_ratenucl = 1.0_r8 ! applied to boundary layer nucleation rate + real(r8), public :: adjust_factor_pbl_ratenucl = 1.0_r8 ! applied to boundary layer nucleation rate + + +! !NON-PUBLIC DATA MEMBERS: integer, parameter :: pcnstxx = gas_pcnst integer :: l_h2so4_sv, l_nh3_sv, lnumait_sv, lnh4ait_sv, lso4ait_sv -! min h2so4 vapor for nuc calcs = 4.0e-16 mol/mol-air ~= 1.0e4 molecules/cm3, - real(r8), parameter :: qh2so4_cutoff = 4.0e-16_r8 +! max cloud fraction for nuc calcs + real(r8), parameter :: cld_cutoff = 0.99_r8 + ! !DESCRIPTION: This module implements ... ! @@ -66,15 +83,15 @@ subroutine modal_aero_newnuc_sub( & ! !USES: use modal_aero_data - use cam_abortutils, only: endrun - use cam_history, only: outfld, fieldname_len - use chem_mods, only: adv_mass - use constituents, only: pcnst, cnst_name - use physconst, only: gravit, mwdry, r_universal - use ppgrid, only: pcols, pver - use spmd_utils, only: iam, masterproc - use wv_saturation, only: qsat - use ref_pres, only: top_lev=>clim_modal_aero_top_lev + use cam_abortutils, only: endrun + use cam_history, only: outfld, fieldname_len + use chem_mods, only: adv_mass + use constituents, only: pcnst, cnst_name + use physconst, only: gravit, mwdry, r_universal + use ppgrid, only: pcols, pver + use spmd_utils, only: iam, masterproc + use wv_saturation, only: qsat + use ref_pres, only: top_lev=>clim_modal_aero_top_lev implicit none @@ -133,7 +150,6 @@ subroutine modal_aero_newnuc_sub( & ! 11=merikanto ternary + first-order boundary layer ! 12=merikanto ternary + second-order boundary layer - real(r8) :: adjust_factor real(r8) :: aircon real(r8) :: cldx real(r8) :: dens_nh4so4a @@ -249,14 +265,21 @@ subroutine modal_aero_newnuc_sub( & main_k: do k = top_lev, pver main_i: do i = 1, ncol -! skip if completely cloudy, +! skip if (almost) completely cloudy, ! because all h2so4 vapor should be cloud-borne - if (cld(i,k) >= 0.99_r8) cycle main_i + if (cld(i,k) >= cld_cutoff) cycle main_i ! qh2so4_cur = current qh2so4, after aeruptk qh2so4_cur = q(i,k,l_h2so4) + ! skip if h2so4 vapor < qh2so4_cutoff - if (qh2so4_cur <= qh2so4_cutoff) cycle main_i +! 05-jul-2013 - maybe should only skip here if qh2so4_cur << cutoff +! because may have qh2so4_avg >> qh2so4_cur + if (newnuc_h2so4_conc_flag < 10) then + if (qh2so4_cur <= qh2so4_cutoff) cycle main_i + else + if (qh2so4_cur <= qh2so4_cutoff*1.0e-10_r8) cycle main_i + end if tmpa = max( 0.0_r8, del_h2so4_gasprod(i,k) ) tmp_q3 = qh2so4_cur @@ -294,6 +317,13 @@ subroutine modal_aero_newnuc_sub( & tmpc = tmpa/tmpb qh2so4_avg = (tmp_q3 - tmpc)*((exp(tmpb)-1.0_r8)/tmpb) + tmpc end if + + if (newnuc_h2so4_conc_flag == 11) then + qh2so4_avg = qh2so4_cur + else if (newnuc_h2so4_conc_flag == 12) then + qh2so4_avg = qh2so4_cur + 0.5_r8*max( 0.0_r8, -del_h2so4_aeruptk(i,k) ) + end if + if (qh2so4_avg <= qh2so4_cutoff) cycle main_i @@ -309,7 +339,7 @@ subroutine modal_aero_newnuc_sub( & qvswtr = max( qvswtr, 1.0e-20_r8 ) relhumav = qv(i,k) / qvswtr relhumav = max( 0.0_r8, min( 1.0_r8, relhumav ) ) -! relhum = non-cloudy area RH +! relhum = non-cloudy area RH (note that 1-cldx >= .01) cldx = max( 0.0_r8, cld(i,k) ) relhum = (relhumav - cldx) / (1.0_r8 - cldx) relhum = max( 0.0_r8, min( 1.0_r8, relhum ) ) @@ -435,9 +465,8 @@ subroutine modal_aero_newnuc_sub( & ! *** apply adjustment factor to avoid unrealistically high ! aitken number concentrations in mid and upper troposphere -! adjust_factor = 0.5 -! dndt_ait = dndt_ait * adjust_factor -! dmdt_ait = dmdt_ait * adjust_factor + dndt_ait = dndt_ait * adjust_factor_dnaitdt + dmdt_ait = dmdt_ait * adjust_factor_dnaitdt ! set tendencies pdel_fac = pdel(i,k)/gravit @@ -573,8 +602,9 @@ subroutine mer07_veh02_nuc_mosaic_1box( & mw_so4a_host, & nsize, maxd_asize, dplom_sect, dphim_sect, & isize_nuc, qnuma_del, qso4a_del, qnh4a_del, & - qh2so4_del, qnh3_del, dens_nh4so4a, ldiagaa ) -! qh2so4_del, qnh3_del, dens_nh4so4a ) + qh2so4_del, qnh3_del, dens_nh4so4a, ldiagaa, & + dnclusterdt ) + use mo_constants, only: rgas, & ! Gas constant (J/K/kmol) avogad => avogadro ! Avogadro's number (1/kmol) use physconst, only: mw_so4a => mwso4, & ! Molecular weight of sulfate @@ -657,6 +687,8 @@ subroutine mer07_veh02_nuc_mosaic_1box( & real(r8), intent(out) :: qnh3_del ! change to gas nh3 mixing ratio (mol/mol-air) ! aerosol changes are > 0; gas changes are < 0 real(r8), intent(out) :: dens_nh4so4a ! dry-density of the new nh4-so4 aerosol mass (kg/m3) + real(r8), intent(out), optional :: & + dnclusterdt ! cluster nucleation rate (#/m3/s) ! subr arguments (out) passed via common block ! these are used to duplicate the outputs of yang zhang's original test driver @@ -748,6 +780,7 @@ subroutine mer07_veh02_nuc_mosaic_1box( & qnh4a_del = 0.0_r8 qh2so4_del = 0.0_r8 qnh3_del = 0.0_r8 + if ( present ( dnclusterdt ) ) dnclusterdt = 0.0_r8 ! if (qh2so4_avg .le. qh2so4_cutoff) return ! this no longer needed ! if (qh2so4_cur .le. qh2so4_cutoff) return ! this no longer needed @@ -801,6 +834,8 @@ subroutine mer07_veh02_nuc_mosaic_1box( & newnuc_method_flagaa2 = 2 end if + rateloge = rateloge & + + log( max( 1.0e-38_r8, adjust_factor_bin_tern_ratenucl ) ) ! do boundary layer nuc @@ -816,12 +851,14 @@ subroutine mer07_veh02_nuc_mosaic_1box( & end if -! if nucleation rate is less than 1e-6 #/m3/s ~= 0.1 #/cm3/day, +! if nucleation rate is less than 1e-6 #/cm3/s ~= 0.1 #/cm3/day, ! exit with new particle formation = 0 if (rateloge .le. -13.82_r8) return ! if (ratenuclt .le. 1.0e-6) return + ratenuclt = exp( rateloge ) - ratenuclt_bb = ratenuclt*1.0e6_r8 + ratenuclt_bb = ratenuclt*1.0e6_r8 ! ratenuclt_bb is #/m3/s; ratenuclt is #/cm3/s + if ( present ( dnclusterdt ) ) dnclusterdt = ratenuclt_bb ! wet/dry volume ratio - use simple kohler approx for ammsulf/ammbisulf @@ -1184,7 +1221,8 @@ subroutine pbl_nuc_wang2008( so4vol, & else return end if - tmp_rateloge = log( tmp_ratenucl ) + tmp_ratenucl = tmp_ratenucl * adjust_factor_pbl_ratenucl + tmp_rateloge = log( max( 1.0e-38_r8, tmp_ratenucl ) ) ! exit if pbl nuc rate is lower than (incoming) ternary/binary rate if (tmp_rateloge <= rateloge) return @@ -1413,7 +1451,7 @@ end subroutine binary_nuc_vehk2002 !---------------------------------------------------------------------- !---------------------------------------------------------------------- -subroutine modal_aero_newnuc_init +subroutine modal_aero_newnuc_init( mam_amicphys_optaa ) !----------------------------------------------------------------------- ! @@ -1429,17 +1467,18 @@ subroutine modal_aero_newnuc_init use modal_aero_data use modal_aero_rename -use cam_abortutils, only: endrun -use cam_history, only: addfld, add_default, fieldname_len, phys_decomp -use constituents, only: pcnst, cnst_get_ind, cnst_name -use spmd_utils, only: masterproc -use phys_control, only: phys_getopts +use cam_abortutils, only: endrun +use cam_history, only: addfld, add_default, fieldname_len, phys_decomp +use constituents, only: pcnst, cnst_get_ind, cnst_name +use spmd_utils, only: masterproc +use phys_control, only: phys_getopts implicit none !----------------------------------------------------------------------- ! arguments + integer, intent(in) :: mam_amicphys_optaa !----------------------------------------------------------------------- ! local @@ -1458,8 +1497,6 @@ subroutine modal_aero_newnuc_init !----------------------------------------------------------------------- - call phys_getopts( history_aerosol_out = history_aerosol ) - ! set these indices ! skip if no h2so4 species @@ -1480,19 +1517,19 @@ subroutine modal_aero_newnuc_init lnh4ait = lptr_nh4_a_amode(mait) end if if ((l_h2so4 <= 0) .or. (l_h2so4 > pcnst)) then - write(*,'(/a/)') & + write(iulog,'(/a/)') & '*** modal_aero_newnuc bypass -- l_h2so4 <= 0' return else if ((lso4ait <= 0) .or. (lso4ait > pcnst)) then - write(*,'(/a/)') & + write(iulog,'(/a/)') & '*** modal_aero_newnuc bypass -- lso4ait <= 0' return else if ((lnumait <= 0) .or. (lnumait > pcnst)) then - write(*,'(/a/)') & + write(iulog,'(/a/)') & '*** modal_aero_newnuc bypass -- lnumait <= 0' return else if ((mait <= 0) .or. (mait > ntot_amode)) then - write(*,'(/a/)') & + write(iulog,'(/a/)') & '*** modal_aero_newnuc bypass -- modeptr_aitken <= 0' return end if @@ -1506,6 +1543,10 @@ subroutine modal_aero_newnuc_init ! ! create history file column-tendency fields ! + if (mam_amicphys_optaa > 0) return + + call phys_getopts( history_aerosol_out = history_aerosol ) + dotend(:) = .false. dotend(lnumait) = .true. dotend(lso4ait) = .true. @@ -1529,7 +1570,7 @@ subroutine modal_aero_newnuc_init if ( history_aerosol ) then call add_default( fieldname, 1, ' ' ) endif - if ( masterproc ) write(*,'(3(a,2x))') & + if ( masterproc ) write(iulog,'(3(a,2x))') & 'modal_aero_newnuc_init addfld', fieldname, unit end do ! l = ... @@ -1695,7 +1736,7 @@ end subroutine ternary_nuc_merik2007 !---------------------------------------------------------------------- -#endif ! (defined MODAL_AERO) +#endif end module modal_aero_newnuc diff --git a/components/cam/src/chemistry/mozart/mo_gas_phase_chemdr.F90 b/components/cam/src/chemistry/mozart/mo_gas_phase_chemdr.F90 index 676ca448618e..857ab328d4d6 100644 --- a/components/cam/src/chemistry/mozart/mo_gas_phase_chemdr.F90 +++ b/components/cam/src/chemistry/mozart/mo_gas_phase_chemdr.F90 @@ -748,7 +748,7 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & ! Aerosol processes ... ! - call aero_model_gasaerexch( imozart-1, ncol, lchnk, delt, reaction_rates, & + call aero_model_gasaerexch( imozart-1, ncol, lchnk, delt, latndx, lonndx, reaction_rates, & tfld, pmid, pdel, mbar, relhum, & zm, qh2o, cwat, cldfr, ncldwtr, & invariants(:,:,indexm), invariants, del_h2so4_gasprod, & diff --git a/components/cam/src/chemistry/utils/modal_aero_calcsize.F90 b/components/cam/src/chemistry/utils/modal_aero_calcsize.F90 index c824611dcd66..6b1c24fa9aca 100644 --- a/components/cam/src/chemistry/utils/modal_aero_calcsize.F90 +++ b/components/cam/src/chemistry/utils/modal_aero_calcsize.F90 @@ -15,7 +15,7 @@ module modal_aero_calcsize rad_cnst_get_mode_props, rad_cnst_get_mode_num use cam_logfile, only: iulog -use cam_abortutils, only: endrun +use cam_abortutils, only: endrun use cam_history, only: addfld, add_default, fieldname_len, phys_decomp, outfld use constituents, only: pcnst, cnst_name @@ -38,10 +38,6 @@ module modal_aero_calcsize lspectype_amode, specmw_amode, specdens_amode, voltonumb_amode, & cnst_name_cw -use modal_aero_rename, only: lspectooa_renamexf, lspecfrma_renamexf, lspectooc_renamexf, lspecfrmc_renamexf, & - modetoo_renamexf, nspecfrm_renamexf, npair_renamexf, modefrm_renamexf - - #endif @@ -57,6 +53,19 @@ module modal_aero_calcsize integer :: dgnum_idx = -1 +integer, parameter, public :: maxpair_csizxf = 1 +integer, parameter, public :: maxspec_csizxf = ntot_aspectype + +integer, public :: npair_csizxf = -123456789 +integer, public :: modefrm_csizxf(maxpair_csizxf) +integer, public :: modetoo_csizxf(maxpair_csizxf) +integer, public :: nspecfrm_csizxf(maxpair_csizxf) +integer, public :: lspecfrmc_csizxf(maxspec_csizxf,maxpair_csizxf) +integer, public :: lspecfrma_csizxf(maxspec_csizxf,maxpair_csizxf) +integer, public :: lspectooc_csizxf(maxspec_csizxf,maxpair_csizxf) +integer, public :: lspectooa_csizxf(maxspec_csizxf,maxpair_csizxf) + + !=============================================================================== contains !=============================================================================== @@ -76,7 +85,7 @@ end subroutine modal_aero_calcsize_reg !=============================================================================== !=============================================================================== -subroutine modal_aero_calcsize_init(pbuf2d) +subroutine modal_aero_calcsize_init( pbuf2d, species_class) use time_manager, only: is_first_step use physics_buffer,only: pbuf_set_field @@ -92,12 +101,15 @@ subroutine modal_aero_calcsize_init(pbuf2d) !----------------------------------------------------------------------- type(physics_buffer_desc), pointer :: pbuf2d(:,:) + integer, intent(in) :: species_class(:) ! local - integer :: ipair, iq + integer :: ipair, iq, iqfrm, iqtoo integer :: jac - integer :: lsfrm, lstoo - integer :: n, nacc, nait + integer :: lsfrm, lstoo, lsfrma, lsfrmc, lstooa, lstooc, lunout + integer :: mfrm, mtoo + integer :: n, nacc, nait, nspec + integer :: nchfrma, nchfrmc, nchfrmskip, nchtooa, nchtooc, nchtooskip logical :: history_aerosol character(len=fieldname_len) :: tmpnamea, tmpnameb @@ -115,9 +127,14 @@ subroutine modal_aero_calcsize_init(pbuf2d) call pbuf_set_field(pbuf2d, dgnum_idx, 0.0_r8) endif + npair_csizxf = 0 + modefrm_csizxf(1) = 0 + modetoo_csizxf(1) = 0 + #ifndef MODAL_AERO do_adjust_default = .false. do_aitacc_transfer_default = .false. + #else ! do_adjust_default allows adjustment to be turned on/off do_adjust_default = .true. @@ -138,7 +155,188 @@ subroutine modal_aero_calcsize_init(pbuf2d) if ( .not. do_adjust_default ) return - ! define history fields for number-adjust source-sink for all modes +! +! define history fields for number-adjust source-sink for all modes +! + +do_aitacc_transfer_if_block1: & + if ( do_aitacc_transfer_default ) then +! +! compute pointers for aitken <--> accum mode transfer +! (a2 <--> a1 transfer) +! transfers include number_a, number_c, mass_a, mass_c +! + npair_csizxf = 1 + modefrm_csizxf(1) = nait + modetoo_csizxf(1) = nacc + +! +! define species involved in each transfer pairing +! +aa_ipair: do ipair = 1, npair_csizxf + + mfrm = modefrm_csizxf(ipair) + mtoo = modetoo_csizxf(ipair) + if (mfrm < 10) then + nchfrmskip = 1 + else if (mfrm < 100) then + nchfrmskip = 2 + else + nchfrmskip = 3 + end if + if (mtoo < 10) then + nchtooskip = 1 + else if (mtoo < 100) then + nchtooskip = 2 + else + nchtooskip = 3 + end if + nspec = 0 + +aa_iqfrm: do iqfrm = -1, nspec_amode(mfrm) + + if (iqfrm == -1) then + lsfrma = numptr_amode(mfrm) + lstooa = numptr_amode(mtoo) + lsfrmc = numptrcw_amode(mfrm) + lstooc = numptrcw_amode(mtoo) + else if (iqfrm == 0) then +! bypass transfer of aerosol water due to calcsize transfer + cycle aa_iqfrm + else + lsfrma = lmassptr_amode(iqfrm,mfrm) + lsfrmc = lmassptrcw_amode(iqfrm,mfrm) + lstooa = 0 + lstooc = 0 + end if + + if ((lsfrma < 1) .or. (lsfrma > pcnst)) then + write(iulog,9100) mfrm, iqfrm, lsfrma + call endrun( 'modal_aero_calcsize_init error aa' ) + end if + if ((lsfrmc < 1) .or. (lsfrmc > pcnst)) then + write(iulog,9102) mfrm, iqfrm, lsfrmc + call endrun( 'modal_aero_calcsize_init error bb' ) + end if + + if (iqfrm > 0) then + nchfrma = len( trim( cnst_name(lsfrma) ) ) - nchfrmskip + +! find "too" species having same cnst_name as the "frm" species +! (except for last 1/2/3 characters which are the mode index) + do iqtoo = 1, nspec_amode(mtoo) + lstooa = lmassptr_amode(iqtoo,mtoo) + nchtooa = len( trim( cnst_name(lstooa) ) ) - nchtooskip + if (cnst_name(lsfrma)(1:nchfrma) == cnst_name(lstooa)(1:nchtooa)) then + ! interstitial names match, so check cloudborne names too + nchfrmc = len( trim( cnst_name_cw(lsfrmc) ) ) - nchfrmskip + lstooc = lmassptrcw_amode(iqtoo,mtoo) + nchtooc = len( trim( cnst_name_cw(lstooc) ) ) - nchtooskip + if (cnst_name_cw(lsfrmc)(1:nchfrmc) /= & + cnst_name_cw(lstooc)(1:nchtooc)) lstooc = 0 + exit + else + lstooa = 0 + end if + end do + end if ! (iqfrm > 0) + + if ((lstooc < 1) .or. (lstooc > pcnst)) lstooc = 0 + if ((lstooa < 1) .or. (lstooa > pcnst)) lstooa = 0 + if (lstooa == 0) then + write(iulog,9104) mfrm, iqfrm, lsfrma, iqtoo, lstooa + call endrun( 'modal_aero_calcsize_init error cc' ) + end if + if ((lstooc == 0) .and. (iqfrm /= 0)) then + write(iulog,9104) mfrm, iqfrm, lsfrmc, iqtoo, lstooc + call endrun( 'modal_aero_calcsize_init error dd' ) + end if + + nspec = nspec + 1 + lspecfrma_csizxf(nspec,ipair) = lsfrma + lspectooa_csizxf(nspec,ipair) = lstooa + lspecfrmc_csizxf(nspec,ipair) = lsfrmc + lspectooc_csizxf(nspec,ipair) = lstooc + end do aa_iqfrm + + nspecfrm_csizxf(ipair) = nspec + end do aa_ipair + +9100 format( / '*** subr. modal_aero_calcsize_init' / & + 'lspecfrma out of range' / & + 'modefrm, ispecfrm, lspecfrma =', 3i6 / ) +9102 format( / '*** subr. modal_aero_calcsize_init' / & + 'lspecfrmc out of range' / & + 'modefrm, ispecfrm, lspecfrmc =', 3i6 / ) +9104 format( / '*** subr. modal_aero_calcsize_init' / & + 'lspectooa out of range' / & + 'modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 5i6 / ) +9106 format( / '*** subr. modal_aero_calcsize_init' / & + 'lspectooc out of range' / & + 'modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 5i6 / ) + +! +! output results +! + if ( masterproc ) then + + write(iulog,9310) do_adjust_default, do_aitacc_transfer_default + + do ipair = 1, npair_csizxf + mfrm = modefrm_csizxf(ipair) + mtoo = modetoo_csizxf(ipair) + write(iulog,9320) ipair, mfrm, mtoo + + do iq = 1, nspecfrm_csizxf(ipair) + lsfrma = lspecfrma_csizxf(iq,ipair) + lstooa = lspectooa_csizxf(iq,ipair) + lsfrmc = lspecfrmc_csizxf(iq,ipair) + lstooc = lspectooc_csizxf(iq,ipair) + if (lstooa .gt. 0) then + write(iulog,9330) lsfrma, cnst_name(lsfrma), & + lstooa, cnst_name(lstooa) + else + write(iulog,9340) lsfrma, cnst_name(lsfrma) + end if + if (lstooc .gt. 0) then + write(iulog,9330) lsfrmc, cnst_name_cw(lsfrmc), & + lstooc, cnst_name_cw(lstooc) + else if (lsfrmc .gt. 0) then + write(iulog,9340) lsfrmc, cnst_name_cw(lsfrmc) + else + write(iulog,9350) + end if + end do ! iq + + end do ! ipair + write(iulog,*) + + end if ! ( masterproc ) + + + else ! do_aitacc_transfer_if_block1 + + npair_csizxf = 0 + if ( masterproc ) then + write(iulog,9310) do_adjust_default, do_aitacc_transfer_default + write(iulog,9320) 0, 0, 0 + end if + + end if do_aitacc_transfer_if_block1 + +9310 format( / 'subr. modal_aero_calcsize_init' / & + 'do_adjust_default, do_aitacc_transfer_default = ', 2l10 ) +9320 format( 'pair', i3, 5x, 'mode', i3, ' ---> mode', i3 ) +9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a ) +9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' ) +9350 format( 5x, 'no corresponding activated species' ) + + + +! define history fields for number-adjust source-sink for all modes +do_adjust_if_block2: & + if ( do_adjust_default ) then + do n = 1, ntot_amode if (mprognum_amode(n) <= 0) cycle @@ -155,7 +353,7 @@ subroutine modal_aero_calcsize_init(pbuf2d) if (history_aerosol) then call add_default(fieldname, 1, ' ') end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + if ( masterproc ) write(iulog,'(2a)') 'calcsize addfld - ', fieldname fieldname = trim(tmpnamea) // '_sfcsiz2' long_name = trim(tmpnamea) // ' calcsize number-adjust column sink' @@ -163,84 +361,100 @@ subroutine modal_aero_calcsize_init(pbuf2d) if (history_aerosol) then call add_default(fieldname, 1, ' ') end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + if ( masterproc ) write(iulog,'(2a)') 'calcsize addfld - ', fieldname end do ! jac = ... + end do ! n = ... - if ( .not. do_aitacc_transfer_default ) return - ! check that renaming ipair=1 is aitken-->accum - ipair = 1 - if ((modefrm_renamexf(ipair) .ne. nait) .or. & - (modetoo_renamexf(ipair) .ne. nacc)) then - write( 6, '(//2a//)' ) & - '*** modal_aero_calcaersize_init error -- ', & - 'modefrm/too_renamexf(1) are wrong' - call endrun( 'modal_aero_calcaersize_init error' ) - end if +! define history fields for aitken-accum transfer +do_aitacc_transfer_if_block2: & + if ( do_aitacc_transfer_default ) then - ! define history fields for aitken-accum transfer - do iq = 1, nspecfrm_renamexf(ipair) +! check that calcsize transfer ipair=1 is aitken-->accum + ipair = 1 + if ((modefrm_csizxf(ipair) .ne. nait) .or. & + (modetoo_csizxf(ipair) .ne. nacc)) then + write( iulog, '(//2a//)' ) & + '*** modal_aero_calcaersize_init error -- ', & + 'modefrm/too_csizxf(1) are wrong' + call endrun( 'modal_aero_calcaersize_init error' ) + end if - ! jac=1 does interstitial ("_a"); jac=2 does activated ("_c"); - do jac = 1, 2 + do iq = 1, nspecfrm_csizxf(ipair) - ! the lspecfrma_renamexf (and lspecfrmc_renamexf) are aitken species - ! the lspectooa_renamexf (and lspectooc_renamexf) are accum species - if (jac .eq. 1) then - lsfrm = lspecfrma_renamexf(iq,ipair) - lstoo = lspectooa_renamexf(iq,ipair) - else - lsfrm = lspecfrmc_renamexf(iq,ipair) - lstoo = lspectooc_renamexf(iq,ipair) - end if - if ((lsfrm <= 0) .or. (lstoo <= 0)) cycle +! jac=1 does interstitial ("_a"); jac=2 does activated ("_c"); + do jac = 1, 2 - if (jac .eq. 1) then - tmpnamea = cnst_name(lsfrm) - tmpnameb = cnst_name(lstoo) - else - tmpnamea = cnst_name_cw(lsfrm) - tmpnameb = cnst_name_cw(lstoo) - end if +! the lspecfrma_csizxf (and lspecfrmc_csizxf) are aitken species +! the lspectooa_csizxf (and lspectooc_csizxf) are accum species + if (jac .eq. 1) then + lsfrm = lspecfrma_csizxf(iq,ipair) + lstoo = lspectooa_csizxf(iq,ipair) + else + lsfrm = lspecfrmc_csizxf(iq,ipair) + lstoo = lspectooc_csizxf(iq,ipair) + end if + if ((lsfrm <= 0) .or. (lstoo <= 0)) cycle + + if (jac .eq. 1) then + tmpnamea = cnst_name(lsfrm) + tmpnameb = cnst_name(lstoo) + else + tmpnamea = cnst_name_cw(lsfrm) + tmpnameb = cnst_name_cw(lstoo) + end if - unit = 'kg/m2/s' - if ((tmpnamea(1:3) == 'num') .or. & - (tmpnamea(1:3) == 'NUM')) unit = '#/m2/s' - fieldname = trim(tmpnamea) // '_sfcsiz3' - long_name = trim(tmpnamea) // ' calcsize aitken-to-accum adjust column tendency' - call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + unit = 'kg/m2/s' + if ((tmpnamea(1:3) == 'num') .or. & + (tmpnamea(1:3) == 'NUM')) unit = '#/m2/s' + fieldname = trim(tmpnamea) // '_sfcsiz3' + long_name = trim(tmpnamea) // ' calcsize aitken-to-accum adjust column tendency' + call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if ( masterproc ) write(iulog,'(2a)') 'calcsize addfld - ', fieldname - fieldname = trim(tmpnameb) // '_sfcsiz3' - long_name = trim(tmpnameb) // ' calcsize aitken-to-accum adjust column tendency' - call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + fieldname = trim(tmpnameb) // '_sfcsiz3' + long_name = trim(tmpnameb) // ' calcsize aitken-to-accum adjust column tendency' + call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if ( masterproc ) write(iulog,'(2a)') 'calcsize addfld - ', fieldname - fieldname = trim(tmpnamea) // '_sfcsiz4' - long_name = trim(tmpnamea) // ' calcsize accum-to-aitken adjust column tendency' - call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + fieldname = trim(tmpnamea) // '_sfcsiz4' + long_name = trim(tmpnamea) // ' calcsize accum-to-aitken adjust column tendency' + call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if ( masterproc ) write(iulog,'(2a)') 'calcsize addfld - ', fieldname - fieldname = trim(tmpnameb) // '_sfcsiz4' - long_name = trim(tmpnameb) // ' calcsize accum-to-aitken adjust column tendency' - call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + fieldname = trim(tmpnameb) // '_sfcsiz4' + long_name = trim(tmpnameb) // ' calcsize accum-to-aitken adjust column tendency' + call addfld( fieldname, unit, 1, 'A', long_name, phys_decomp ) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if ( masterproc ) write(iulog,'(2a)') 'calcsize addfld - ', fieldname - end do ! jac = ... - end do ! iq = ... + end do ! jac = ... + end do ! iq = ... + + end if do_aitacc_transfer_if_block2 + + end if do_adjust_if_block2 + + + if ( masterproc ) then + write(iulog,'(/a)') 'l, species_class, name' + do n = 1, pcnst + write(iulog,'(2i4,2x,a)') n, species_class(n), cnst_name(n) + end do + end if + if ( masterproc ) write(iulog,'(a)') 'modal_aero_calcsize_init ALL DONE' #endif @@ -363,7 +577,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, do_adjust_in, & ! 3rd index -- ! 1="standard" number adjust gain; ! 2="standard" number adjust loss; - ! 3=aitken-->accum renaming; 4=accum-->aitken) + ! 3=aitken-->accum transfer; 4=accum-->aitken) ! 4th index -- ! 1="a" species; 2="c" species !----------------------------------------------------------------------- @@ -688,7 +902,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, do_adjust_in, & qsrflx(i,lnc,2,jac) = qsrflx(i,lnc,2,jac) + min(0.0_r8,dqqcwdt(i,k,lnc))*pdel_fac - ! save number and dryvol for aitken <--> accum renaming + ! save number and dryvol for aitken <--> accum transfer if ( do_aitacc_transfer ) then if (n == nait) then drv_a_aitsv(i,k) = drv_a @@ -735,39 +949,32 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, do_adjust_in, & ixfer_acc2ait_sv(:,:) = 0 if ( do_aitacc_transfer ) then - ! old - on time first step, npair_renamexf will be <= 0, - ! in which case need to do modal_aero_rename_init - ! new - init is now done through chem_init and things below it - if (npair_renamexf .le. 0) then - npair_renamexf = 0 - ! call modal_aero_rename_init - if (npair_renamexf .le. 0) then - write( 6, '(//a//)' ) & - '*** modal_aero_calcaersize_sub error -- npair_renamexf <= 0' - call endrun( 'modal_aero_calcaersize_sub error' ) - end if + if (npair_csizxf .le. 0) then + write( iulog, '(//a//)' ) & + '*** modal_aero_calcaersize_sub error -- npair_csizxf <= 0' + call endrun( 'modal_aero_calcaersize_sub error' ) end if - ! check that renaming ipair=1 is aitken-->accum + ! check that calcsize transfer ipair=1 is aitken-->accum ipair = 1 - if ((modefrm_renamexf(ipair) .ne. nait) .or. & - (modetoo_renamexf(ipair) .ne. nacc)) then - write( 6, '(//2a//)' ) & + if ((modefrm_csizxf(ipair) .ne. nait) .or. & + (modetoo_csizxf(ipair) .ne. nacc)) then + write( iulog, '(//2a//)' ) & '*** modal_aero_calcaersize_sub error -- ', & - 'modefrm/too_renamexf(1) are wrong' + 'modefrm/too_csizxf(1) are wrong' call endrun( 'modal_aero_calcaersize_sub error' ) end if ! set dotend() for species that will be transferred - do iq = 1, nspecfrm_renamexf(ipair) - lsfrm = lspecfrma_renamexf(iq,ipair) - lstoo = lspectooa_renamexf(iq,ipair) + do iq = 1, nspecfrm_csizxf(ipair) + lsfrm = lspecfrma_csizxf(iq,ipair) + lstoo = lspectooa_csizxf(iq,ipair) if ((lsfrm > 0) .and. (lstoo > 0)) then dotend(lsfrm) = .true. dotend(lstoo) = .true. end if - lsfrm = lspecfrmc_renamexf(iq,ipair) - lstoo = lspectooc_renamexf(iq,ipair) + lsfrm = lspecfrmc_csizxf(iq,ipair) + lstoo = lspectooc_csizxf(iq,ipair) if ((lsfrm > 0) .and. (lstoo > 0)) then dotendqqcw(lsfrm) = .true. dotendqqcw(lstoo) = .true. @@ -778,8 +985,8 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, do_adjust_in, & noxf_acc2ait(:) = .true. do l1 = 1, nspec_amode(nacc) la = lmassptr_amode(l1,nacc) - do iq = 1, nspecfrm_renamexf(ipair) - if (lspectooa_renamexf(iq,ipair) == la) then + do iq = 1, nspecfrm_csizxf(ipair) + if (lspectooa_csizxf(iq,ipair) == la) then noxf_acc2ait(l1) = .false. end if end do @@ -976,26 +1183,26 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, do_adjust_in, & if ( masterproc ) then if (idiagaa > 0) then do j = 1, 2 - do iq = 1, nspecfrm_renamexf(ipair) + do iq = 1, nspecfrm_csizxf(ipair) do jac = 1, 2 if (j .eq. 1) then if (jac .eq. 1) then - lsfrm = lspecfrma_renamexf(iq,ipair) - lstoo = lspectooa_renamexf(iq,ipair) + lsfrm = lspecfrma_csizxf(iq,ipair) + lstoo = lspectooa_csizxf(iq,ipair) else - lsfrm = lspecfrmc_renamexf(iq,ipair) - lstoo = lspectooc_renamexf(iq,ipair) + lsfrm = lspecfrmc_csizxf(iq,ipair) + lstoo = lspectooc_csizxf(iq,ipair) end if else if (jac .eq. 1) then - lsfrm = lspectooa_renamexf(iq,ipair) - lstoo = lspecfrma_renamexf(iq,ipair) + lsfrm = lspectooa_csizxf(iq,ipair) + lstoo = lspecfrma_csizxf(iq,ipair) else - lsfrm = lspectooc_renamexf(iq,ipair) - lstoo = lspecfrmc_renamexf(iq,ipair) + lsfrm = lspectooc_csizxf(iq,ipair) + lstoo = lspecfrmc_csizxf(iq,ipair) end if end if - write( 6, '(a,3i3,2i4)' ) 'calcsize j,iq,jac, lsfrm,lstoo', & + write( iulog, '(a,3i3,2i4)' ) 'calcsize j,iq,jac, lsfrm,lstoo', & j,iq,jac, lsfrm,lstoo end do end do @@ -1018,30 +1225,30 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, do_adjust_in, & xfercoef = xfercoef_vol_acc2ait end if - do iq = 1, nspecfrm_renamexf(ipair) + do iq = 1, nspecfrm_csizxf(ipair) ! jac=1 does interstitial ("_a"); jac=2 does activated ("_c"); do jac = 1, 2 - ! the lspecfrma_renamexf (and lspecfrmc_renamexf) are aitken species - ! the lspectooa_renamexf (and lspectooc_renamexf) are accum species + ! the lspecfrma_csizxf (and lspecfrmc_csizxf) are aitken species + ! the lspectooa_csizxf (and lspectooc_csizxf) are accum species ! for j=1, want lsfrm=aitken species, lstoo=accum species ! for j=2, want lsfrm=accum species, lstoo=aitken species if (j .eq. 1) then if (jac .eq. 1) then - lsfrm = lspecfrma_renamexf(iq,ipair) - lstoo = lspectooa_renamexf(iq,ipair) + lsfrm = lspecfrma_csizxf(iq,ipair) + lstoo = lspectooa_csizxf(iq,ipair) else - lsfrm = lspecfrmc_renamexf(iq,ipair) - lstoo = lspectooc_renamexf(iq,ipair) + lsfrm = lspecfrmc_csizxf(iq,ipair) + lstoo = lspectooc_csizxf(iq,ipair) end if else if (jac .eq. 1) then - lsfrm = lspectooa_renamexf(iq,ipair) - lstoo = lspecfrma_renamexf(iq,ipair) + lsfrm = lspectooa_csizxf(iq,ipair) + lstoo = lspecfrma_csizxf(iq,ipair) else - lsfrm = lspectooc_renamexf(iq,ipair) - lstoo = lspecfrmc_renamexf(iq,ipair) + lsfrm = lspectooc_csizxf(iq,ipair) + lstoo = lspecfrmc_csizxf(iq,ipair) end if end if @@ -1129,19 +1336,19 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, do_adjust_in, & ! history fields for aitken-accum transfer if ( .not. do_aitacc_transfer ) return - do iq = 1, nspecfrm_renamexf(ipair) + do iq = 1, nspecfrm_csizxf(ipair) ! jac=1 does interstitial ("_a"); jac=2 does activated ("_c"); do jac = 1, 2 - ! the lspecfrma_renamexf (and lspecfrmc_renamexf) are aitken species - ! the lspectooa_renamexf (and lspectooc_renamexf) are accum species + ! the lspecfrma_csizxf (and lspecfrmc_csizxf) are aitken species + ! the lspectooa_csizxf (and lspectooc_csizxf) are accum species if (jac .eq. 1) then - lsfrm = lspecfrma_renamexf(iq,ipair) - lstoo = lspectooa_renamexf(iq,ipair) + lsfrm = lspecfrma_csizxf(iq,ipair) + lstoo = lspectooa_csizxf(iq,ipair) else - lsfrm = lspecfrmc_renamexf(iq,ipair) - lstoo = lspectooc_renamexf(iq,ipair) + lsfrm = lspecfrmc_csizxf(iq,ipair) + lstoo = lspectooc_csizxf(iq,ipair) end if if ((lsfrm <= 0) .or. (lstoo <= 0)) cycle @@ -1237,9 +1444,9 @@ subroutine modal_aero_calcsize_diag(state, pbuf, list_idx_in, dgnum_m) call endrun('modal_aero_calcsize_diag called for'// & 'diagnostic list but dgnum_m pointer not present') end if - if (.not. associated(dgnum_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but dgnum_m not associated') + allocate(dgnum_m(pcols,pver,nmodes), stat=stat) + if (stat > 0) then + call endrun('modal_aero_calcsize_diag: allocation FAILURE: dgnum_m') end if end if diff --git a/components/cam/src/physics/cam/phys_control.F90 b/components/cam/src/physics/cam/phys_control.F90 index a14ae96632b9..c2fc198ef28f 100644 --- a/components/cam/src/physics/cam/phys_control.F90 +++ b/components/cam/src/physics/cam/phys_control.F90 @@ -72,6 +72,9 @@ module phys_control ! convproc_method_activate - 1=apply abdulrazzak-ghan to entrained aerosols for lowest nlayers ! 2=do secondary activation with prescribed supersat integer :: convproc_method_activate = 2 ! controls activation in the unified convective transport/removal +integer :: mam_amicphys_optaa = 0 ! <= 0 -- use old microphysics code (separate calls to gasaerexch, + ! newnuc, and coag routines) + ! > 0 -- use new microphysics code (single call to amicphys routine) logical :: liqcf_fix = .false. ! liq cld fraction fix calc. logical :: regen_fix = .false. ! aerosol regeneration bug fix for ndrop.F90 logical :: demott_ice_nuc = .false. ! use DeMott ice nucleation treatment in microphysics @@ -151,6 +154,7 @@ subroutine phys_ctl_readnl(nlfile) cld_macmic_num_steps, micro_do_icesupersat, & fix_g1_err_ndrop, ssalt_tuning, resus_fix, convproc_do_aer, & convproc_do_gas, convproc_method_activate, liqcf_fix, regen_fix, demott_ice_nuc, & + mam_amicphys_optaa, & l_tracer_aero, l_vdiff, l_rayleigh, l_gw_drag, l_ac_energy_chk, & l_bc_energy_fix, l_dry_adj, l_st_mac, l_st_mic, l_rad !----------------------------------------------------------------------------- @@ -207,6 +211,7 @@ subroutine phys_ctl_readnl(nlfile) call mpibcast(convproc_do_aer, 1 , mpiint, 0, mpicom) call mpibcast(convproc_do_gas, 1 , mpilog, 0, mpicom) call mpibcast(convproc_method_activate, 1 , mpilog, 0, mpicom) + call mpibcast(mam_amicphys_optaa, 1 , mpilog, 0, mpicom) call mpibcast(liqcf_fix, 1 , mpilog, 0, mpicom) call mpibcast(regen_fix, 1 , mpilog, 0, mpicom) call mpibcast(demott_ice_nuc, 1 , mpilog, 0, mpicom) @@ -341,7 +346,7 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi do_clubb_sgs_out, do_tms_out, state_debug_checks_out, & cld_macmic_num_steps_out, micro_do_icesupersat_out, & fix_g1_err_ndrop_out, ssalt_tuning_out,resus_fix_out,convproc_do_aer_out, & - convproc_do_gas_out, convproc_method_activate_out, & + convproc_do_gas_out, convproc_method_activate_out, mam_amicphys_optaa_out, & liqcf_fix_out, regen_fix_out,demott_ice_nuc_out & ,l_tracer_aero_out, l_vdiff_out, l_rayleigh_out, l_gw_drag_out, l_ac_energy_chk_out & ,l_bc_energy_fix_out, l_dry_adj_out, l_st_mac_out, l_st_mic_out, l_rad_out & @@ -386,6 +391,7 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi logical, intent(out), optional :: convproc_do_aer_out logical, intent(out), optional :: convproc_do_gas_out integer, intent(out), optional :: convproc_method_activate_out + integer, intent(out), optional :: mam_amicphys_optaa_out logical, intent(out), optional :: liqcf_fix_out logical, intent(out), optional :: regen_fix_out logical, intent(out), optional :: demott_ice_nuc_out @@ -433,7 +439,8 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi if ( present(resus_fix_out ) ) resus_fix_out = resus_fix if ( present(convproc_do_aer_out ) ) convproc_do_aer_out = convproc_do_aer if ( present(convproc_do_gas_out ) ) convproc_do_gas_out = convproc_do_gas - if ( present(convproc_method_activate_out))convproc_method_activate_out= convproc_method_activate + if ( present(convproc_method_activate_out ) ) convproc_method_activate_out = convproc_method_activate + if ( present(mam_amicphys_optaa_out ) ) mam_amicphys_optaa_out = mam_amicphys_optaa if ( present(liqcf_fix_out ) ) liqcf_fix_out = liqcf_fix if ( present(regen_fix_out ) ) regen_fix_out = regen_fix if ( present(demott_ice_nuc_out ) ) demott_ice_nuc_out = demott_ice_nuc diff --git a/components/cam/src/physics/cam/physpkg.F90 b/components/cam/src/physics/cam/physpkg.F90 index 2c5f42fca94d..0a2112dfcc19 100644 --- a/components/cam/src/physics/cam/physpkg.F90 +++ b/components/cam/src/physics/cam/physpkg.F90 @@ -852,7 +852,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) ! here. For prognostic MAM the initialization is called from ! modal_aero_initialize if (.not. prog_modal_aero) then - call modal_aero_calcsize_init(pbuf2d) + call modal_aero_calcsize_init(pbuf2d, species_class) endif call modal_aero_wateruptake_init(pbuf2d) diff --git a/components/rtm/src/riverroute/RtmMod.F90 b/components/rtm/src/riverroute/RtmMod.F90 index 08aff5909503..febeb4d1804f 100644 --- a/components/rtm/src/riverroute/RtmMod.F90 +++ b/components/rtm/src/riverroute/RtmMod.F90 @@ -87,6 +87,7 @@ module RtmMod character(len=256) :: nlfilename_rof = 'rof_in' character(len=256) :: nlfilename_lnd = 'lnd_in' + real(r8), save :: delt_save ! previous delt !BSINGH- declare and initialize it globally ! !EOP !----------------------------------------------------------------------- @@ -976,7 +977,7 @@ subroutine Rtmini() call RtmHistFldsSet() if (masterproc) write(iulog,*) subname //':: Success ' - + delt_save = 0.0 end subroutine Rtmini !======================================================================= @@ -1028,7 +1029,7 @@ subroutine Rtmrun(totrunin, rstwr, nlend, rdate) real(r8) :: delt ! delt associated with subcycling real(r8) :: delt_rtm ! real value of rtm_tstep integer , save :: nsub_save ! previous nsub - real(r8), save :: delt_save ! previous delt + !real(r8), save :: delt_save ! previous delt !BSINGH- declare and initialize it globally logical , save :: first_time = .true. ! first time flag (for backwards compatibility) character(len=256) :: filer ! restart file name integer,parameter :: dbug = 1 ! local debug flag