From d1a1be766dd1c0138ce0c07cf784baefbe67caa0 Mon Sep 17 00:00:00 2001 From: Haipeng Lin Date: Wed, 24 Jun 2026 22:50:16 -0400 Subject: [PATCH 1/6] Refactor MAM into portable code (remove CAM dependencies) and move to atmos_phys This is the first step to CCPP conversion of MAM. This PR completes the CAM side work. It refactors CAM-specific code into CAM interfaces (_cam suffix) and includes the MAM core science code sourced from the atmos_phys external. Refactor into portable code: modal_aero_calcsize, wateruptake, gasaerexch, rename Refactor into portable code: modal_aero_calcsize, wateruptake, gasaerexch Initial try at converting modal_aero_calcsize into portable code. Initial try at converting modal_aero_wateruptake into portable code. Put modal_aero_calcdry_run back in the portable subroutine and eliminate dual-path method - move to CAM interface. Cleanup; rewire modal_strat_sulfate Initial attempt for modal_aero_gasaerexch portability Build fixes. Alternate approach for modal_strat_sulfate (put in modal_aero_data) that does not need circular depends Diagnostic b4b (partial) fix; loffset build fix B4B fix for gasaerexch. B4B fixes Various cleanup; thread through rair B4B fix 3 Thread pi through calcsize_dry_run Initial attempt for modal_aero_rename portability. Follow-up cleanups to modal_aero_rename refactor. Refactor into portable code: modal_aero_newnuc (tendency-return). Refactor into portable code: modal_aero_coag (in-place vmr, dqdt diagnostic-only). Refactor into portable code: mo_setsox aqueous sulfur chemistry (setsox_sub + sox_cldaero + cldaero portable; mo_setsox_cam wrapper). Refactor into portable code: aero_activate (activate_aerosol) + wetdep split; rewire convproc call sites. Extract the Abdul-Razzak & Ghan activation kernel activate_aerosol from ndrop.F90 into portable aero_activate.F90. Split wetdep.F90 into portable science (clddiag, wetdepa_v1, wetdepa_v2) Refactor into portable code: full aero_convproc split + impaction tables to wetdep. Remove pre-existing dead code from wetdep scavenging routines (unused dummies/locals). Remove pre-existing dead code from aerosol drydep path. Refactor into portable code: aerosol drydep leaves + dust_sediment_mod. Remove aer_drydep_mod.F90: fully dead after the drydep portable split. Behavior-neutral; separate commit so CAM regression b4b can bisect it. Remove pre-existing dead code from MAM dust/seasalt emissions path. Refactor into portable code: MAM dust + seasalt emissions cores. Rename to avoid naming conflict with GEOS-Chem Remove pre-existing dead code from ndrop gas-mixing path. Refactor into portable code: ndrop (dropmixnuc) droplet activation core. Unify the calcsize/wateruptake diag path in modal_aerosol_state_mod for CAM and CAM-SIMA. Cleanup modal_aero_calcsize/wateruptake diag paths as they are moved to portable code. --- src/chemistry/aerosol/aer_drydep_mod.F90 | 268 -- src/chemistry/aerosol/aero_convproc.F90 | 788 ++---- src/chemistry/aerosol/aero_convproc_cam.F90 | 590 +++++ src/chemistry/aerosol/aero_drydep_core.F90 | 319 +++ src/chemistry/aerosol/aero_wetdep_cam.F90 | 448 +--- src/chemistry/aerosol/aerosol_optics_core.F90 | 47 +- src/chemistry/aerosol/aerosol_state_mod.F90 | 35 +- .../aerosol/bulk_aerosol_state_mod.F90 | 27 +- .../aerosol/carma_aerosol_state_mod.F90 | 27 +- src/chemistry/aerosol/cldaero_mod.F90 | 21 +- src/chemistry/aerosol/dust_common.F90 | 35 +- src/chemistry/aerosol/dust_sediment_mod.F90 | 219 +- src/chemistry/aerosol/mo_setsox.F90 | 273 +-- src/chemistry/aerosol/mo_setsox_cam.F90 | 321 +++ src/chemistry/aerosol/modal_aero_data.F90 | 2 + .../aerosol/modal_aerosol_state_mod.F90 | 168 +- .../aerosol/refractive_aerosol_optics_mod.F90 | 11 +- src/chemistry/aerosol/sox_cldaero_mod.F90 | 67 +- src/chemistry/aerosol/wetdep.F90 | 1073 ++++---- src/chemistry/aerosol/wetdep_cam.F90 | 402 +++ src/chemistry/bulk_aero/aero_model.F90 | 58 +- src/chemistry/bulk_aero/dust_model.F90 | 9 +- src/chemistry/carma_aero/aero_model.F90 | 4 +- src/chemistry/geoschem/chemistry.F90 | 2 +- src/chemistry/modal_aero/aero_model.F90 | 770 +++--- src/chemistry/modal_aero/dust_model.F90 | 97 +- src/chemistry/modal_aero/modal_aero_coag.F90 | 549 ++--- .../modal_aero/modal_aero_coag_cam.F90 | 416 ++++ .../modal_aero/modal_aero_gasaerexch.F90 | 1655 +++++-------- .../modal_aero/modal_aero_gasaerexch_cam.F90 | 497 ++++ .../modal_aero/modal_aero_newnuc.F90 | 351 +-- .../modal_aero/modal_aero_newnuc_cam.F90 | 200 ++ .../modal_aero/modal_aero_rename.F90 | 2163 +++++++---------- .../modal_aero/modal_aero_rename_cam.F90 | 601 +++++ .../modal_aero/modal_dust_emissions.F90 | 138 ++ .../modal_aero/modal_seasalt_emissions.F90 | 98 + src/chemistry/modal_aero/seasalt_model.F90 | 58 +- src/chemistry/utils/modal_aero_calcsize.F90 | 1179 +++------ .../utils/modal_aero_calcsize_cam.F90 | 702 ++++++ .../utils/modal_aero_wateruptake.F90 | 1095 ++++----- .../utils/modal_aero_wateruptake_cam.F90 | 453 ++++ src/physics/cam/aero_activate.F90 | 429 ++++ src/physics/cam/aerosol_mmr_host.F90 | 57 + src/physics/cam/aerosol_optics_cam.F90 | 32 +- src/physics/cam/microp_aero.F90 | 266 +- src/physics/cam/ndrop.F90 | 767 ++---- src/physics/cam/physpkg.F90 | 8 +- src/physics/cam7/physpkg.F90 | 8 +- src/physics/carma/cam/carma_intr.F90 | 25 +- 49 files changed, 10139 insertions(+), 7689 deletions(-) delete mode 100644 src/chemistry/aerosol/aer_drydep_mod.F90 create mode 100644 src/chemistry/aerosol/aero_convproc_cam.F90 create mode 100644 src/chemistry/aerosol/aero_drydep_core.F90 create mode 100644 src/chemistry/aerosol/mo_setsox_cam.F90 create mode 100644 src/chemistry/aerosol/wetdep_cam.F90 create mode 100644 src/chemistry/modal_aero/modal_aero_coag_cam.F90 create mode 100644 src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 create mode 100644 src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 create mode 100644 src/chemistry/modal_aero/modal_aero_rename_cam.F90 create mode 100644 src/chemistry/modal_aero/modal_dust_emissions.F90 create mode 100644 src/chemistry/modal_aero/modal_seasalt_emissions.F90 create mode 100644 src/chemistry/utils/modal_aero_calcsize_cam.F90 create mode 100644 src/chemistry/utils/modal_aero_wateruptake_cam.F90 create mode 100644 src/physics/cam/aero_activate.F90 diff --git a/src/chemistry/aerosol/aer_drydep_mod.F90 b/src/chemistry/aerosol/aer_drydep_mod.F90 deleted file mode 100644 index 512a8bdc5b..0000000000 --- a/src/chemistry/aerosol/aer_drydep_mod.F90 +++ /dev/null @@ -1,268 +0,0 @@ -module aer_drydep_mod - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid - - ! Shared Data for dry deposition calculation. - - real(r8) rair ! Gas constant for dry air (J/K/kg) - real(r8) gravit ! Gravitational acceleration -! real(r8), allocatable :: phi(:) ! grid latitudes (radians)11 - -contains - -!############################################################################## - -! $Id$ - - subroutine inidrydep( xrair, xgravit) !, xphi ) - -! Initialize dry deposition parameterization. - - implicit none - -! Input arguments: - real(r8), intent(in) :: xrair ! Gas constant for dry air - real(r8), intent(in) :: xgravit ! Gravitational acceleration -! real(r8), intent(in) :: xphi(:) ! grid latitudes (radians) - -! Local variables: - integer i, j, ncid, vid, ns -!----------------------------------------------------------------------- -! ns = size(xphi) -! allocate(phi(ns)) - rair = xrair - gravit = xgravit -! do j = 1, ns -! phi(j) = xphi(j) -! end do - - return - end subroutine inidrydep - -!############################################################################## - - subroutine setdvel( ncol, landfrac, icefrac, ocnfrac, vgl, vgo, vgsi, vg ) - -! Set the deposition velocity depending on whether we are over -! land, ocean, and snow/ice - - - implicit none - -! Input arguments: - - integer, intent(in) :: ncol - real (r8), intent(in) :: landfrac(pcols) ! land fraction - real (r8), intent(in) :: icefrac(pcols) ! ice fraction - real (r8), intent(in) :: ocnfrac(pcols) ! ocean fraction - - real(r8), intent(in) :: vgl ! dry deposition velocity in m/s (land) - real(r8), intent(in) :: vgo ! dry deposition velocity in m/s (ocean) - real(r8), intent(in) :: vgsi ! dry deposition velocity in m/s (snow/ice) - -! Output arguments: - real(r8), intent(out) :: vg(pcols) ! dry deposition velocity in m/s - -! Local variables: - - integer i - real(r8) a - - - do i = 1, ncol - vg(i) = landfrac(i)*vgl + ocnfrac(i)*vgo + icefrac(i)*vgsi -! if (ioro(i).eq.0) then -! vg(i) = vgo -! else if (ioro(i).eq.1) then -! vg(i) = vgl -! else -! vg(i) = vgsi -! endif - end do - - return - end subroutine setdvel - -!############################################################################## - - subroutine ddflux( ncol, vg, q, p, tv, flux ) - -! Compute surface flux due to dry deposition processes. - - - implicit none - -! Input arguments: - integer , intent(in) :: ncol - real(r8), intent(in) :: vg(pcols) ! dry deposition velocity in m/s - real(r8), intent(in) :: q(pcols) ! tracer conc. in surface layer (kg tracer/kg moist air) - real(r8), intent(in) :: p(pcols) ! midpoint pressure in surface layer (Pa) - real(r8), intent(in) :: tv(pcols) ! midpoint virtual temperature in surface layer (K) - -! Output arguments: - - real(r8), intent(out) :: flux(pcols) ! flux due to dry deposition in kg/m^s/sec - -! Local variables: - - integer i - - do i = 1, ncol - flux(i) = -vg(i) * q(i) * p(i) /(tv(i) * rair) - end do - - return - end subroutine ddflux - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: subroutine d3ddflux -! -! !INTERFACE: -! - subroutine d3ddflux ( ncol, vlc_dry, q,pmid,pdel, tv, dep_dry,dep_dry_tend,dt) -! Description: -!Do 3d- settling deposition calculations following Zender's dust codes, Dec 02. -! -! Author: Natalie Mahowald -! - implicit none - -! Input arguments: - integer , intent(in) :: ncol - real(r8), intent(in) :: vlc_dry(pcols,pver) ! dry deposition velocity in m/s - real(r8), intent(in) :: q(pcols,pver) ! tracer conc. in surface layer (kg tracer/kg moist air) - real(r8), intent(in) :: pmid(pcols,pver) ! midpoint pressure in surface layer (Pa) - real(r8), intent(in) :: pdel(pcols,pver) ! delta pressure across level (Pa) - real(r8), intent(in) :: tv(pcols,pver) ! midpoint virtual temperature in surface layer (K) - real(r8), intent(in) :: dt ! time step - -! Output arguments: - - real(r8), intent(out) :: dep_dry(pcols) ! flux due to dry deposition in kg /m^s/sec - real(r8), intent(out) :: dep_dry_tend(pcols,pver) ! flux due to dry deposition in kg /m^s/sec - -! Local variables: - - real(r8) :: flux(pcols,0:pver) ! downward flux at each level: kg/m2/s - integer i,k - do i=1,ncol - flux(i,0)=0._r8 - enddo - do k=1,pver - do i = 1, ncol - flux(i,k) = -min(vlc_dry(i,k) * q(i,k) * pmid(i,k) /(tv(i,k) * rair), & - q(i,k)*pdel(i,k)/gravit/dt) - dep_dry_tend(i,k)=(flux(i,k)-flux(i,k-1))/pdel(i,k)*gravit !kg/kg/s - - end do - enddo -! surface flux: - do i=1,ncol - dep_dry(i)=flux(i,pver) - enddo - return - end subroutine d3ddflux - - - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: subroutine Calcram -! -! !INTERFACE: -! - - subroutine calcram(ncol,landfrac,icefrac,ocnfrac,obklen,& - ustar,ram1in,ram1,t,pmid,& - pdel,fvin,fv) - ! - ! !DESCRIPTION: - ! - ! Calc aerodynamic resistance over oceans and sea ice (comes in from land model) - ! from Seinfeld and Pandis, p.963. - ! - ! Author: Natalie Mahowald - ! - implicit none - integer, intent(in) :: ncol - real(r8),intent(in) :: ram1in(pcols) !aerodynamical resistance (s/m) - real(r8),intent(in) :: fvin(pcols) ! sfc frc vel from land - real(r8),intent(out) :: ram1(pcols) !aerodynamical resistance (s/m) - real(r8),intent(out) :: fv(pcols) ! sfc frc vel from land - real(r8), intent(in) :: obklen(pcols) ! obklen - real(r8), intent(in) :: ustar(pcols) ! sfc fric vel - real(r8), intent(in) :: landfrac(pcols) ! land fraction - real(r8), intent(in) :: icefrac(pcols) ! ice fraction - real(r8), intent(in) :: ocnfrac(pcols) ! ocean fraction - real(r8), intent(in) :: t(pcols) !atm temperature (K) - real(r8), intent(in) :: pmid(pcols) !atm pressure (Pa) - real(r8), intent(in) :: pdel(pcols) !atm pressure (Pa) - real(r8), parameter :: zzocen = 0.0001_r8 ! Ocean aerodynamic roughness length - real(r8), parameter :: zzsice = 0.0400_r8 ! Sea ice aerodynamic roughness length - real(r8), parameter :: xkar = 0.4_r8 ! Von Karman constant - - ! local variables - real(r8) :: z,psi,psi0,nu,nu0,temp,ram - integer :: i - ! write(iulog,*) rair,zzsice,zzocen,gravit,xkar - - - do i=1,ncol - z=pdel(i)*rair*t(i)/pmid(i)/gravit/2.0_r8 !use half the layer height like Ganzefeld and Lelieveld, 1995 - if(obklen(i).eq.0) then - psi=0._r8 - psi0=0._r8 - else - psi=min(max(z/obklen(i),-1.0_r8),1.0_r8) - psi0=min(max(zzocen/obklen(i),-1.0_r8),1.0_r8) - endif - temp=z/zzocen - if(icefrac(i) > 0.5_r8) then - if(obklen(i).gt.0) then - psi0=min(max(zzsice/obklen(i),-1.0_r8),1.0_r8) - else - psi0=0.0_r8 - endif - temp=z/zzsice - endif - if(psi> 0._r8) then - ram=1/xkar/ustar(i)*(log(temp)+4.7_r8*(psi-psi0)) - else - nu=(1.00_r8-15.000_r8*psi)**(.25_r8) - nu0=(1.000_r8-15.000_r8*psi0)**(.25_r8) - if(ustar(i).ne.0._r8) then - ram=1/xkar/ustar(i)*(log(temp) & - +log(((nu0**2+1.00_r8)*(nu0+1.0_r8)**2)/((nu**2+1.0_r8)*(nu+1.00_r8)**2)) & - +2.0_r8*(atan(nu)-atan(nu0))) - else - ram=0._r8 - endif - endif - if(landfrac(i) < 0.000000001_r8) then - fv(i)=ustar(i) - ram1(i)=ram - else - fv(i)=fvin(i) - ram1(i)=ram1in(i) - endif - ! write(iulog,*) i,pdel(i),t(i),pmid(i),gravit,obklen(i),psi,psi0,icefrac(i),nu,nu0,ram,ustar(i),& - ! log(((nu0**2+1.00)*(nu0+1.0)**2)/((nu**2+1.0)*(nu+1.00)**2)),2.0*(atan(nu)-atan(nu0)) - - enddo - - ! fvitt -- fv == 0 causes a floating point exception in - ! dry dep of sea salts and dust - where ( fv(:ncol) == 0._r8 ) - fv(:ncol) = 1.e-12_r8 - endwhere - - return - end subroutine calcram - - -!############################################################################## -end module aer_drydep_mod diff --git a/src/chemistry/aerosol/aero_convproc.F90 b/src/chemistry/aerosol/aero_convproc.F90 index 33b918e044..d7fa640a39 100644 --- a/src/chemistry/aerosol/aero_convproc.F90 +++ b/src/chemistry/aerosol/aero_convproc.F90 @@ -2,7 +2,7 @@ module aero_convproc !--------------------------------------------------------------------------------- ! Purpose: ! -! CAM interface to aerosol/trace-gas convective cloud processing scheme +! Portable aerosol/trace-gas convective cloud processing scheme ! ! currently these routines assume stratiform and convective clouds only interact ! through the detrainment of convective cloudborne material into stratiform clouds @@ -15,580 +15,49 @@ module aero_convproc !--------------------------------------------------------------------------------- use shr_kind_mod, only: r8=>shr_kind_r8 -use shr_kind_mod, only: shr_kind_cs - -use spmd_utils, only: masterproc -use physconst, only: gravit, rair -use ppgrid, only: pver, pcols, pverp -use constituents, only: pcnst, cnst_get_ind -use constituents, only: cnst_species_class, cnst_spec_class_aerosol -use phys_control, only: phys_getopts - -use physics_types, only: physics_state, physics_ptend -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field -use time_manager, only: get_nstep -use cam_history, only: outfld, addfld, add_default, horiz_only -use cam_logfile, only: iulog -use cam_abortutils, only: endrun use aerosol_properties_mod, only: aerosol_properties -use aerosol_state_mod, only: aerosol_state, ptr2d_t implicit none private -public :: aero_convproc_readnl -public :: aero_convproc_init -public :: aero_convproc_intr +public :: aero_convproc_run -! namelist options -! NOTE: These are the defaults for CAM6. -logical, protected, public :: deepconv_wetdep_history = .true. -logical, protected, public :: convproc_do_deep = .true. -! NOTE: These are the defaults for the Eaton/Wang parameterization. -logical, protected, public :: convproc_do_evaprain_atonce = .false. -real(r8), protected, public :: convproc_pom_spechygro = -1._r8 -real(r8), protected, public :: convproc_wup_max = 4.0_r8 - -logical, parameter :: use_cwaer_for_activate_maxsat = .false. -logical, parameter :: apply_convproc_tend_to_ptend = .true. - -real(r8) :: hund_ovr_g ! = 100.0_r8/gravit -! used with zm_conv mass fluxes and delta-p -! for mu = [mbar/s], mu*hund_ovr_g = [kg/m2/s] -! for dp = [mbar] and q = [kg/kg], q*dp*hund_ovr_g = [kg/m2] +logical, parameter, public :: use_cwaer_for_activate_maxsat = .false. ! method1_activate_nlayers = number of layers (including cloud base) where activation is applied -integer, parameter :: method1_activate_nlayers = 2 +integer, parameter, public :: method1_activate_nlayers = 2 ! method2_activate_smaxmax = the uniform or peak supersat value (as 0-1 fraction = percent*0.01) -real(r8), parameter :: method2_activate_smaxmax = 0.003_r8 +real(r8), parameter, public :: method2_activate_smaxmax = 0.003_r8 ! method_reduce_actfrac = 1 -- multiply activation fractions by factor_reduce_actfrac ! (this works ok with convproc_method_activate = 1 but not for ... = 2) ! = 2 -- do 2 iterations to get an overall reduction by factor_reduce_actfrac ! (this works ok with convproc_method_activate = 1 or 2) ! = other -- do nothing involving reduce_actfrac -integer, parameter :: method_reduce_actfrac = 0 -real(r8), parameter :: factor_reduce_actfrac = 0.5_r8 +integer, parameter, public :: method_reduce_actfrac = 0 +real(r8), parameter, public :: factor_reduce_actfrac = 0.5_r8 ! convproc_method_activate - 1=apply abdulrazzak-ghan to entrained aerosols for lowest nlayers ! 2=do secondary activation with prescribed supersat -integer, parameter :: convproc_method_activate = 2 - -logical :: convproc_do_aer - -! physics buffer indices -integer :: fracis_idx = 0 - -integer :: rprddp_idx = 0 -integer :: rprdsh_idx = 0 -integer :: nevapr_shcu_idx = 0 -integer :: nevapr_dpcu_idx = 0 - -integer :: icwmrdp_idx = 0 -integer :: icwmrsh_idx = 0 -integer :: sh_frac_idx = 0 -integer :: dp_frac_idx = 0 - -integer :: zm_eu_idx = 0 -integer :: zm_du_idx = 0 -integer :: zm_ed_idx = 0 -integer :: zm_dp_idx = 0 -integer :: zm_jt_idx = 0 -integer :: zm_maxg_idx = 0 -integer :: zm_ideep_idx = 0 - -integer :: cmfmc_sh_idx = 0 -integer :: sh_e_ed_ratio_idx = 0 - -integer :: istat - -integer :: nbins = 0 -integer :: ncnstaer = 0 - -integer, allocatable :: aer_cnst_ndx(:) - -character(len=32), allocatable :: cnst_name_extd(:,:) ! (2,ncnstaer) +integer, parameter, public :: convproc_method_activate = 2 contains -!========================================================================================= -subroutine aero_convproc_readnl(nlfile) - - use namelist_utils, only: find_group_name - use spmd_utils, only: mpicom, masterprocid, mpi_real8, mpi_logical - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'aero_convproc_readnl' - - namelist /aerosol_convproc_opts/ deepconv_wetdep_history, convproc_do_deep, & - convproc_do_evaprain_atonce, convproc_pom_spechygro, convproc_wup_max - - ! Read namelist - if (masterproc) then - open( newunit=unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'aerosol_convproc_opts', status=ierr) - if (ierr == 0) then - read(unitn, aerosol_convproc_opts, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - end if - - ! Broadcast namelist variables - call mpi_bcast( deepconv_wetdep_history, 1, mpi_logical, masterprocid, mpicom, ierr) - call mpi_bcast( convproc_do_deep, 1, mpi_logical, masterprocid, mpicom, ierr) - call mpi_bcast( convproc_do_evaprain_atonce, 1, mpi_logical, masterprocid, mpicom, ierr) - call mpi_bcast( convproc_pom_spechygro, 1, mpi_real8, masterprocid, mpicom, ierr) - call mpi_bcast( convproc_wup_max, 1, mpi_real8, masterprocid, mpicom, ierr) - - if (masterproc) then - write(iulog,*) subname//': deepconv_wetdep_history = ',deepconv_wetdep_history - write(iulog,*) subname//': convproc_do_deep = ',convproc_do_deep - write(iulog,*) subname//': convproc_do_evaprain_atonce = ',convproc_do_evaprain_atonce - write(iulog,*) subname//': convproc_pom_spechygro = ',convproc_pom_spechygro - write(iulog,*) subname//': convproc_wup_max = ', convproc_wup_max - end if - -end subroutine aero_convproc_readnl - -!========================================================================================= - -subroutine aero_convproc_init(aero_props) - - class(aerosol_properties), intent(in) :: aero_props - - integer :: m, mm, l, ndx, astat - integer :: npass_calc_updraft - logical :: history_aerosol - character(len=32) :: name_a, name_c - - character(len=*), parameter :: prefix = 'aero_convproc_init: ' - - hund_ovr_g = 100.0_r8/gravit - ! used with zm_conv mass fluxes and delta-p - ! for mu = [mbar/s], mu*hund_ovr_g = [kg/m2/s] - ! for dp = [mbar] and q = [kg/kg], q*dp*hund_ovr_g = [kg/m2] - - nbins = aero_props%nbins() - ncnstaer = aero_props%ncnst_tot() - - allocate(aer_cnst_ndx(ncnstaer),stat=astat) - if (astat/=0) then - call endrun(prefix//'aer_cnst_ndx allocation error') - end if - allocate(cnst_name_extd(2,ncnstaer),stat=astat) - if (astat/=0) then - call endrun(prefix//'cnst_name_extd allocation error') - end if - - aer_cnst_ndx(:) = -1 - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - if (l==0) then - call aero_props%num_names(m, name_a, name_c) - else - call aero_props%mmr_names(m,l, name_a, name_c) - endif - cnst_name_extd(1,mm) = name_a - cnst_name_extd(2,mm) = name_c - - call cnst_get_ind(trim(name_a), ndx, abort=.false.) - aer_cnst_ndx(mm) = ndx - end do - end do - - call phys_getopts( history_aerosol_out=history_aerosol, & - convproc_do_aer_out = convproc_do_aer ) - - call addfld('DP_MFUP_MAX', horiz_only, 'A', 'kg/m2', & - 'Deep conv. column-max updraft mass flux' ) - call addfld('DP_WCLDBASE', horiz_only, 'A', 'm/s', & - 'Deep conv. cloudbase vertical velocity' ) - call addfld('DP_KCLDBASE', horiz_only, 'A', '1', & - 'Deep conv. cloudbase level index' ) - - ! output wet deposition fields to history - ! I = in-cloud removal; E = precip-evap resuspension - ! C = convective (total); D = deep convective - ! note that the precip-evap resuspension includes that resulting from - ! below-cloud removal, calculated in mz_aero_wet_intr - if (convproc_do_aer .and. apply_convproc_tend_to_ptend ) then - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - - ndx = aer_cnst_ndx(mm) - - if ( deepconv_wetdep_history ) then - call addfld (trim(cnst_name_extd(1,mm))//'SFSID', & - horiz_only, 'A','kg/m2/s','Wet deposition flux (incloud, deep convective) at surface') - call addfld (trim(cnst_name_extd(1,mm))//'SFSED', & - horiz_only, 'A','kg/m2/s','Wet deposition flux (precip evap, deep convective) at surface') - if (history_aerosol) then - call add_default(trim(cnst_name_extd(1,mm))//'SFSID', 1, ' ') - call add_default(trim(cnst_name_extd(1,mm))//'SFSED', 1, ' ') - end if - end if - - end do - end do - end if - - if ( history_aerosol .and. convproc_do_aer ) then - call add_default( 'DP_MFUP_MAX', 1, ' ' ) - call add_default( 'DP_WCLDBASE', 1, ' ' ) - call add_default( 'DP_KCLDBASE', 1, ' ' ) - end if - - fracis_idx = pbuf_get_index('FRACIS') - - rprddp_idx = pbuf_get_index('RPRDDP') - rprdsh_idx = pbuf_get_index('RPRDSH') - nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') - nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') - - icwmrdp_idx = pbuf_get_index('ICWMRDP') - icwmrsh_idx = pbuf_get_index('ICWMRSH') - dp_frac_idx = pbuf_get_index('DP_FRAC') - sh_frac_idx = pbuf_get_index('SH_FRAC') - - zm_eu_idx = pbuf_get_index('ZM_EU') - zm_du_idx = pbuf_get_index('ZM_DU') - zm_ed_idx = pbuf_get_index('ZM_ED') - zm_dp_idx = pbuf_get_index('ZM_DP') - zm_jt_idx = pbuf_get_index('ZM_JT') - zm_maxg_idx = pbuf_get_index('ZM_MAXG') - zm_ideep_idx = pbuf_get_index('ZM_IDEEP') - - cmfmc_sh_idx = pbuf_get_index('CMFMC_SH') - sh_e_ed_ratio_idx = pbuf_get_index('SH_E_ED_RATIO', istat) - - if (masterproc ) then - - write(iulog,'(a,l12)') 'aero_convproc_init - convproc_do_aer = ', & - convproc_do_aer - write(iulog,'(a,l12)') 'aero_convproc_init - use_cwaer_for_activate_maxsat = ', & - use_cwaer_for_activate_maxsat - write(iulog,'(a,l12)') 'aero_convproc_init - apply_convproc_tend_to_ptend = ', & - apply_convproc_tend_to_ptend - write(iulog,'(a,i12)') 'aero_convproc_init - convproc_method_activate = ', & - convproc_method_activate - write(iulog,'(a,i12)') 'aero_convproc_init - method1_activate_nlayers = ', & - method1_activate_nlayers - write(iulog,'(a,1pe12.4)') 'aero_convproc_init - method2_activate_smaxmax = ', & - method2_activate_smaxmax - write(iulog,'(a,i12)') 'aero_convproc_init - method_reduce_actfrac = ', & - method_reduce_actfrac - write(iulog,'(a,1pe12.4)') 'aero_convproc_init - factor_reduce_actfrac = ', & - factor_reduce_actfrac - - npass_calc_updraft = 1 - if ( (method_reduce_actfrac == 2) .and. & - (factor_reduce_actfrac >= 0.0_r8) .and. & - (factor_reduce_actfrac <= 1.0_r8) ) npass_calc_updraft = 2 - write(iulog,'(a,i12)') 'aero_convproc_init - npass_calc_updraft = ', & - npass_calc_updraft - - end if - -end subroutine aero_convproc_init - -!========================================================================================= - -subroutine aero_convproc_intr( aero_props, aero_state, state, ptend, pbuf, ztodt, & - nsrflx_mzaer2cnvpr, qsrflx_mzaer2cnvpr, & - aerdepwetis, dcondt_resusp3d ) -!----------------------------------------------------------------------- -! -! Convective cloud processing (transport, activation/resuspension, -! wet removal) of aerosols and trace gases. -! (Currently no aqueous chemistry and no trace-gas wet removal) -! Does aerosols when convproc_do_aer is .true. -! -! Does deep convection -! Uses mass fluxes, cloud water, precip production from the -! convective cloud routines -! -! Author: R. Easter -! -!----------------------------------------------------------------------- - - - ! Arguments - class(aerosol_properties), intent(in) :: aero_props - class(aerosol_state), intent(in) :: aero_state - - type(physics_state),target,intent(in ) :: state ! Physics state variables - type(physics_ptend), intent(inout) :: ptend ! %lq set in aero_model_wetdep - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: ztodt ! model physics timestep [s] - - integer, intent(in) :: nsrflx_mzaer2cnvpr - real(r8), intent(in) :: qsrflx_mzaer2cnvpr(pcols,ncnstaer,nsrflx_mzaer2cnvpr) - real(r8), intent(inout) :: aerdepwetis(pcols,pcnst) ! aerosol wet deposition (interstitial) - real(r8), intent(inout) :: dcondt_resusp3d(ncnstaer,pcols,pver) - - ! Local variables - integer, parameter :: nsrflx = 5 ! last dimension of qsrflx - integer :: l, m, mm, ndx, lchnk - integer :: ncol - - real(r8) :: dqdt(pcols,pver,ncnstaer) - real(r8) :: dt - - - - real(r8) :: q(pcols,pver,ncnstaer) - real(r8) :: qsrflx(pcols,ncnstaer,nsrflx) - real(r8), pointer :: qptr(:,:) - - real(r8) :: sflxic(pcols,ncnstaer) - real(r8) :: sflxid(pcols,ncnstaer) - real(r8) :: sflxec(pcols,ncnstaer) - real(r8) :: sflxed(pcols,ncnstaer) - - type(ptr2d_t) :: raer(ncnstaer) ! aerosol mass, number mixing ratios - type(ptr2d_t) :: qqcw(ncnstaer) - - logical :: dotend(pcnst) - logical :: applytend - - !------------------------------------------------------------------------------------------------- - - dotend = .false. - - ! Initialize - lchnk = state%lchnk - ncol = state%ncol - dt = ztodt - - sflxic(:,:) = 0.0_r8 - sflxid(:,:) = 0.0_r8 - sflxec(:,:) = 0.0_r8 - sflxed(:,:) = 0.0_r8 - - call aero_state%get_states( aero_props, raer, qqcw ) - - ! prepare for deep conv processing - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - - mm = aero_props%indexer(m,l) - ndx = aer_cnst_ndx(mm) - - sflxec(1:ncol,mm) = qsrflx_mzaer2cnvpr(1:ncol,mm,1) - sflxed(1:ncol,mm) = qsrflx_mzaer2cnvpr(1:ncol,mm,2) - - applytend = .false. - if ( ndx > 0 ) then - applytend = ptend%lq(ndx) - dotend(ndx) = applytend - endif - - qptr => raer(mm)%fld - - if ( applytend ) then - ! calc new q (after calcaersize and mz_aero_wet_intr) - q(1:ncol,:,mm) = max( 0.0_r8, qptr(1:ncol,:) + dt*ptend%q(1:ncol,:,ndx) ) - else - ! use old q - q(1:ncol,:,mm) = qptr(1:ncol,:) - end if - - end do - end do - - dqdt(:,:,:) = 0.0_r8 - qsrflx(:,:,:) = 0.0_r8 - - if (convproc_do_aer) then - - ! do deep conv processing - if (convproc_do_deep) then - call aero_convproc_dp_intr( aero_props, & - state, pbuf, dt, & - q, dqdt, nsrflx, qsrflx, dcondt_resusp3d ) - - ! apply deep conv processing tendency - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - ndx = aer_cnst_ndx(mm) - - if ( apply_convproc_tend_to_ptend ) then - ! add dqdt onto ptend%q and set ptend%lq - if (ndx>0) then ! advected species - ptend%q(1:ncol,:,ndx) = ptend%q(1:ncol,:,ndx) + dqdt(1:ncol,:,mm) - else - raer(mm)%fld(1:ncol,:) = max( 0.0_r8, raer(mm)%fld(1:ncol,:) + dqdt(1:ncol,:,mm) * dt ) - end if - end if - - ! these used for history file wetdep diagnostics - sflxic(1:ncol,mm) = sflxic(1:ncol,mm) + qsrflx(1:ncol,mm,4) - sflxid(1:ncol,mm) = sflxid(1:ncol,mm) + qsrflx(1:ncol,mm,4) - sflxec(1:ncol,mm) = sflxec(1:ncol,mm) + qsrflx(1:ncol,mm,5) - sflxed(1:ncol,mm) = sflxed(1:ncol,mm) + qsrflx(1:ncol,mm,5) - - ! this used for surface coupling - if (ndx>0) then - aerdepwetis(1:ncol,ndx) = aerdepwetis(1:ncol,ndx) & - + qsrflx(1:ncol,mm,4) + qsrflx(1:ncol,mm,5) - end if - end do - end do - - end if - - end if ! (convproc_do_aer) then - - if (convproc_do_aer .and. apply_convproc_tend_to_ptend ) then - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - - ndx = aer_cnst_ndx(mm) - - if (ndx>0) call outfld( trim(cnst_name_extd(1,mm))//'SFWETC', aerdepwetis(:,ndx), pcols, lchnk ) - call outfld( trim(cnst_name_extd(1,mm))//'SFSIC', sflxic(:,mm), pcols, lchnk ) - call outfld( trim(cnst_name_extd(1,mm))//'SFSEC', sflxec(:,mm), pcols, lchnk ) - - if ( deepconv_wetdep_history ) then - call outfld( trim(cnst_name_extd(1,mm))//'SFSID', sflxid(:,mm), pcols, lchnk ) - call outfld( trim(cnst_name_extd(1,mm))//'SFSED', sflxed(:,mm), pcols, lchnk ) - end if - end do - end do - - end if - -end subroutine aero_convproc_intr - -!========================================================================================= - -subroutine aero_convproc_dp_intr( aero_props, & - state, pbuf, dt, & - q, dqdt, nsrflx, qsrflx, dcondt_resusp3d) -!----------------------------------------------------------------------- -! -! Convective cloud processing (transport, activation/resuspension, -! wet removal) of aerosols and trace gases. -! (Currently no aqueous chemistry and no trace-gas wet removal) -! Does aerosols when convproc_do_aer is .true. -! -! This routine does deep convection -! Uses mass fluxes, cloud water, precip production from the -! convective cloud routines -! -! Author: R. Easter -! -!----------------------------------------------------------------------- - - ! Arguments - class(aerosol_properties), intent(in) :: aero_props - - type(physics_state), intent(in ) :: state ! Physics state variables - type(physics_buffer_desc), pointer :: pbuf(:) - - real(r8), intent(in) :: dt ! delta t (model time increment) - - real(r8), intent(in) :: q(pcols,pver,ncnstaer) - real(r8), intent(inout) :: dqdt(pcols,pver,ncnstaer) - integer, intent(in) :: nsrflx - real(r8), intent(inout) :: qsrflx(pcols,ncnstaer,nsrflx) - real(r8), intent(inout) :: dcondt_resusp3d(ncnstaer,pcols,pver) - - integer :: i - integer :: lchnk - integer :: nstep - - real(r8) :: dpdry(pcols,pver) ! layer delta-p-dry (mb) - real(r8) :: fracice(pcols,pver) ! Ice fraction of cloud droplets - real(r8) :: xx_mfup_max(pcols), xx_wcldbase(pcols), xx_kcldbase(pcols) - - ! physics buffer fields - real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble - real(r8), pointer :: rprddp(:,:) ! Deep conv precip production (kg/kg/s - grid avg) - real(r8), pointer :: evapcdp(:,:) ! Deep conv precip evaporation (kg/kg/s - grid avg) - real(r8), pointer :: icwmrdp(:,:) ! Deep conv cloud condensate (kg/kg - in cloud) - real(r8), pointer :: dp_frac(:,:) ! Deep conv cloud frac (0-1) - - ! deep conv variables - real(r8), pointer :: du(:,:) ! Mass detrain rate from updraft (pcols,pver) - real(r8), pointer :: eu(:,:) ! Mass entrain rate into updraft (pcols,pver) - real(r8), pointer :: ed(:,:) ! Mass entrain rate into downdraft (pcols,pver) - ! eu, ed, du are "d(massflux)/dp" and are all positive - real(r8), pointer :: dp(:,:) ! Delta pressure between interfaces (pcols,pver) - integer, pointer :: jt(:) ! Index of cloud top for each column (pcols) - integer, pointer :: maxg(:) ! Index of cloud bottom for each column (pcols) - integer, pointer :: ideep(:) ! Gathering array (pcols) - integer :: lengath ! Gathered min lon indices over which to operate - - ! Initialize - - lchnk = state%lchnk - nstep = get_nstep() - - ! Associate pointers with physics buffer fields - call pbuf_get_field(pbuf, rprddp_idx, rprddp) - call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp) - call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp) - call pbuf_get_field(pbuf, dp_frac_idx, dp_frac) - call pbuf_get_field(pbuf, fracis_idx, fracis) - call pbuf_get_field(pbuf, zm_eu_idx, eu) - call pbuf_get_field(pbuf, zm_du_idx, du) - call pbuf_get_field(pbuf, zm_ed_idx, ed) - call pbuf_get_field(pbuf, zm_dp_idx, dp) - call pbuf_get_field(pbuf, zm_jt_idx, jt) - call pbuf_get_field(pbuf, zm_maxg_idx, maxg) - call pbuf_get_field(pbuf, zm_ideep_idx, ideep) - - lengath = count(ideep > 0) - - fracice(:,:) = 0.0_r8 - - ! initialize dpdry (units=mb), which is used for tracers of dry mixing ratio type - dpdry = 0._r8 - do i = 1, lengath - dpdry(i,:) = state%pdeldry(ideep(i),:)/100._r8 - end do - - call aero_convproc_tend( aero_props, 'deep', lchnk, dt, & - state%t, state%pmid, q, du, eu, & - ed, dp, dpdry, jt, & - maxg, ideep, 1, lengath, & - dp_frac, icwmrdp, rprddp, evapcdp, & - fracice, dqdt, nsrflx, qsrflx, & - xx_mfup_max, xx_wcldbase, xx_kcldbase, & - dcondt_resusp3d ) - - call outfld( 'DP_MFUP_MAX', xx_mfup_max, pcols, lchnk ) - call outfld( 'DP_WCLDBASE', xx_wcldbase, pcols, lchnk ) - call outfld( 'DP_KCLDBASE', xx_kcldbase, pcols, lchnk ) - -end subroutine aero_convproc_dp_intr - -!========================================================================================= - -subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & +subroutine aero_convproc_run( aero_props, convtype, lchnk, dt, & t, pmid, q, du, eu, & ed, dp, dpdry, jt, & mx, ideep, il1g, il2g, & cldfrac, icwmr, rprd, evapc, & fracice, dqdt, nsrflx, qsrflx, & xx_mfup_max, xx_wcldbase, xx_kcldbase, & - dcondt_resusp3d ) + dcondt_resusp3d, conu2, dcondt2, & + ncol, pver, ncnstaer, nbins, & + pi, rhoh2o, rh2o, gravit, & + latvap, cpair, rair, & + convproc_do_evaprain_atonce, & + convproc_pom_spechygro, & + errmsg, errflg ) !----------------------------------------------------------------------- ! @@ -627,47 +96,65 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & ! class(aerosol_properties), intent(in) :: aero_props + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pver ! number of vertical layers + integer, intent(in) :: ncnstaer ! number of aerosol constituents (extended, = 2*ncnst) + integer, intent(in) :: nbins ! number of aerosol bins/modes + real(r8), intent(in) :: pi ! ratio of circle circumference to diameter + real(r8), intent(in) :: rhoh2o ! density of liquid water (STP) (kg/m3) + real(r8), intent(in) :: rh2o ! gas constant for water vapor (J/K/kg) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + real(r8), intent(in) :: latvap ! latent heat of vaporization (J/kg) + real(r8), intent(in) :: cpair ! specific heat of dry air (J/K/kg) + real(r8), intent(in) :: rair ! dry air gas constant (J/K/kg) + logical, intent(in) :: convproc_do_evaprain_atonce ! resuspend only when rain fully evaporates in a layer + real(r8), intent(in) :: convproc_pom_spechygro ! prescribed p-organic hygroscopicity (<0 = use default) + character(len=*), intent(in) :: convtype ! identifies the type of ! convection ("deep", "shcu") integer, intent(in) :: lchnk ! chunk identifier real(r8), intent(in) :: dt ! Model timestep - real(r8), intent(in) :: t(pcols,pver) ! Temperature - real(r8), intent(in) :: pmid(pcols,pver) ! Pressure at model levels - real(r8), intent(in) :: q(pcols,pver,ncnstaer) ! Tracer array including moisture + real(r8), intent(in) :: t(:,:) ! Temperature + real(r8), intent(in) :: pmid(:,:) ! Pressure at model levels + real(r8), intent(in) :: q(:,:,:) ! Tracer array including moisture - real(r8), intent(in) :: du(pcols,pver) ! Mass detrain rate from updraft - real(r8), intent(in) :: eu(pcols,pver) ! Mass entrain rate into updraft - real(r8), intent(in) :: ed(pcols,pver) ! Mass entrain rate into downdraft + real(r8), intent(in) :: du(:,:) ! Mass detrain rate from updraft + real(r8), intent(in) :: eu(:,:) ! Mass entrain rate into updraft + real(r8), intent(in) :: ed(:,:) ! Mass entrain rate into downdraft ! *** note1 - mu, md, eu, ed, du, dp, dpdry are GATHERED ARRAYS *** ! *** note2 - mu and md units are (mb/s), which is used in the zm_conv code ! - eventually these should be changed to (kg/m2/s) ! *** note3 - eu, ed, du are "d(massflux)/dp" (with dp units = mb), and are all >= 0 - real(r8), intent(in) :: dp(pcols,pver) ! Delta pressure between interfaces (mb) - real(r8), intent(in) :: dpdry(pcols,pver) ! Delta dry-pressure (mb) - integer, intent(in) :: jt(pcols) ! Index of cloud top for each column - integer, intent(in) :: mx(pcols) ! Index of cloud bottom for each column - integer, intent(in) :: ideep(pcols) ! Gathering array indices + real(r8), intent(in) :: dp(:,:) ! Delta pressure between interfaces (mb) + real(r8), intent(in) :: dpdry(:,:) ! Delta dry-pressure (mb) + integer, intent(in) :: jt(:) ! Index of cloud top for each column + integer, intent(in) :: mx(:) ! Index of cloud bottom for each column + integer, intent(in) :: ideep(:) ! Gathering array indices integer, intent(in) :: il1g ! Gathered min lon indices over which to operate integer, intent(in) :: il2g ! Gathered max lon indices over which to operate ! *** note4 -- for il1g <= i <= il2g, icol = ideep(i) is the "normal" chunk column index - real(r8), intent(in) :: cldfrac(pcols,pver) ! Convective cloud fractional area - real(r8), intent(in) :: icwmr(pcols,pver) ! Convective cloud water from zhang - real(r8), intent(in) :: rprd(pcols,pver) ! Convective precipitation formation rate - real(r8), intent(in) :: evapc(pcols,pver) ! Convective precipitation evaporation rate - real(r8), intent(in) :: fracice(pcols,pver) ! Ice fraction of cloud droplets + real(r8), intent(in) :: cldfrac(:,:) ! Convective cloud fractional area + real(r8), intent(in) :: icwmr(:,:) ! Convective cloud water from zhang + real(r8), intent(in) :: rprd(:,:) ! Convective precipitation formation rate + real(r8), intent(in) :: evapc(:,:) ! Convective precipitation evaporation rate + real(r8), intent(in) :: fracice(:,:) ! Ice fraction of cloud droplets - real(r8), intent(out):: dqdt(pcols,pver,ncnstaer) ! Tracer tendency array + real(r8), intent(out):: dqdt(:,:,:) ! Tracer tendency array integer, intent(in) :: nsrflx ! last dimension of qsrflx - real(r8), intent(out):: qsrflx(pcols,ncnstaer,nsrflx) + real(r8), intent(out):: qsrflx(:,:,:) ! 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) - real(r8), intent(inout) :: dcondt_resusp3d(ncnstaer,pcols,pver) + real(r8), intent(out) :: xx_mfup_max(:) + real(r8), intent(out) :: xx_wcldbase(:) + real(r8), intent(out) :: xx_kcldbase(:) + real(r8), intent(inout) :: dcondt_resusp3d(:,:,:) + real(r8), intent(out) :: conu2(:,:,:,:) ! updraft interface TMR diagnostic (WETC/CONU history) + real(r8), intent(out) :: dcondt2(:,:,:,:) ! wet-deposition TMR tendency diagnostic (WETC/CONU history) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !--------------------------Local Variables------------------------------ @@ -691,7 +178,7 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & integer :: km1, km1x ! Work index integer :: kp1, kp1x ! Work index integer :: l, mm ! Work index - integer :: m, n, ndx ! Work index + integer :: m, n ! Work index integer :: nerr ! number of errors for entire run integer :: nerrmax ! maximum number of errors to report integer :: npass_calc_updraft @@ -702,19 +189,19 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & real(r8) aqfrac(2,ncnstaer) ! aqueous fraction of constituent in updraft real(r8) cldfrac_i(pver) ! cldfrac at current i (with adjustments) - real(r8) chat(2,ncnstaer,pverp) ! mix ratio in env at interfaces - real(r8) cond(2,ncnstaer,pverp) ! mix ratio in downdraft at interfaces + real(r8) chat(2,ncnstaer,pver+1) ! mix ratio in env at interfaces + real(r8) cond(2,ncnstaer,pver+1) ! mix ratio in downdraft at interfaces real(r8) const(2,ncnstaer,pver) ! gathered tracer array - real(r8) conu(2,ncnstaer,pverp) ! mix ratio in updraft at interfaces + real(r8) conu(2,ncnstaer,pver+1) ! mix ratio in updraft at interfaces real(r8) dcondt(2,ncnstaer,pver) ! grid-average TMR tendency for current column real(r8) dcondt_prevap(2,ncnstaer,pver) ! portion of dcondt from precip evaporation real(r8) dcondt_resusp(2,ncnstaer,pver) ! portion of dcondt from resuspension real(r8) dcondt_wetdep(2,ncnstaer,pver) ! portion of dcondt from wet deposition - real(r8) dconudt_activa(2,ncnstaer,pverp) ! d(conu)/dt by activation - real(r8) dconudt_aqchem(2,ncnstaer,pverp) ! d(conu)/dt by aqueous chem - real(r8) dconudt_wetdep(2,ncnstaer,pverp) ! d(conu)/dt by wet removal + real(r8) dconudt_activa(2,ncnstaer,pver+1) ! d(conu)/dt by activation + real(r8) dconudt_aqchem(2,ncnstaer,pver+1) ! d(conu)/dt by aqueous chem + real(r8) dconudt_wetdep(2,ncnstaer,pver+1) ! d(conu)/dt by wet removal real(r8) maxflux(2,ncnstaer) ! maximum (over layers) of fluxin and fluxout real(r8) maxflux2(2,ncnstaer) ! ditto but computed using method-2 fluxes @@ -758,10 +245,10 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & real(r8) mbsth ! Threshold for mass fluxes real(r8) minc ! a work variable real(r8) md_m_eddp ! a work variable - real(r8) md_i(pverp) ! md(i,k) at current i (note pverp dimension) - real(r8) md_x(pverp) ! md(i,k) at current i (note pverp dimension) - real(r8) mu_i(pverp) ! mu(i,k) at current i (note pverp dimension) - real(r8) mu_x(pverp) ! mu(i,k) at current i (note pverp dimension) + real(r8) md_i(pver+1) ! md(i,k) at current i (note pverp dimension) + real(r8) md_x(pver+1) ! md(i,k) at current i (note pverp dimension) + real(r8) mu_i(pver+1) ! mu(i,k) at current i (note pverp dimension) + real(r8) mu_x(pver+1) ! mu(i,k) at current i (note pverp dimension) ! md_i, md_x, mu_i, mu_x are all "dry" mass fluxes ! the mu_x/md_x are initially calculated from the incoming mu/md by applying dp/dpdry ! the mu_i/md_i are next calculated by applying the mbsth threshold @@ -776,8 +263,10 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & real(r8) tmpf ! work variables real(r8) xinv_ntsub ! 1.0/ntsub real(r8) wup(pver) ! working updraft velocity (m/s) - real(r8) conu2(pcols,pver,2,ncnstaer) - real(r8) dcondt2(pcols,pver,2,ncnstaer) + real(r8) hund_ovr_g ! = 100.0_r8/gravit +! used with zm_conv mass fluxes and delta-p +! for mu = [mbar/s], mu*hund_ovr_g = [kg/m2/s] +! for dp = [mbar] and q = [kg/kg], q*dp*hund_ovr_g = [kg/m2] !Fractional area of ensemble mean updrafts in ZM scheme set to 0.01 !Chosen to reproduce vertical velocities in GATEIII GIGALES (Khairoutdinov etal 2009, JAMES) @@ -785,6 +274,11 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & !----------------------------------------------------------------------- ! + errmsg = '' + errflg = 0 + + hund_ovr_g = 100.0_r8/gravit + iconvtype = -1 iflux_method = -1 @@ -795,7 +289,9 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & iconvtype = 2 iflux_method = 2 else - call endrun( '*** aero_convproc_tend -- convtype is not |deep| or |uwsh|' ) + errmsg = '*** aero_convproc_run -- convtype is not |deep| or |uwsh|' + errflg = 1 + return end if nerr = 0 @@ -843,7 +339,7 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & ! invalid cloudtop and cloudbase indices -- skip this column write(*,9010) 'illegal jt, mx', convtype, lchnk, icol, i, & jt(i), mx(i) -9010 format( '*** aero_convproc_tend error -- ', a, 5x, 'convtype = ', a / & +9010 format( '*** aero_convproc_run error -- ', a, 5x, 'convtype = ', a / & '*** lchnk, icol, il, jt, mx = ', 5(1x,i10) ) cycle i_loop_main_aa @@ -1123,7 +619,11 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & call activate_convproc( aero_props, & conu(:,:,k), dconudt_activa(:,:,k), conu(:,:,k), & tmpa, dt_u(k), wup(k), & - t(icol,k), rhoair_i(k), ipass_calc_updraft ) + t(icol,k), rhoair_i(k), ipass_calc_updraft, & + ncnstaer, nbins, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & + errmsg, errflg ) + if (errflg /= 0) return else if (f_ent > 0.0_r8) then ! current layer is above cloud base (=first layer with activation) ! only allow activation at k = kactfirst thru kactfirst-(method1_activate_nlayers-1) @@ -1131,7 +631,11 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & call activate_convproc( aero_props, & conu(:,:,k), dconudt_activa(:,:,k), const(:,:,k), & f_ent, dt_u(k), wup(k), & - t(icol,k), rhoair_i(k), ipass_calc_updraft ) + t(icol,k), rhoair_i(k), ipass_calc_updraft, & + ncnstaer, nbins, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & + errmsg, errflg ) + if (errflg /= 0) return end if end if ! the following was for cam2 shallow convection (hack), @@ -1179,7 +683,11 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & conu(:,:,k), dconudt_activa(:,:,k), & f_ent, dt_u(k), wup(k), & t(icol,k), rhoair_i(k), k, & - kactfirst, ipass_calc_updraft ) + kactfirst, ipass_calc_updraft, & + ncnstaer, nbins, convproc_pom_spechygro, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & + errmsg, errflg ) + if (errflg /= 0) return end if conu2(icol,k,:,:) = conu(:,:,k) @@ -1391,11 +899,13 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & ! calculate effects of precipitation evaporation call precpevap_convproc( aero_props, dcondt, dcondt_wetdep, dcondt_prevap, & rprd, evapc, dp_i, & - icol, ktop ) + icol, ktop, pver, ncnstaer, & + convproc_do_evaprain_atonce ) ! make adjustments to dcondt for activated & unactivated aerosol species ! pairs to account any (or total) resuspension of convective-cloudborne aerosol - call resuspend_convproc( aero_props, dcondt, dcondt_resusp, ktop, kbot_prevap ) + call resuspend_convproc( aero_props, dcondt, dcondt_resusp, ktop, kbot_prevap, & + pver, ncnstaer, convproc_do_evaprain_atonce ) ! Do resuspension of aerosols from rain only when the rain has ! totally evaporated. @@ -1424,7 +934,7 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & end do ! -! note again the aero_convproc_tend does not apply convective cloud processing +! note again the aero_convproc_run does not apply convective cloud processing ! to the stratiform-cloudborne aerosol ! within this routine, cloudborne aerosols are convective-cloudborne ! @@ -1455,7 +965,6 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & do m = 1, aero_props%nbins() do l = 0, aero_props%nmasses(m) mm = aero_props%indexer(m,l) - ndx = aer_cnst_ndx(mm) do k = ktop, kbot_prevap dqdt_i(k,mm) = dcondt(1,mm,k) dqdt(icol,k,mm) = dqdt(icol,k,mm) + dqdt_i(k,mm)*xinv_ntsub @@ -1479,7 +988,6 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & do m = 1, aero_props%nbins() do l = 0, aero_props%nmasses(m) mm = aero_props%indexer(m,l) - ndx = aer_cnst_ndx(mm) do k = ktop, kbot_prevap q_i(k,mm) = max( (q_i(k,mm) + dqdt_i(k,mm)*dtsub), 0.0_r8 ) end do @@ -1494,25 +1002,17 @@ subroutine aero_convproc_tend( aero_props, convtype, lchnk, dt, & end do i_loop_main_aa ! of the main "do i = il1g, il2g" loop - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - - call outfld( trim(cnst_name_extd(1,mm))//'WETC', dcondt2(:,:,1,mm), pcols, lchnk ) - call outfld( trim(cnst_name_extd(1,mm))//'CONU', conu2(:,:,1,mm), pcols, lchnk ) - call outfld( trim(cnst_name_extd(2,mm))//'WETC', dcondt2(:,:,2,mm), pcols, lchnk ) - call outfld( trim(cnst_name_extd(2,mm))//'CONU', conu2(:,:,2,mm), pcols, lchnk ) - - end do - end do +! conu2/dcondt2 are returned as out-args; the WETC/CONU history diagnostics +! are written by the CAM host layer (aero_convproc_cam) -end subroutine aero_convproc_tend +end subroutine aero_convproc_run !========================================================================================= subroutine precpevap_convproc( aero_props, & dcondt, dcondt_wetdep, dcondt_prevap, & rprd, evapc, dp_i, & - icol, ktop ) + icol, ktop, pver, ncnstaer, & + convproc_do_evaprain_atonce ) !----------------------------------------------------------------------- ! ! Purpose: @@ -1528,6 +1028,9 @@ subroutine precpevap_convproc( aero_props, & ! (note: TMR = tracer mixing ratio) class(aerosol_properties), intent(in) :: aero_props + integer, intent(in) :: pver ! number of vertical layers + integer, intent(in) :: ncnstaer ! number of aerosol constituents (extended) + logical, intent(in) :: convproc_do_evaprain_atonce real(r8), intent(inout) :: dcondt(2,ncnstaer,pver) ! overall TMR tendency from convection real(r8), intent(in) :: dcondt_wetdep(2,ncnstaer,pver) @@ -1537,8 +1040,8 @@ subroutine precpevap_convproc( aero_props, & ! (actually, due to the adjustments made here) ! (on entry, this is 0.0) - 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) :: rprd(:,:) ! conv precip production rate (gathered) + real(r8), intent(in) :: evapc(:,:) ! 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 @@ -1615,7 +1118,10 @@ end subroutine precpevap_convproc subroutine activate_convproc( aero_props, & conu, dconudt, conent, & f_ent, dt_u, wup, & - tair, rhoair, ipass_calc_updraft ) + tair, rhoair, ipass_calc_updraft, & + ncnstaer, nbins, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & + errmsg, errflg ) !----------------------------------------------------------------------- ! ! Purpose: @@ -1627,7 +1133,7 @@ subroutine activate_convproc( aero_props, & ! conent(l) = TMR of air that is entrained into the updraft from level k ! f_ent = Fraction of the "before-detrainment" updraft massflux at ! k/k-1 interface" resulting from entrainment of level k air -! (where k is the current level in subr aero_convproc_tend) +! (where k is the current level in subr aero_convproc_run) ! ! On entry to this routine, the conu(l) represents the updraft TMR ! after entrainment, but before chemistry/physics and detrainment, @@ -1660,13 +1166,23 @@ subroutine activate_convproc( aero_props, & ! !----------------------------------------------------------------------- - use ndrop, only: activate_aerosol + use aero_activate, only: activate_aerosol !----------------------------------------------------------------------- ! arguments (note: TMR = tracer mixing ratio) class(aerosol_properties), intent(in) :: aero_props + integer, intent(in) :: ncnstaer ! number of aerosol constituents (extended) + integer, intent(in) :: nbins ! number of aerosol bins/modes + real(r8), intent(in) :: pi ! ratio of circle circumference to diameter + real(r8), intent(in) :: rhoh2o ! density of liquid water (STP) (kg/m3) + real(r8), intent(in) :: rh2o ! gas constant for water vapor (J/K/kg) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + real(r8), intent(in) :: latvap ! latent heat of vaporization (J/kg) + real(r8), intent(in) :: cpair ! specific heat of dry air (J/K/kg) + real(r8), intent(in) :: rair ! dry air gas constant (J/K/kg) + ! conu = tracer mixing ratios in updraft at top of this (current) level ! The conu are changed by activation real(r8), intent(inout) :: conu(2,ncnstaer) @@ -1714,8 +1230,14 @@ subroutine activate_convproc( aero_props, & real(r8) :: naerosol_a(1,1) ! number conc (1/m3) real(r8) :: vaerosol_a(1,1) ! volume conc (m3/m3) + character(len=*), intent(out) :: errmsg ! error message from activate_aerosol + integer, intent(out) :: errflg ! error flag from activate_aerosol + !----------------------------------------------------------------------- + errmsg = '' + errflg = 0 + ! when ipass_calc_updraft == 2, apply the activation tendencies ! from pass 1, but multiplied by factor_reduce_actfrac ! (can only have ipass_calc_updraft == 2 when method_reduce_actfrac = 2) @@ -1797,7 +1319,9 @@ subroutine activate_convproc( aero_props, & call activate_aerosol( & wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & naerosol, nbins, vaerosol, hygro, aero_props, & - fn, fm, fluxn, fluxm, flux_fullact ) + fn, fm, fluxn, fluxm, flux_fullact, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, errmsg, errflg ) + if (errflg /= 0) return ! apply the activation fractions to the updraft aerosol mixing ratios dt_u_inv = 1.0_r8/dt_u @@ -1827,7 +1351,10 @@ subroutine activate_convproc_method2( aero_props, & conu, dconudt, & f_ent, dt_u, wup, & tair, rhoair, k, & - kactfirst, ipass_calc_updraft ) + kactfirst, ipass_calc_updraft, & + ncnstaer, nbins, convproc_pom_spechygro, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & + errmsg, errflg ) !----------------------------------------------------------------------- ! ! Purpose: @@ -1838,7 +1365,7 @@ subroutine activate_convproc_method2( aero_props, & ! conu(l) = Updraft TMR (tracer mixing ratio) at k/k-1 interface ! f_ent = Fraction of the "before-detrainment" updraft massflux at ! k/k-1 interface" resulting from entrainment of level k air -! (where k is the current level in subr aero_convproc_tend) +! (where k is the current level in subr aero_convproc_run) ! ! On entry to this routine, the conu(l) represents the updraft TMR ! after entrainment, but before chemistry/physics and detrainment. @@ -1866,13 +1393,24 @@ subroutine activate_convproc_method2( aero_props, & ! !----------------------------------------------------------------------- - use ndrop, only: activate_aerosol + use aero_activate, only: activate_aerosol !----------------------------------------------------------------------- ! arguments (note: TMR = tracer mixing ratio) class(aerosol_properties), intent(in) :: aero_props + integer, intent(in) :: ncnstaer ! number of aerosol constituents (extended) + integer, intent(in) :: nbins ! number of aerosol bins/modes + real(r8), intent(in) :: convproc_pom_spechygro ! prescribed p-organic hygroscopicity (<0 = use default) + real(r8), intent(in) :: pi ! ratio of circle circumference to diameter + real(r8), intent(in) :: rhoh2o ! density of liquid water (STP) (kg/m3) + real(r8), intent(in) :: rh2o ! gas constant for water vapor (J/K/kg) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + real(r8), intent(in) :: latvap ! latent heat of vaporization (J/kg) + real(r8), intent(in) :: cpair ! specific heat of dry air (J/K/kg) + real(r8), intent(in) :: rair ! dry air gas constant (J/K/kg) + ! conu = tracer mixing ratios in updraft at top of this (current) level ! The conu are changed by activation real(r8), intent(inout) :: conu(2,ncnstaer) @@ -1921,8 +1459,14 @@ subroutine activate_convproc_method2( aero_props, & real(r8) :: naerosol_a(1,1) ! number conc (1/m3) real(r8) :: vaerosol_a(1,1) ! volume conc (m3/m3) + character(len=*), intent(out) :: errmsg ! error message from activate_aerosol + integer, intent(out) :: errflg ! error flag from activate_aerosol + !----------------------------------------------------------------------- + errmsg = '' + errflg = 0 + ! when ipass_calc_updraft == 2, apply the activation tendencies ! from pass 1, but multiplied by factor_reduce_actfrac ! (can only have ipass_calc_updraft == 2 when method_reduce_actfrac = 2) @@ -2020,8 +1564,9 @@ subroutine activate_convproc_method2( aero_props, & call activate_aerosol( & wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & naerosol, nbins, vaerosol, hygro, aero_props, & - fn, fm, fluxn, fluxm, flux_fullact ) - + fn, fm, fluxn, fluxm, flux_fullact, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, errmsg, errflg ) + if (errflg /= 0) return else ! above cloud base - do secondary activation with prescribed supersat @@ -2030,7 +1575,10 @@ subroutine activate_convproc_method2( aero_props, & call activate_aerosol( & wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & naerosol, nbins, vaerosol, hygro, aero_props, & - fn, fm, fluxn, fluxm, flux_fullact, smax_prescribed ) + fn, fm, fluxn, fluxm, flux_fullact, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, errmsg, errflg, & + smax_prescribed ) + if (errflg /= 0) return end if ! apply the activation fractions to the updraft aerosol mixing ratios @@ -2063,7 +1611,8 @@ end subroutine activate_convproc_method2 !========================================================================================= subroutine resuspend_convproc( aero_props, & - dcondt, dcondt_resusp, ktop, kbot_prevap ) + dcondt, dcondt_resusp, ktop, kbot_prevap, & + pver, ncnstaer, convproc_do_evaprain_atonce ) !----------------------------------------------------------------------- ! ! Purpose: @@ -2100,6 +1649,9 @@ subroutine resuspend_convproc( aero_props, & ! (note: TMR = tracer mixing ratio) class(aerosol_properties), intent(in) :: aero_props + integer, intent(in) :: pver ! number of vertical layers + integer, intent(in) :: ncnstaer ! number of aerosol constituents (extended) + logical, intent(in) :: convproc_do_evaprain_atonce real(r8), intent(inout) :: dcondt(2,ncnstaer,pver) ! overall TMR tendency from convection real(r8), intent(inout) :: dcondt_resusp(2,ncnstaer,pver) diff --git a/src/chemistry/aerosol/aero_convproc_cam.F90 b/src/chemistry/aerosol/aero_convproc_cam.F90 new file mode 100644 index 0000000000..50e5f5a7e4 --- /dev/null +++ b/src/chemistry/aerosol/aero_convproc_cam.F90 @@ -0,0 +1,590 @@ +module aero_convproc_cam +!--------------------------------------------------------------------------------- +! Purpose: +! +! CAM interface to aerosol/trace-gas convective cloud processing scheme +! +! currently these routines assume stratiform and convective clouds only interact +! through the detrainment of convective cloudborne material into stratiform clouds +! +! thus the stratiform-cloudborne aerosols (in the qqcw array) are not processed +! by the convective up/downdrafts, but are affected by the detrainment +! +! Author: R. C. Easter +! +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use shr_kind_mod, only: shr_kind_cs + +use spmd_utils, only: masterproc +use physconst, only: gravit, rair +use physconst, only: pi, rhoh2o, rh2o, latvap, cpair +use ppgrid, only: pver, pcols, pverp +use constituents, only: pcnst, cnst_get_ind +use constituents, only: cnst_species_class, cnst_spec_class_aerosol +use phys_control, only: phys_getopts + +use physics_types, only: physics_state, physics_ptend +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field +use time_manager, only: get_nstep +use cam_history, only: outfld, addfld, add_default, horiz_only +use cam_logfile, only: iulog +use cam_abortutils, only: endrun + +use aerosol_properties_mod, only: aerosol_properties +use aerosol_state_mod, only: aerosol_state, ptr2d_t + +use aero_convproc, only: aero_convproc_run +use aero_convproc, only: use_cwaer_for_activate_maxsat, convproc_method_activate +use aero_convproc, only: method1_activate_nlayers, method2_activate_smaxmax +use aero_convproc, only: method_reduce_actfrac, factor_reduce_actfrac + +implicit none +private + +public :: aero_convproc_readnl +public :: aero_convproc_init +public :: aero_convproc_intr + +! namelist options +! NOTE: These are the defaults for CAM6. +logical, protected, public :: deepconv_wetdep_history = .true. +logical, protected, public :: convproc_do_deep = .true. +! NOTE: These are the defaults for the Eaton/Wang parameterization. +logical, protected, public :: convproc_do_evaprain_atonce = .false. +real(r8), protected, public :: convproc_pom_spechygro = -1._r8 +real(r8), protected, public :: convproc_wup_max = 4.0_r8 + +logical, parameter :: apply_convproc_tend_to_ptend = .true. + +logical :: convproc_do_aer + +! physics buffer indices +integer :: fracis_idx = 0 + +integer :: rprddp_idx = 0 +integer :: rprdsh_idx = 0 +integer :: nevapr_shcu_idx = 0 +integer :: nevapr_dpcu_idx = 0 + +integer :: icwmrdp_idx = 0 +integer :: icwmrsh_idx = 0 +integer :: sh_frac_idx = 0 +integer :: dp_frac_idx = 0 + +integer :: zm_eu_idx = 0 +integer :: zm_du_idx = 0 +integer :: zm_ed_idx = 0 +integer :: zm_dp_idx = 0 +integer :: zm_jt_idx = 0 +integer :: zm_maxg_idx = 0 +integer :: zm_ideep_idx = 0 + +integer :: cmfmc_sh_idx = 0 +integer :: sh_e_ed_ratio_idx = 0 + +integer :: istat + +integer :: nbins = 0 +integer :: ncnstaer = 0 + +integer, allocatable :: aer_cnst_ndx(:) + +character(len=32), allocatable :: cnst_name_extd(:,:) ! (2,ncnstaer) + +contains + +!========================================================================================= +subroutine aero_convproc_readnl(nlfile) + + use namelist_utils, only: find_group_name + use spmd_utils, only: mpicom, masterprocid, mpi_real8, mpi_logical + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'aero_convproc_readnl' + + namelist /aerosol_convproc_opts/ deepconv_wetdep_history, convproc_do_deep, & + convproc_do_evaprain_atonce, convproc_pom_spechygro, convproc_wup_max + + ! Read namelist + if (masterproc) then + open( newunit=unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'aerosol_convproc_opts', status=ierr) + if (ierr == 0) then + read(unitn, aerosol_convproc_opts, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + end if + + ! Broadcast namelist variables + call mpi_bcast( deepconv_wetdep_history, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast( convproc_do_deep, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast( convproc_do_evaprain_atonce, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast( convproc_pom_spechygro, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast( convproc_wup_max, 1, mpi_real8, masterprocid, mpicom, ierr) + + if (masterproc) then + write(iulog,*) subname//': deepconv_wetdep_history = ',deepconv_wetdep_history + write(iulog,*) subname//': convproc_do_deep = ',convproc_do_deep + write(iulog,*) subname//': convproc_do_evaprain_atonce = ',convproc_do_evaprain_atonce + write(iulog,*) subname//': convproc_pom_spechygro = ',convproc_pom_spechygro + write(iulog,*) subname//': convproc_wup_max = ', convproc_wup_max + end if + +end subroutine aero_convproc_readnl + +!========================================================================================= + +subroutine aero_convproc_init(aero_props) + + class(aerosol_properties), intent(in) :: aero_props + + integer :: m, mm, l, ndx, astat + integer :: npass_calc_updraft + logical :: history_aerosol + character(len=32) :: name_a, name_c + + character(len=*), parameter :: prefix = 'aero_convproc_init: ' + + nbins = aero_props%nbins() + ncnstaer = aero_props%ncnst_tot() + + allocate(aer_cnst_ndx(ncnstaer),stat=astat) + if (astat/=0) then + call endrun(prefix//'aer_cnst_ndx allocation error') + end if + allocate(cnst_name_extd(2,ncnstaer),stat=astat) + if (astat/=0) then + call endrun(prefix//'cnst_name_extd allocation error') + end if + + aer_cnst_ndx(:) = -1 + + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) + mm = aero_props%indexer(m,l) + if (l==0) then + call aero_props%num_names(m, name_a, name_c) + else + call aero_props%mmr_names(m,l, name_a, name_c) + endif + cnst_name_extd(1,mm) = name_a + cnst_name_extd(2,mm) = name_c + + call cnst_get_ind(trim(name_a), ndx, abort=.false.) + aer_cnst_ndx(mm) = ndx + end do + end do + + call phys_getopts( history_aerosol_out=history_aerosol, & + convproc_do_aer_out = convproc_do_aer ) + + call addfld('DP_MFUP_MAX', horiz_only, 'A', 'kg/m2', & + 'Deep conv. column-max updraft mass flux' ) + call addfld('DP_WCLDBASE', horiz_only, 'A', 'm/s', & + 'Deep conv. cloudbase vertical velocity' ) + call addfld('DP_KCLDBASE', horiz_only, 'A', '1', & + 'Deep conv. cloudbase level index' ) + + ! output wet deposition fields to history + ! I = in-cloud removal; E = precip-evap resuspension + ! C = convective (total); D = deep convective + ! note that the precip-evap resuspension includes that resulting from + ! below-cloud removal, calculated in mz_aero_wet_intr + if (convproc_do_aer .and. apply_convproc_tend_to_ptend ) then + + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) + mm = aero_props%indexer(m,l) + + ndx = aer_cnst_ndx(mm) + + if ( deepconv_wetdep_history ) then + call addfld (trim(cnst_name_extd(1,mm))//'SFSID', & + horiz_only, 'A','kg/m2/s','Wet deposition flux (incloud, deep convective) at surface') + call addfld (trim(cnst_name_extd(1,mm))//'SFSED', & + horiz_only, 'A','kg/m2/s','Wet deposition flux (precip evap, deep convective) at surface') + if (history_aerosol) then + call add_default(trim(cnst_name_extd(1,mm))//'SFSID', 1, ' ') + call add_default(trim(cnst_name_extd(1,mm))//'SFSED', 1, ' ') + end if + end if + + end do + end do + end if + + if ( history_aerosol .and. convproc_do_aer ) then + call add_default( 'DP_MFUP_MAX', 1, ' ' ) + call add_default( 'DP_WCLDBASE', 1, ' ' ) + call add_default( 'DP_KCLDBASE', 1, ' ' ) + end if + + fracis_idx = pbuf_get_index('FRACIS') + + rprddp_idx = pbuf_get_index('RPRDDP') + rprdsh_idx = pbuf_get_index('RPRDSH') + nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') + nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') + + icwmrdp_idx = pbuf_get_index('ICWMRDP') + icwmrsh_idx = pbuf_get_index('ICWMRSH') + dp_frac_idx = pbuf_get_index('DP_FRAC') + sh_frac_idx = pbuf_get_index('SH_FRAC') + + zm_eu_idx = pbuf_get_index('ZM_EU') + zm_du_idx = pbuf_get_index('ZM_DU') + zm_ed_idx = pbuf_get_index('ZM_ED') + zm_dp_idx = pbuf_get_index('ZM_DP') + zm_jt_idx = pbuf_get_index('ZM_JT') + zm_maxg_idx = pbuf_get_index('ZM_MAXG') + zm_ideep_idx = pbuf_get_index('ZM_IDEEP') + + cmfmc_sh_idx = pbuf_get_index('CMFMC_SH') + sh_e_ed_ratio_idx = pbuf_get_index('SH_E_ED_RATIO', istat) + + if (masterproc ) then + + write(iulog,'(a,l12)') 'aero_convproc_init - convproc_do_aer = ', & + convproc_do_aer + write(iulog,'(a,l12)') 'aero_convproc_init - use_cwaer_for_activate_maxsat = ', & + use_cwaer_for_activate_maxsat + write(iulog,'(a,l12)') 'aero_convproc_init - apply_convproc_tend_to_ptend = ', & + apply_convproc_tend_to_ptend + write(iulog,'(a,i12)') 'aero_convproc_init - convproc_method_activate = ', & + convproc_method_activate + write(iulog,'(a,i12)') 'aero_convproc_init - method1_activate_nlayers = ', & + method1_activate_nlayers + write(iulog,'(a,1pe12.4)') 'aero_convproc_init - method2_activate_smaxmax = ', & + method2_activate_smaxmax + write(iulog,'(a,i12)') 'aero_convproc_init - method_reduce_actfrac = ', & + method_reduce_actfrac + write(iulog,'(a,1pe12.4)') 'aero_convproc_init - factor_reduce_actfrac = ', & + factor_reduce_actfrac + + npass_calc_updraft = 1 + if ( (method_reduce_actfrac == 2) .and. & + (factor_reduce_actfrac >= 0.0_r8) .and. & + (factor_reduce_actfrac <= 1.0_r8) ) npass_calc_updraft = 2 + write(iulog,'(a,i12)') 'aero_convproc_init - npass_calc_updraft = ', & + npass_calc_updraft + + end if + +end subroutine aero_convproc_init + +!========================================================================================= + +subroutine aero_convproc_intr( aero_props, aero_state, state, ptend, pbuf, ztodt, & + nsrflx_mzaer2cnvpr, qsrflx_mzaer2cnvpr, & + aerdepwetis, dcondt_resusp3d ) +!----------------------------------------------------------------------- +! +! Convective cloud processing (transport, activation/resuspension, +! wet removal) of aerosols and trace gases. +! (Currently no aqueous chemistry and no trace-gas wet removal) +! Does aerosols when convproc_do_aer is .true. +! +! Does deep convection +! Uses mass fluxes, cloud water, precip production from the +! convective cloud routines +! +! Author: R. Easter +! +!----------------------------------------------------------------------- + + + ! Arguments + class(aerosol_properties), intent(in) :: aero_props + class(aerosol_state), intent(in) :: aero_state + + type(physics_state),target,intent(in ) :: state ! Physics state variables + type(physics_ptend), intent(inout) :: ptend ! %lq set in aero_model_wetdep + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(in) :: ztodt ! model physics timestep [s] + + integer, intent(in) :: nsrflx_mzaer2cnvpr + real(r8), intent(in) :: qsrflx_mzaer2cnvpr(pcols,ncnstaer,nsrflx_mzaer2cnvpr) + real(r8), intent(inout) :: aerdepwetis(pcols,pcnst) ! aerosol wet deposition (interstitial) + real(r8), intent(inout) :: dcondt_resusp3d(ncnstaer,pcols,pver) + + ! Local variables + integer, parameter :: nsrflx = 5 ! last dimension of qsrflx + integer :: l, m, mm, ndx, lchnk + integer :: ncol + + real(r8) :: dqdt(pcols,pver,ncnstaer) + real(r8) :: dt + + + + real(r8) :: q(pcols,pver,ncnstaer) + real(r8) :: qsrflx(pcols,ncnstaer,nsrflx) + real(r8), pointer :: qptr(:,:) + + real(r8) :: sflxic(pcols,ncnstaer) + real(r8) :: sflxid(pcols,ncnstaer) + real(r8) :: sflxec(pcols,ncnstaer) + real(r8) :: sflxed(pcols,ncnstaer) + + type(ptr2d_t) :: raer(ncnstaer) ! aerosol mass, number mixing ratios + type(ptr2d_t) :: qqcw(ncnstaer) + + logical :: dotend(pcnst) + logical :: applytend + + !------------------------------------------------------------------------------------------------- + + dotend = .false. + + ! Initialize + lchnk = state%lchnk + ncol = state%ncol + dt = ztodt + + sflxic(:,:) = 0.0_r8 + sflxid(:,:) = 0.0_r8 + sflxec(:,:) = 0.0_r8 + sflxed(:,:) = 0.0_r8 + + call aero_state%get_states( aero_props, raer, qqcw ) + + ! prepare for deep conv processing + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) + + mm = aero_props%indexer(m,l) + ndx = aer_cnst_ndx(mm) + + sflxec(1:ncol,mm) = qsrflx_mzaer2cnvpr(1:ncol,mm,1) + sflxed(1:ncol,mm) = qsrflx_mzaer2cnvpr(1:ncol,mm,2) + + applytend = .false. + if ( ndx > 0 ) then + applytend = ptend%lq(ndx) + dotend(ndx) = applytend + endif + + qptr => raer(mm)%fld + + if ( applytend ) then + ! calc new q (after calcaersize and mz_aero_wet_intr) + q(1:ncol,:,mm) = max( 0.0_r8, qptr(1:ncol,:) + dt*ptend%q(1:ncol,:,ndx) ) + else + ! use old q + q(1:ncol,:,mm) = qptr(1:ncol,:) + end if + + end do + end do + + dqdt(:,:,:) = 0.0_r8 + qsrflx(:,:,:) = 0.0_r8 + + if (convproc_do_aer) then + + ! do deep conv processing + if (convproc_do_deep) then + call aero_convproc_dp_intr( aero_props, & + state, pbuf, dt, & + q, dqdt, nsrflx, qsrflx, dcondt_resusp3d ) + + ! apply deep conv processing tendency + + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) + mm = aero_props%indexer(m,l) + ndx = aer_cnst_ndx(mm) + + if ( apply_convproc_tend_to_ptend ) then + ! add dqdt onto ptend%q and set ptend%lq + if (ndx>0) then ! advected species + ptend%q(1:ncol,:,ndx) = ptend%q(1:ncol,:,ndx) + dqdt(1:ncol,:,mm) + else + raer(mm)%fld(1:ncol,:) = max( 0.0_r8, raer(mm)%fld(1:ncol,:) + dqdt(1:ncol,:,mm) * dt ) + end if + end if + + ! these used for history file wetdep diagnostics + sflxic(1:ncol,mm) = sflxic(1:ncol,mm) + qsrflx(1:ncol,mm,4) + sflxid(1:ncol,mm) = sflxid(1:ncol,mm) + qsrflx(1:ncol,mm,4) + sflxec(1:ncol,mm) = sflxec(1:ncol,mm) + qsrflx(1:ncol,mm,5) + sflxed(1:ncol,mm) = sflxed(1:ncol,mm) + qsrflx(1:ncol,mm,5) + + ! this used for surface coupling + if (ndx>0) then + aerdepwetis(1:ncol,ndx) = aerdepwetis(1:ncol,ndx) & + + qsrflx(1:ncol,mm,4) + qsrflx(1:ncol,mm,5) + end if + end do + end do + + end if + + end if ! (convproc_do_aer) then + + if (convproc_do_aer .and. apply_convproc_tend_to_ptend ) then + + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) + mm = aero_props%indexer(m,l) + + ndx = aer_cnst_ndx(mm) + + if (ndx>0) call outfld( trim(cnst_name_extd(1,mm))//'SFWETC', aerdepwetis(:,ndx), pcols, lchnk ) + call outfld( trim(cnst_name_extd(1,mm))//'SFSIC', sflxic(:,mm), pcols, lchnk ) + call outfld( trim(cnst_name_extd(1,mm))//'SFSEC', sflxec(:,mm), pcols, lchnk ) + + if ( deepconv_wetdep_history ) then + call outfld( trim(cnst_name_extd(1,mm))//'SFSID', sflxid(:,mm), pcols, lchnk ) + call outfld( trim(cnst_name_extd(1,mm))//'SFSED', sflxed(:,mm), pcols, lchnk ) + end if + end do + end do + + end if + +end subroutine aero_convproc_intr + +!========================================================================================= + +subroutine aero_convproc_dp_intr( aero_props, & + state, pbuf, dt, & + q, dqdt, nsrflx, qsrflx, dcondt_resusp3d) +!----------------------------------------------------------------------- +! +! Convective cloud processing (transport, activation/resuspension, +! wet removal) of aerosols and trace gases. +! (Currently no aqueous chemistry and no trace-gas wet removal) +! Does aerosols when convproc_do_aer is .true. +! +! This routine does deep convection +! Uses mass fluxes, cloud water, precip production from the +! convective cloud routines +! +! Author: R. Easter +! +!----------------------------------------------------------------------- + + ! Arguments + class(aerosol_properties), intent(in) :: aero_props + + type(physics_state), intent(in ) :: state ! Physics state variables + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: dt ! delta t (model time increment) + + real(r8), intent(in) :: q(pcols,pver,ncnstaer) + real(r8), intent(inout) :: dqdt(pcols,pver,ncnstaer) + integer, intent(in) :: nsrflx + real(r8), intent(inout) :: qsrflx(pcols,ncnstaer,nsrflx) + real(r8), intent(inout) :: dcondt_resusp3d(ncnstaer,pcols,pver) + + integer :: i, l, m, mm + integer :: lchnk + integer :: nstep + + real(r8) :: dpdry(pcols,pver) ! layer delta-p-dry (mb) + real(r8) :: fracice(pcols,pver) ! Ice fraction of cloud droplets + real(r8) :: xx_mfup_max(pcols), xx_wcldbase(pcols), xx_kcldbase(pcols) + + ! updraft interface TMR + wet-deposition TMR tendency diagnostics returned + ! from aero_convproc_run for the WETC/CONU history fields + real(r8) :: conu2(pcols,pver,2,ncnstaer) + real(r8) :: dcondt2(pcols,pver,2,ncnstaer) + + character(len=512) :: errmsg + integer :: errflg + + ! physics buffer fields + real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble + real(r8), pointer :: rprddp(:,:) ! Deep conv precip production (kg/kg/s - grid avg) + real(r8), pointer :: evapcdp(:,:) ! Deep conv precip evaporation (kg/kg/s - grid avg) + real(r8), pointer :: icwmrdp(:,:) ! Deep conv cloud condensate (kg/kg - in cloud) + real(r8), pointer :: dp_frac(:,:) ! Deep conv cloud frac (0-1) + + ! deep conv variables + real(r8), pointer :: du(:,:) ! Mass detrain rate from updraft (pcols,pver) + real(r8), pointer :: eu(:,:) ! Mass entrain rate into updraft (pcols,pver) + real(r8), pointer :: ed(:,:) ! Mass entrain rate into downdraft (pcols,pver) + ! eu, ed, du are "d(massflux)/dp" and are all positive + real(r8), pointer :: dp(:,:) ! Delta pressure between interfaces (pcols,pver) + integer, pointer :: jt(:) ! Index of cloud top for each column (pcols) + integer, pointer :: maxg(:) ! Index of cloud bottom for each column (pcols) + integer, pointer :: ideep(:) ! Gathering array (pcols) + integer :: lengath ! Gathered min lon indices over which to operate + + ! Initialize + + lchnk = state%lchnk + nstep = get_nstep() + + ! Associate pointers with physics buffer fields + call pbuf_get_field(pbuf, rprddp_idx, rprddp) + call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp) + call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp) + call pbuf_get_field(pbuf, dp_frac_idx, dp_frac) + call pbuf_get_field(pbuf, fracis_idx, fracis) + call pbuf_get_field(pbuf, zm_eu_idx, eu) + call pbuf_get_field(pbuf, zm_du_idx, du) + call pbuf_get_field(pbuf, zm_ed_idx, ed) + call pbuf_get_field(pbuf, zm_dp_idx, dp) + call pbuf_get_field(pbuf, zm_jt_idx, jt) + call pbuf_get_field(pbuf, zm_maxg_idx, maxg) + call pbuf_get_field(pbuf, zm_ideep_idx, ideep) + + lengath = count(ideep > 0) + + fracice(:,:) = 0.0_r8 + + ! initialize dpdry (units=mb), which is used for tracers of dry mixing ratio type + dpdry = 0._r8 + do i = 1, lengath + dpdry(i,:) = state%pdeldry(ideep(i),:)/100._r8 + end do + + call aero_convproc_run( aero_props, 'deep', lchnk, dt, & + state%t, state%pmid, q, du, eu, & + ed, dp, dpdry, jt, & + maxg, ideep, 1, lengath, & + dp_frac, icwmrdp, rprddp, evapcdp, & + fracice, dqdt, nsrflx, qsrflx, & + xx_mfup_max, xx_wcldbase, xx_kcldbase, & + dcondt_resusp3d, conu2, dcondt2, & + state%ncol, pver, ncnstaer, nbins, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & + convproc_do_evaprain_atonce, & + convproc_pom_spechygro, & + errmsg, errflg ) + if (errflg /= 0) call endrun(trim(errmsg)) + + call outfld( 'DP_MFUP_MAX', xx_mfup_max, pcols, lchnk ) + call outfld( 'DP_WCLDBASE', xx_wcldbase, pcols, lchnk ) + call outfld( 'DP_KCLDBASE', xx_kcldbase, pcols, lchnk ) + + ! WETC = wet-deposition tendency, CONU = updraft mixing ratio (interstitial + ! and cloud-borne); computed in aero_convproc_run and returned as out-args + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) + mm = aero_props%indexer(m,l) + + call outfld( trim(cnst_name_extd(1,mm))//'WETC', dcondt2(:,:,1,mm), pcols, lchnk ) + call outfld( trim(cnst_name_extd(1,mm))//'CONU', conu2(:,:,1,mm), pcols, lchnk ) + call outfld( trim(cnst_name_extd(2,mm))//'WETC', dcondt2(:,:,2,mm), pcols, lchnk ) + call outfld( trim(cnst_name_extd(2,mm))//'CONU', conu2(:,:,2,mm), pcols, lchnk ) + + end do + end do + +end subroutine aero_convproc_dp_intr + +!========================================================================================= + +end module aero_convproc_cam diff --git a/src/chemistry/aerosol/aero_drydep_core.F90 b/src/chemistry/aerosol/aero_drydep_core.F90 new file mode 100644 index 0000000000..0ae24842f7 --- /dev/null +++ b/src/chemistry/aerosol/aero_drydep_core.F90 @@ -0,0 +1,319 @@ +!=============================================================================== +! Aerosol dry deposition +! Portable science routines split from modal_aero/aero_model.F90 and +! aer_drydep_mod.F90: surface deposition velocities of particles +! (Zhang et al. 2001) and the aerodynamic resistance / friction velocity +! patch over ocean and sea ice. Host constants and the landuse fractions +! are passed as arguments; array sizing is by ncol/pver runtime arguments. +!=============================================================================== +module aero_drydep_core + + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + private + + public :: modal_aero_depvel_part + public :: calcram + +contains + + !============================================================================= + !============================================================================= + subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc_grv, & + radius_part, density_part, sig_part, moment, & + pver, top_lev, n_land_type, fraction_landuse, & + pi, boltz, gravit, rair, aspherical ) ! dmleung added aspherical flag 20 Oct 2025 + +! calculates surface deposition velocity of particles +! L. Zhang, S. Gong, J. Padro, and L. Barrie +! A size-seggregated particle dry deposition scheme for an atmospheric aerosol module +! Atmospheric Environment, 35, 549-560, 2001. +! +! Authors: X. Liu + + ! !ARGUMENTS: + ! + implicit none + ! + real(r8), intent(in) :: t(:,:) !atm temperature (K) + real(r8), intent(in) :: pmid(:,:) !atm pressure (Pa) + real(r8), intent(in) :: fv(:) !friction velocity (m/s) + real(r8), intent(in) :: ram1(:) !aerodynamical resistance (s/m) + real(r8), intent(in) :: radius_part(:,:) ! mean (volume/number) particle radius (m) + real(r8), intent(in) :: density_part(:,:) ! density of particle material (kg/m3) + real(r8), intent(in) :: sig_part(:,:) ! geometric standard deviation of particles + integer, intent(in) :: moment ! moment of size distribution (0 for number, 2 for surface area, 3 for volume) + integer, intent(in) :: ncol + integer, intent(in) :: pver ! number of vertical levels + integer, intent(in) :: top_lev ! top level for modal aerosols + integer, intent(in) :: n_land_type ! number of land use types + real(r8), intent(in) :: fraction_landuse(:,:) ! land use fractions (ncol, n_land_type) + real(r8), intent(in) :: pi ! host model constants + real(r8), intent(in) :: boltz ! Boltzmann constant (J/K) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + real(r8), intent(in) :: rair ! gas constant for dry air (J/K/kg) + + real(r8), intent(out) :: vlc_trb(:) !Turbulent deposn velocity (m/s) + real(r8), intent(out) :: vlc_grv(:,:) !grav deposn velocity (m/s) + real(r8), intent(out) :: vlc_dry(:,:) !dry deposn velocity (m/s) + logical, intent(in), OPTIONAL :: aspherical ! dmleung: asphericity is strong for coarse-mode interstitial + ! aerosols only, mostly dust and seasalt. For coarse mode aerosols, asphericity reduces coarse-mode gravitational + ! settling velocity by 20 % following Fig. 4 of Yue Huang et al. (2020). + !------------------------------------------------------------------------ + + !------------------------------------------------------------------------ + ! Local Variables + integer :: m,i,k,ix !indices + real(r8) :: rho !atm density (kg/m**3) + real(r8) :: vsc_dyn_atm(ncol,pver) ![kg m-1 s-1] Dynamic viscosity of air + real(r8) :: vsc_knm_atm(ncol,pver) ![m2 s-1] Kinematic viscosity of atmosphere + real(r8) :: shm_nbr ![frc] Schmidt number + real(r8) :: stk_nbr ![frc] Stokes number + real(r8) :: mfp_atm(ncol,pver) ![m] Mean free path of air + real(r8) :: dff_aer ![m2 s-1] Brownian diffusivity of particle + real(r8) :: slp_crc(ncol,pver) ![frc] Slip correction factor + real(r8) :: rss_trb ![s m-1] Resistance to turbulent deposition + real(r8) :: rss_lmn ![s m-1] Quasi-laminar layer resistance + real(r8) :: brownian ! collection efficiency for Browning diffusion + real(r8) :: impaction ! collection efficiency for impaction + real(r8) :: interception ! collection efficiency for interception + real(r8) :: stickfrac ! fraction of particles sticking to surface + real(r8) :: radius_moment(ncol,pver) ! median radius (m) for moment + real(r8) :: lnsig ! ln(sig_part) + real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity + ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) + + integer :: lt + real(r8) :: lnd_frc + real(r8) :: wrk1, wrk2, wrk3 + + ! constants + + real(r8), parameter :: asphericaldust_drydep = 0.8_r8 ! dmleung added 20 Oct 2025: aspherical dust reduces + ! gravitational settling velocity by 15-20 %. Yue Huang et al. (2020) + ! Climate Models and Remote Sensing Retrievals Neglect Substantial Desert Dust Asphericity + + real(r8) gamma(11) ! exponent of schmidt number +! data gamma/0.54d+00, 0.56d+00, 0.57d+00, 0.54d+00, 0.54d+00, & +! 0.56d+00, 0.54d+00, 0.54d+00, 0.54d+00, 0.56d+00, & +! 0.50d+00/ + data gamma/0.56e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.56e+00_r8, 0.56e+00_r8, & + 0.56e+00_r8, 0.50e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.54e+00_r8, & + 0.54e+00_r8/ + save gamma + + real(r8) alpha(11) ! parameter for impaction +! data alpha/50.00d+00, 0.95d+00, 0.80d+00, 1.20d+00, 1.30d+00, & +! 0.80d+00, 50.00d+00, 50.00d+00, 2.00d+00, 1.50d+00, & +! 100.00d+00/ + data alpha/1.50e+00_r8, 1.20e+00_r8, 1.20e+00_r8, 0.80e+00_r8, 1.00e+00_r8, & + 0.80e+00_r8, 100.00e+00_r8, 50.00e+00_r8, 2.00e+00_r8, 1.20e+00_r8, & + 50.00e+00_r8/ + save alpha + + real(r8) radius_collector(11) ! radius (m) of surface collectors +! data radius_collector/-1.00d+00, 5.10d-03, 3.50d-03, 3.20d-03, 10.00d-03, & +! 5.00d-03, -1.00d+00, -1.00d+00, 10.00d-03, 10.00d-03, & +! -1.00d+00/ + data radius_collector/10.00e-03_r8, 3.50e-03_r8, 3.50e-03_r8, 5.10e-03_r8, 2.00e-03_r8, & + 5.00e-03_r8, -1.00e+00_r8, -1.00e+00_r8, 10.00e-03_r8, 3.50e-03_r8, & + -1.00e+00_r8/ + save radius_collector + + integer :: iwet(11) ! flag for wet surface = 1, otherwise = -1 +! data iwet/1, -1, -1, -1, -1, & +! -1, -1, -1, 1, -1, & +! 1/ + data iwet/-1, -1, -1, -1, -1, & + -1, 1, -1, 1, -1, & + -1/ + save iwet + + + vlc_trb = 0._r8 + vlc_grv = 0._r8 + vlc_dry = 0._r8 + + !------------------------------------------------------------------------ + do k=top_lev,pver ! radius_part is not defined above top_lev + do i=1,ncol + + lnsig = log(sig_part(i,k)) +! use a maximum radius of 50 microns when calculating deposition velocity + radius_moment(i,k) = min(50.0e-6_r8,radius_part(i,k))* & + exp((float(moment)-1.5_r8)*lnsig*lnsig) + dispersion = exp(2._r8*lnsig*lnsig) + + rho=pmid(i,k)/rair/t(i,k) + + ! Quasi-laminar layer resistance: call rss_lmn_get + ! Size-independent thermokinetic properties + vsc_dyn_atm(i,k) = 1.72e-5_r8 * ((t(i,k)/273.0_r8)**1.5_r8) * 393.0_r8 / & + (t(i,k)+120.0_r8) ![kg m-1 s-1] RoY94 p. 102 + mfp_atm(i,k) = 2.0_r8 * vsc_dyn_atm(i,k) / & ![m] SeP97 p. 455 + (pmid(i,k)*sqrt(8.0_r8/(pi*rair*t(i,k)))) + vsc_knm_atm(i,k) = vsc_dyn_atm(i,k) / rho ![m2 s-1] Kinematic viscosity of air + + slp_crc(i,k) = 1.0_r8 + mfp_atm(i,k) * & + (1.257_r8+0.4_r8*exp(-1.1_r8*radius_moment(i,k)/(mfp_atm(i,k)))) / & + radius_moment(i,k) ![frc] Slip correction factor SeP97 p. 464 + vlc_grv(i,k) = (4.0_r8/18.0_r8) * radius_moment(i,k)*radius_moment(i,k)*density_part(i,k)* & + gravit*slp_crc(i,k) / vsc_dyn_atm(i,k) ![m s-1] Stokes' settling velocity SeP97 p. 466 + vlc_grv(i,k) = vlc_grv(i,k) * dispersion + + ! dmleung edited 20 Oct 2025 based on Longlei Li's edits ++ + ! asphericity reduces gravitational settling velocity of coarse-mode aerosols by 20 %. + ! scale flag is only true for coarse mode (m == n_coarse_dust). + if (present(aspherical)) then + if(aspherical) then + vlc_grv(i,k) = vlc_grv(i,k) * asphericaldust_drydep + end if + end if + ! dmleung -- + + vlc_dry(i,k)=vlc_grv(i,k) + enddo + enddo + k=pver ! only look at bottom level for next part + do i=1,ncol + dff_aer = boltz * t(i,k) * slp_crc(i,k) / & ![m2 s-1] + (6.0_r8*pi*vsc_dyn_atm(i,k)*radius_moment(i,k)) !SeP97 p.474 + shm_nbr = vsc_knm_atm(i,k) / dff_aer ![frc] SeP97 p.972 + + wrk2 = 0._r8 + wrk3 = 0._r8 + do lt = 1,n_land_type + lnd_frc = fraction_landuse(i,lt) + if ( lnd_frc /= 0._r8 ) then + brownian = shm_nbr**(-gamma(lt)) + if (radius_collector(lt) > 0.0_r8) then +! vegetated surface + stk_nbr = vlc_grv(i,k) * fv(i) / (gravit*radius_collector(lt)) + interception = 2.0_r8*(radius_moment(i,k)/radius_collector(lt))**2.0_r8 + else +! non-vegetated surface + stk_nbr = vlc_grv(i,k) * fv(i) * fv(i) / (gravit*vsc_knm_atm(i,k)) ![frc] SeP97 p.965 + interception = 0.0_r8 + endif + impaction = (stk_nbr/(alpha(lt)+stk_nbr))**2.0_r8 + + if (iwet(lt) > 0) then + stickfrac = 1.0_r8 + else + stickfrac = exp(-sqrt(stk_nbr)) + if (stickfrac < 1.0e-10_r8) stickfrac = 1.0e-10_r8 + endif + rss_lmn = 1.0_r8 / (3.0_r8 * fv(i) * stickfrac * (brownian+interception+impaction)) + rss_trb = ram1(i) + rss_lmn + ram1(i)*rss_lmn*vlc_grv(i,k) + + wrk1 = 1.0_r8 / rss_trb + wrk2 = wrk2 + lnd_frc*( wrk1 ) + wrk3 = wrk3 + lnd_frc*( wrk1 + vlc_grv(i,k) ) + endif + enddo ! n_land_type + vlc_trb(i) = wrk2 + vlc_dry(i,k) = wrk3 + enddo !ncol + + return + end subroutine modal_aero_depvel_part + +!------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: subroutine Calcram +! +! !INTERFACE: +! + + subroutine calcram(ncol,landfrac,icefrac,ocnfrac,obklen,& + ustar,ram1in,ram1,t,pmid,& + pdel,fvin,fv,rair,gravit) + ! + ! !DESCRIPTION: + ! + ! Calc aerodynamic resistance over oceans and sea ice (comes in from land model) + ! from Seinfeld and Pandis, p.963. + ! + ! Author: Natalie Mahowald + ! + implicit none + integer, intent(in) :: ncol + real(r8),intent(in) :: ram1in(:) !aerodynamical resistance (s/m) + real(r8),intent(in) :: fvin(:) ! sfc frc vel from land + real(r8),intent(out) :: ram1(:) !aerodynamical resistance (s/m) + real(r8),intent(out) :: fv(:) ! sfc frc vel from land + real(r8), intent(in) :: obklen(:) ! obklen + real(r8), intent(in) :: ustar(:) ! sfc fric vel + real(r8), intent(in) :: landfrac(:) ! land fraction + real(r8), intent(in) :: icefrac(:) ! ice fraction + real(r8), intent(in) :: ocnfrac(:) ! ocean fraction + real(r8), intent(in) :: t(:) !atm temperature (K) + real(r8), intent(in) :: pmid(:) !atm pressure (Pa) + real(r8), intent(in) :: pdel(:) !atm pressure (Pa) + real(r8), intent(in) :: rair ! gas constant for dry air (J/K/kg) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + real(r8), parameter :: zzocen = 0.0001_r8 ! Ocean aerodynamic roughness length + real(r8), parameter :: zzsice = 0.0400_r8 ! Sea ice aerodynamic roughness length + real(r8), parameter :: xkar = 0.4_r8 ! Von Karman constant + + ! local variables + real(r8) :: z,psi,psi0,nu,nu0,temp,ram + integer :: i + ! write(iulog,*) rair,zzsice,zzocen,gravit,xkar + + + do i=1,ncol + z=pdel(i)*rair*t(i)/pmid(i)/gravit/2.0_r8 !use half the layer height like Ganzefeld and Lelieveld, 1995 + if(obklen(i).eq.0) then + psi=0._r8 + psi0=0._r8 + else + psi=min(max(z/obklen(i),-1.0_r8),1.0_r8) + psi0=min(max(zzocen/obklen(i),-1.0_r8),1.0_r8) + endif + temp=z/zzocen + if(icefrac(i) > 0.5_r8) then + if(obklen(i).gt.0) then + psi0=min(max(zzsice/obklen(i),-1.0_r8),1.0_r8) + else + psi0=0.0_r8 + endif + temp=z/zzsice + endif + if(psi> 0._r8) then + ram=1/xkar/ustar(i)*(log(temp)+4.7_r8*(psi-psi0)) + else + nu=(1.00_r8-15.000_r8*psi)**(.25_r8) + nu0=(1.000_r8-15.000_r8*psi0)**(.25_r8) + if(ustar(i).ne.0._r8) then + ram=1/xkar/ustar(i)*(log(temp) & + +log(((nu0**2+1.00_r8)*(nu0+1.0_r8)**2)/((nu**2+1.0_r8)*(nu+1.00_r8)**2)) & + +2.0_r8*(atan(nu)-atan(nu0))) + else + ram=0._r8 + endif + endif + if(landfrac(i) < 0.000000001_r8) then + fv(i)=ustar(i) + ram1(i)=ram + else + fv(i)=fvin(i) + ram1(i)=ram1in(i) + endif + ! write(iulog,*) i,pdel(i),t(i),pmid(i),gravit,obklen(i),psi,psi0,icefrac(i),nu,nu0,ram,ustar(i),& + ! log(((nu0**2+1.00)*(nu0+1.0)**2)/((nu**2+1.0)*(nu+1.00)**2)),2.0*(atan(nu)-atan(nu0)) + + enddo + + ! fvitt -- fv == 0 causes a floating point exception in + ! dry dep of sea salts and dust + where ( fv(:ncol) == 0._r8 ) + fv(:ncol) = 1.e-12_r8 + endwhere + + return + end subroutine calcram + +end module aero_drydep_core diff --git a/src/chemistry/aerosol/aero_wetdep_cam.F90 b/src/chemistry/aerosol/aero_wetdep_cam.F90 index 7bd5e984c5..7247b70128 100644 --- a/src/chemistry/aerosol/aero_wetdep_cam.F90 +++ b/src/chemistry/aerosol/aero_wetdep_cam.F90 @@ -14,7 +14,7 @@ module aero_wetdep_cam use infnan, only: nan, assignment(=) use cam_history, only: addfld, add_default, horiz_only, outfld - use wetdep, only: wetdep_init + use wetdep_cam, only: wetdep_init use aerosol_properties_mod, only: aero_name_len use aerosol_properties_mod, only: aerosol_properties @@ -24,9 +24,9 @@ module aero_wetdep_cam aerosol_instances_get_props, & aerosol_instances_get_num_models - use aero_convproc, only: aero_convproc_readnl, aero_convproc_init, aero_convproc_intr - use aero_convproc, only: convproc_do_evaprain_atonce - use aero_convproc, only: deepconv_wetdep_history + use aero_convproc_cam, only: aero_convproc_readnl, aero_convproc_init, aero_convproc_intr + use aero_convproc_cam, only: convproc_do_evaprain_atonce + use aero_convproc_cam, only: deepconv_wetdep_history use infnan, only: nan, assignment(=) use perf_mod, only: t_startf, t_stopf @@ -56,12 +56,6 @@ module aero_wetdep_cam integer,allocatable :: aero_cnst_id(:,:) logical, public, protected :: wetdep_lq(pcnst) ! set flags true for constituents with non-zero tendencies - ! variables for table lookup of aerosol impaction/interception scavenging rates - integer, parameter :: nimptblgrow_mind=-7, nimptblgrow_maxd=12 - real(r8) :: dlndg_nimptblgrow - real(r8),allocatable :: scavimptblnum(:,:) - real(r8),allocatable :: scavimptblvol(:,:) - integer :: nspec_max=0 integer :: nele_tot ! total number of aerosol elements class(aerosol_properties), pointer :: aero_props=>null() @@ -143,6 +137,9 @@ end subroutine aero_wetdep_readnl !------------------------------------------------------------------------------ subroutine aero_wetdep_init( ) + use wetdep, only: init_bcscavcoef + use mo_constants, only: pi, boltz_cgs, rgas_cgs + character(len=*), parameter :: subrname = 'aero_wetdep_init' character(len=2) :: unit_basename ! Units 'kg' or '1' @@ -156,6 +153,9 @@ subroutine aero_wetdep_init( ) character(len=2) :: binstr class(aerosol_properties), pointer :: props_tmp + character(len=512) :: errmsg ! error handling for the portable init_bcscavcoef + integer :: errflg + fracis_idx = pbuf_get_index('FRACIS') rprddp_idx = pbuf_get_index('RPRDDP') rprdsh_idx = pbuf_get_index('RPRDSH') @@ -235,22 +235,15 @@ subroutine aero_wetdep_init( ) end do end do - allocate(scavimptblnum(nimptblgrow_mind:nimptblgrow_maxd, aero_props%nbins()), stat=astat) - if (astat/=0) then - call endrun(subrname//' : not able to allocate scavimptblnum array') - end if - allocate(scavimptblvol(nimptblgrow_mind:nimptblgrow_maxd, aero_props%nbins()), stat=astat) - if (astat/=0) then - call endrun(subrname//' : not able to allocate scavimptblvol array') - end if - scavimptblnum = nan - scavimptblvol = nan - call wetdep_init() nspec_max = maxval(aero_props%nspecies()) + 2 - call init_bcscavcoef() + ! build the below-cloud impaction/interception scavenging lookup table + ! (allocation + fill are owned by the portable init_bcscavcoef) + call init_bcscavcoef( aero_props, pi, boltz_cgs, rgas_cgs, & + errmsg, errflg ) + if (errflg /= 0) call endrun(trim(errmsg)) if (convproc_do_aer) then call aero_convproc_init(aero_props) @@ -322,7 +315,8 @@ end subroutine aero_wetdep_init !------------------------------------------------------------------------------ !------------------------------------------------------------------------------ subroutine aero_wetdep_tend( state, dt, dlf, cam_out, ptend, pbuf) - use wetdep, only: wetdepa_v2, wetdep_inputs_set, wetdep_inputs_t + use wetdep, only: wetdepa_v2, get_bcscavcoefs + use wetdep_cam, only: wetdep_inputs_set, wetdep_inputs_t use aerodep_flx, only: aerodep_flx_prescribed use aero_deposition_cam, only: aero_deposition_cam_setwet @@ -335,6 +329,8 @@ subroutine aero_wetdep_tend( state, dt, dlf, cam_out, ptend, pbuf) character(len=*), parameter :: subrname = 'aero_wetdep_tend' type(wetdep_inputs_t) :: dep_inputs + character(len=512) :: errmsg ! error handling for the portable wetdepa_v2 + integer :: errflg real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble (pcols, pver, pcnst) real(r8), target :: fracis_nadv(pcols,pver) ! fraction of not-transported aerosols @@ -546,7 +542,7 @@ subroutine aero_wetdep_tend( state, dt, dlf, cam_out, ptend, pbuf) scavcoefnv = 0.0_r8 if (lphase == 1) then ! interstial aerosol - call get_bcscavcoefs( m, ncol, isprx, diam_wet, scavcoefnv(:,:,1), scavcoefnv(:,:,2) ) + call get_bcscavcoefs( m, ncol, pver, isprx, diam_wet, scavcoefnv(:,:,1), scavcoefnv(:,:,2), aero_props ) if ( sol_factb_interstitial /= NOTSET ) then sol_factb(:ncol,:) = sol_factb_interstitial ! all below-cloud scav @@ -607,20 +603,21 @@ subroutine aero_wetdep_tend( state, dt, dlf, cam_out, ptend, pbuf) dqdt_tmp(1:ncol,:) = 0.0_r8 - call wetdepa_v2(state%pmid, state%q(:,:,1), state%pdel, & + call wetdepa_v2(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%evapc, dep_inputs%conicw, dep_inputs%prain, & dep_inputs%evapr, dep_inputs%totcond, q_tmp, dt, & dqdt_tmp, iscavt, dep_inputs%cldvcu, dep_inputs%cldvst, & - dlf, insolfr_ptr, sol_factb, ncol, & - scavcoefnv(:,:,jnv), & + dlf, insolfr_ptr, sol_factb(:ncol,:), ncol, & + scavcoefnv(:,:,jnv), gravit, pver, errmsg, errflg, & is_strat_cloudborne=cldbrn, & qqcw=qqcw_in(:,:), f_act_conv=f_act_conv, & icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & convproc_do_aer=convproc_do_aer, rcscavt=rcscavt, rsscavt=rsscavt, & - sol_facti_in=sol_facti, sol_factic_in=sol_factic, & + sol_facti_in=sol_facti(:ncol,:), sol_factic_in=sol_factic(:ncol,:), & convproc_do_evaprain_atonce_in=convproc_do_evaprain_atonce, & bergso_in=dep_inputs%bergso ) + if (errflg /= 0) call endrun(trim(errmsg)) if(convproc_do_aer) then if(cldbrn) then @@ -804,399 +801,6 @@ subroutine aero_wetdep_tend( state, dt, dlf, cam_out, ptend, pbuf) call aero_deposition_cam_setwet(aerdepwetis, aerdepwetcw, cam_out) endif - contains - - ! below cloud impaction scavenging coefs - subroutine get_bcscavcoefs( m, ncol, isprx, diam_wet, scavcoefnum, scavcoefvol ) - - integer,intent(in) :: m, ncol - logical,intent(in):: isprx(:,:) - real(r8), intent(in) :: diam_wet(:,:) - real(r8), intent(out) :: scavcoefnum(:,:), scavcoefvol(:,:) - - integer i, k, jgrow - real(r8) dumdgratio, xgrow, dumfhi, dumflo, scavimpvol, scavimpnum - - do k = 1, pver - do i = 1, ncol - - ! do only if no precip - if ( isprx(i,k) .and. diam_wet(i,k)>0.0_r8) then - ! - ! interpolate table values using log of (actual-wet-size)/(base-dry-size) - - dumdgratio = diam_wet(i,k)/aero_props%scav_diam(m) - if ((dumdgratio >= 0.99_r8) .and. (dumdgratio <= 1.01_r8)) then - scavimpvol = scavimptblvol(0,m) - scavimpnum = scavimptblnum(0,m) - else - xgrow = log( dumdgratio ) / dlndg_nimptblgrow - jgrow = int( xgrow ) - if (xgrow < 0._r8) jgrow = jgrow - 1 - if (jgrow < nimptblgrow_mind) then - jgrow = nimptblgrow_mind - xgrow = jgrow - else - jgrow = min( jgrow, nimptblgrow_maxd-1 ) - end if - - dumfhi = xgrow - jgrow - dumflo = 1._r8 - dumfhi - - scavimpvol = dumflo*scavimptblvol(jgrow,m) + & - dumfhi*scavimptblvol(jgrow+1,m) - scavimpnum = dumflo*scavimptblnum(jgrow,m) + & - dumfhi*scavimptblnum(jgrow+1,m) - - end if - - ! impaction scavenging removal amount for volume - scavcoefvol(i,k) = exp( scavimpvol ) - ! impaction scavenging removal amount to number - scavcoefnum(i,k) = exp( scavimpnum ) - - else - scavcoefvol(i,k) = 0._r8 - scavcoefnum(i,k) = 0._r8 - end if - - end do - end do - - end subroutine get_bcscavcoefs - end subroutine aero_wetdep_tend - !------------------------------------------------------------------------------ - !------------------------------------------------------------------------------ - subroutine init_bcscavcoef( ) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Computes lookup table for aerosol impaction/interception scavenging rates - ! - ! Authors: R. Easter - ! Simone Tilmes Nov 2021 - ! added modifications for bin model, assuming sigma = 1. - ! - !----------------------------------------------------------------------- - - use mo_constants, only: pi - - ! local variables - integer nnfit_maxd - parameter (nnfit_maxd=27) - - integer m, jgrow, nnfit - integer lunerr - - real(r8) dg0, dg0_cgs, press, dg0_base, & - rhodryaero, rhowetaero, rhowetaero_cgs, & - scavratenum, scavratevol, logsig, & - temp, wetdiaratio, wetvolratio - - real(r8) :: xxfitnum(1,nnfit_maxd), yyfitnum(nnfit_maxd) - real(r8) :: xxfitvol(1,nnfit_maxd), yyfitvol(nnfit_maxd) - - character(len=*), parameter :: subname = 'aero_wetdep_cam::init_bcscavcoef' - - lunerr = iulog - dlndg_nimptblgrow = log( 1.25_r8 ) - - ! bin model: main loop over aerosol bins - - modeloop: do m = 1, aero_props%nbins() - - ! for setting up the lookup table, use the dry density of the first species - ! -- assume the first species of the mode/bin is the dominate species - call aero_props%get(m,1,density=rhodryaero) - - dg0_base = aero_props%scav_diam(m) - - logsig = aero_props%alogsig(m) - - growloop: do jgrow = nimptblgrow_mind, nimptblgrow_maxd - - wetdiaratio = exp( jgrow*dlndg_nimptblgrow ) - dg0 = dg0_base*wetdiaratio - - wetvolratio = exp( jgrow*dlndg_nimptblgrow*3._r8 ) - rhowetaero = 1.0_r8 + (rhodryaero-1.0_r8)/wetvolratio - rhowetaero = min( rhowetaero, rhodryaero ) - - ! - ! compute impaction scavenging rates at 1 temp-press pair and save - ! - nnfit = 0 - - temp = 273.16_r8 - press = 0.75e6_r8 ! dynes/cm2 - rhowetaero = rhodryaero - - dg0_cgs = dg0*1.0e2_r8 ! m to cm - - rhowetaero_cgs = rhowetaero*1.0e-3_r8 ! kg/m3 to g/cm3 - - call calc_1_impact_rate( & - dg0_cgs, logsig, rhowetaero_cgs, temp, press, & - scavratenum, scavratevol, lunerr ) - - nnfit = nnfit + 1 - if (nnfit > nnfit_maxd) then - write(lunerr,9110) - call endrun(subname//' : nnfit > nnfit_maxd') - end if -9110 format( '*** subr. init_bcscavcoef -- nnfit too big' ) - - xxfitnum(1,nnfit) = 1._r8 - yyfitnum(nnfit) = log( scavratenum ) - - xxfitvol(1,nnfit) = 1._r8 - yyfitvol(nnfit) = log( scavratevol ) - - !depends on both bins and different species - scavimptblnum(jgrow,m) = yyfitnum(1) - scavimptblvol(jgrow,m) = yyfitvol(1) - - enddo growloop - enddo modeloop - - contains - - !=============================================================================== - subroutine calc_1_impact_rate( & - dg0, logsig, rhoaero, temp, press, & - scavratenum, scavratevol, lunerr ) - ! - ! routine computes a single impaction scavenging rate - ! for precipitation rate of 1 mm/h - ! - ! dg0 = geometric mean diameter of aerosol number size distrib. (cm) - ! sigmag = geometric standard deviation of size distrib. - ! rhoaero = density of aerosol particles (g/cm^3) - ! temp = temperature (K) - ! press = pressure (dyne/cm^2) - ! scavratenum = number scavenging rate (1/h) - ! scavratevol = volume or mass scavenging rate (1/h) - ! lunerr = logical unit for error message - ! - use mo_constants, only: boltz_cgs, pi, rhowater => rhoh2o_cgs, rgas => rgas_cgs - - implicit none - - ! subr. parameters - integer, intent(in) :: lunerr - real(r8), intent(in) :: dg0, logsig, rhoaero, temp, press - real(r8), intent(out) :: scavratenum, scavratevol - - ! local variables - integer nrainsvmax - parameter (nrainsvmax=50) - real(r8) rrainsv(nrainsvmax), xnumrainsv(nrainsvmax),& - vfallrainsv(nrainsvmax) - - integer naerosvmax - parameter (naerosvmax=51) - real(r8) aaerosv(naerosvmax), & - ynumaerosv(naerosvmax), yvolaerosv(naerosvmax) - - integer i, ja, jr, na, nr - real(r8) a, aerodiffus, aeromass, ag0, airdynvisc, airkinvisc - real(r8) anumsum, avolsum, cair, chi - real(r8) d, dr, dum, dumfuchs, dx - real(r8) ebrown, eimpact, eintercept, etotal, freepath - real(r8) precip, precipmmhr, precipsum - real(r8) r, rainsweepout, reynolds, rhi, rhoair, rlo, rnumsum - real(r8) scavsumnum, scavsumnumbb - real(r8) scavsumvol, scavsumvolbb - real(r8) schmidt, sqrtreynolds, sstar, stokes, sx - real(r8) taurelax, vfall, vfallstp - real(r8) x, xg0, xg3, xhi, xlo, xmuwaterair - - rlo = .005_r8 - rhi = .250_r8 - dr = 0.005_r8 - nr = 1 + nint( (rhi-rlo)/dr ) - if (nr > nrainsvmax) then - write(lunerr,9110) - call endrun(subname//' : nr > nrainsvmax') - end if - -9110 format( '*** subr. calc_1_impact_rate -- nr > nrainsvmax' ) - - precipmmhr = 1.0_r8 - precip = precipmmhr/36000._r8 - - ag0 = dg0/2._r8 - sx = logsig - xg0 = log( ag0 ) - xg3 = xg0 + 3._r8*sx*sx - - xlo = xg3 - 4._r8*sx - xhi = xg3 + 4._r8*sx - dx = 0.2_r8*sx - - dx = max( 0.2_r8*sx, 0.01_r8 ) - xlo = xg3 - max( 4._r8*sx, 2._r8*dx ) - xhi = xg3 + max( 4._r8*sx, 2._r8*dx ) - - na = 1 + nint( (xhi-xlo)/dx ) - if (na > naerosvmax) then - write(lunerr,9120) - call endrun(subname//' : na > naerosvmax') - end if - -9120 format( '*** subr. calc_1_impact_rate -- na > naerosvmax' ) - - ! air molar density - cair = press/(rgas*temp) - ! air mass density - rhoair = 28.966_r8*cair - ! molecular freepath - freepath = 2.8052e-10_r8/cair - ! air dynamic viscosity - airdynvisc = 1.8325e-4_r8 * (416.16_r8/(temp+120._r8)) * & - ((temp/296.16_r8)**1.5_r8) - ! air kinemaic viscosity - airkinvisc = airdynvisc/rhoair - ! ratio of water viscosity to air viscosity (from Slinn) - xmuwaterair = 60.0_r8 - - ! - ! compute rain drop number concentrations - ! rrainsv = raindrop radius (cm) - ! xnumrainsv = raindrop number concentration (#/cm^3) - ! (number in the bin, not number density) - ! vfallrainsv = fall velocity (cm/s) - ! - precipsum = 0._r8 - do i = 1, nr - r = rlo + (i-1)*dr - rrainsv(i) = r - xnumrainsv(i) = exp( -r/2.7e-2_r8 ) - - d = 2._r8*r - if (d <= 0.007_r8) then - vfallstp = 2.88e5_r8 * d**2._r8 - else if (d <= 0.025_r8) then - vfallstp = 2.8008e4_r8 * d**1.528_r8 - else if (d <= 0.1_r8) then - vfallstp = 4104.9_r8 * d**1.008_r8 - else if (d <= 0.25_r8) then - vfallstp = 1812.1_r8 * d**0.638_r8 - else - vfallstp = 1069.8_r8 * d**0.235_r8 - end if - - vfall = vfallstp * sqrt(1.204e-3_r8/rhoair) - vfallrainsv(i) = vfall - precipsum = precipsum + vfall*(r**3)*xnumrainsv(i) - end do - precipsum = precipsum*pi*1.333333_r8 - - rnumsum = 0._r8 - do i = 1, nr - xnumrainsv(i) = xnumrainsv(i)*(precip/precipsum) - rnumsum = rnumsum + xnumrainsv(i) - end do - - ! - ! compute aerosol concentrations - ! aaerosv = particle radius (cm) - ! fnumaerosv = fraction of total number in the bin (--) - ! fvolaerosv = fraction of total volume in the bin (--) - ! - anumsum = 0._r8 - avolsum = 0._r8 - do i = 1, na - x = xlo + (i-1)*dx - a = exp( x ) - aaerosv(i) = a - dum = (x - xg0)/sx - ynumaerosv(i) = exp( -0.5_r8*dum*dum ) - yvolaerosv(i) = ynumaerosv(i)*1.3333_r8*pi*a*a*a - anumsum = anumsum + ynumaerosv(i) - avolsum = avolsum + yvolaerosv(i) - end do - - do i = 1, na - ynumaerosv(i) = ynumaerosv(i)/anumsum - yvolaerosv(i) = yvolaerosv(i)/avolsum - end do - - ! - ! compute scavenging - ! - scavsumnum = 0._r8 - scavsumvol = 0._r8 - ! - ! outer loop for rain drop radius - ! - jr_loop: do jr = 1, nr - - r = rrainsv(jr) - vfall = vfallrainsv(jr) - - reynolds = r * vfall / airkinvisc - sqrtreynolds = sqrt( reynolds ) - - ! - ! inner loop for aerosol particle radius - ! - scavsumnumbb = 0._r8 - scavsumvolbb = 0._r8 - - ja_loop: do ja = 1, na - - a = aaerosv(ja) - - chi = a/r - - dum = freepath/a - dumfuchs = 1._r8 + 1.246_r8*dum + 0.42_r8*dum*exp(-0.87_r8/dum) - taurelax = 2._r8*rhoaero*a*a*dumfuchs/(9._r8*rhoair*airkinvisc) - - aeromass = 4._r8*pi*a*a*a*rhoaero/3._r8 - aerodiffus = boltz_cgs*temp*taurelax/aeromass - - schmidt = airkinvisc/aerodiffus - stokes = vfall*taurelax/r - - ebrown = 4._r8*(1._r8 + 0.4_r8*sqrtreynolds*(schmidt**0.3333333_r8)) / & - (reynolds*schmidt) - - dum = (1._r8 + 2._r8*xmuwaterair*chi) / & - (1._r8 + xmuwaterair/sqrtreynolds) - eintercept = 4._r8*chi*(chi + dum) - - dum = log( 1._r8 + reynolds ) - sstar = (1.2_r8 + dum/12._r8) / (1._r8 + dum) - eimpact = 0._r8 - if (stokes > sstar) then - dum = stokes - sstar - eimpact = (dum/(dum+0.6666667_r8)) ** 1.5_r8 - end if - - etotal = ebrown + eintercept + eimpact - etotal = min( etotal, 1.0_r8 ) - - rainsweepout = xnumrainsv(jr)*4._r8*pi*r*r*vfall - - scavsumnumbb = scavsumnumbb + rainsweepout*etotal*ynumaerosv(ja) - scavsumvolbb = scavsumvolbb + rainsweepout*etotal*yvolaerosv(ja) - - enddo ja_loop - - scavsumnum = scavsumnum + scavsumnumbb - scavsumvol = scavsumvol + scavsumvolbb - - enddo jr_loop - - scavratenum = scavsumnum*3600._r8 - scavratevol = scavsumvol*3600._r8 - - end subroutine calc_1_impact_rate - - end subroutine init_bcscavcoef - end module aero_wetdep_cam diff --git a/src/chemistry/aerosol/aerosol_optics_core.F90 b/src/chemistry/aerosol/aerosol_optics_core.F90 index 63d47f8496..eb10958614 100644 --- a/src/chemistry/aerosol/aerosol_optics_core.F90 +++ b/src/chemistry/aerosol/aerosol_optics_core.F90 @@ -26,8 +26,9 @@ module aerosol_optics_core ! Returns a null pointer for unrecognized opticstype (caller handles error). !=============================================================================== function create_aerosol_optics_object(aeroprops, aerostate, ibin, & - ncol, nlev, nswbands, nlwbands, numrh, & - relh, sulfwtpct, crefwsw, crefwlw, & + ncol, nlev, top_lev, nswbands, nlwbands, numrh, & + relh, sulfwtpct, t, pmid, h2ommr, cldn, & + crefwsw, crefwlw, & geometric_radius) result(aero_optics) use phys_prop, only: ot_length @@ -49,11 +50,16 @@ function create_aerosol_optics_object(aeroprops, aerostate, ibin, & integer, intent(in) :: ibin integer, intent(in) :: ncol integer, intent(in) :: nlev + integer, intent(in) :: top_lev integer, intent(in) :: nswbands integer, intent(in) :: nlwbands integer, intent(in) :: numrh real(r8), intent(in) :: relh(:, :) real(r8), intent(in) :: sulfwtpct(:, :) + real(r8), intent(in) :: t(:, :) ! temperature (K) + real(r8), intent(in) :: pmid(:, :) ! layer pressure (Pa) + real(r8), intent(in) :: h2ommr(:, :) ! specific humidity (kg/kg) + real(r8), intent(in) :: cldn(:, :) ! layer cloud fraction (0-1) complex(r8), intent(in) :: crefwsw(:) complex(r8), intent(in) :: crefwlw(:) real(r8), intent(in), optional, pointer :: geometric_radius(:, :) @@ -69,7 +75,8 @@ function create_aerosol_optics_object(aeroprops, aerostate, ibin, & select case (trim(opticstype)) case ('modal') ! refractive method aero_optics => refractive_aerosol_optics(aeroprops, aerostate, ibin, & - ncol, nlev, nswbands, nlwbands, crefwsw, crefwlw) + ncol, nlev, top_lev, t, pmid, h2ommr, cldn, & + nswbands, nlwbands, crefwsw, crefwlw) case ('hygroscopic_coreshell') aero_optics => hygrocoreshell_aerosol_optics(aeroprops, aerostate, & ibin, ncol, nlev, relh) @@ -111,7 +118,8 @@ end function create_aerosol_optics_object subroutine aerosol_optics_sw_bin(aeroprops, aerostate, ibin, & ncol, nlev, top_lev, nswbands, nlwbands, numrh, & idx_sw_diag, & - relh, sulfwtpct, mass, crefwsw, crefwlw, & + relh, sulfwtpct, t, pmid, h2ommr, cldn, & + mass, crefwsw, crefwlw, & geometric_radius, & tau_bin, ssa_bin, asm_bin, & pabs_vis, dopaer0_vis, & @@ -131,6 +139,10 @@ subroutine aerosol_optics_sw_bin(aeroprops, aerostate, ibin, & integer, intent(in) :: idx_sw_diag real(r8), intent(in) :: relh(:, :) real(r8), intent(in) :: sulfwtpct(:, :) + real(r8), intent(in) :: t(:, :) ! temperature (K) + real(r8), intent(in) :: pmid(:, :) ! layer pressure (Pa) + real(r8), intent(in) :: h2ommr(:, :) ! specific humidity (kg/kg) + real(r8), intent(in) :: cldn(:, :) ! layer cloud fraction (0-1) real(r8), intent(in) :: mass(:, :) ! layer mass (pdeldry*rga) complex(r8), intent(in) :: crefwsw(:) complex(r8), intent(in) :: crefwlw(:) @@ -181,8 +193,9 @@ subroutine aerosol_optics_sw_bin(aeroprops, aerostate, ibin, & ! Create aerosol optics object aero_optics => create_aerosol_optics_object(aeroprops, aerostate, ibin, & - ncol, nlev, nswbands, nlwbands, numrh, & - relh, sulfwtpct, crefwsw, crefwlw, & + ncol, nlev, top_lev, nswbands, nlwbands, numrh, & + relh, sulfwtpct, t, pmid, h2ommr, cldn, & + crefwsw, crefwlw, & geometric_radius) if (.not. associated(aero_optics)) then @@ -226,8 +239,10 @@ subroutine aerosol_optics_sw_bin(aeroprops, aerostate, ibin, & ! extinction compared with spherical coarse-mode dust. ! ref: Fig. 1d of Jasper F. Kok et al. (2017) if (coarse_dust_mode .and. idx_sw_diag > 0) then - wetvol(:ncol, :nlev) = aerostate%wet_volume(aeroprops, ibin, ncol, nlev) - watervol(:ncol, :nlev) = aerostate%water_volume(aeroprops, ibin, ncol, nlev) + wetvol(:ncol, :nlev) = aerostate%wet_volume(aeroprops, ibin, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) + watervol(:ncol, :nlev) = aerostate%water_volume(aeroprops, ibin, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) do ilev = top_lev, nlev scatdust(:ncol) = 0._r8 @@ -341,8 +356,9 @@ end subroutine aerosol_optics_sw_bin ! and raw specific absorption (absorp_bin) for diagnostic use. !=============================================================================== subroutine aerosol_optics_lw_bin(aeroprops, aerostate, ibin, & - ncol, nlev, nswbands, nlwbands, numrh, & - relh, sulfwtpct, mass, crefwsw, crefwlw, & + ncol, nlev, top_lev, nswbands, nlwbands, numrh, & + relh, sulfwtpct, t, pmid, h2ommr, cldn, & + mass, crefwsw, crefwlw, & geometric_radius, & tau_lw_bin, absorp_bin, & errmsg, errflg) @@ -353,12 +369,16 @@ subroutine aerosol_optics_lw_bin(aeroprops, aerostate, ibin, & class(aerosol_properties), intent(in), target :: aeroprops class(aerosol_state), intent(in), target :: aerostate integer, intent(in) :: ibin - integer, intent(in) :: ncol, nlev + integer, intent(in) :: ncol, nlev, top_lev integer, intent(in) :: nswbands integer, intent(in) :: nlwbands integer, intent(in) :: numrh real(r8), intent(in) :: relh(:, :) real(r8), intent(in) :: sulfwtpct(:, :) + real(r8), intent(in) :: t(:, :) ! temperature (K) + real(r8), intent(in) :: pmid(:, :) ! layer pressure (Pa) + real(r8), intent(in) :: h2ommr(:, :) ! specific humidity (kg/kg) + real(r8), intent(in) :: cldn(:, :) ! layer cloud fraction (0-1) real(r8), intent(in) :: mass(:, :) complex(r8), intent(in) :: crefwsw(:) complex(r8), intent(in) :: crefwlw(:) @@ -381,8 +401,9 @@ subroutine aerosol_optics_lw_bin(aeroprops, aerostate, ibin, & ! Create aerosol optics object aero_optics => create_aerosol_optics_object(aeroprops, aerostate, ibin, & - ncol, nlev, nswbands, nlwbands, numrh, & - relh, sulfwtpct, crefwsw, crefwlw, & + ncol, nlev, top_lev, nswbands, nlwbands, numrh, & + relh, sulfwtpct, t, pmid, h2ommr, cldn, & + crefwsw, crefwlw, & geometric_radius) if (.not. associated(aero_optics)) then diff --git a/src/chemistry/aerosol/aerosol_state_mod.F90 b/src/chemistry/aerosol/aerosol_state_mod.F90 index 2242717cd8..937a2edc9e 100644 --- a/src/chemistry/aerosol/aerosol_state_mod.F90 +++ b/src/chemistry/aerosol/aerosol_state_mod.F90 @@ -59,8 +59,8 @@ module aerosol_state_mod procedure :: refractive_index_sw procedure :: refractive_index_lw procedure(aero_volume), deferred :: dry_volume - procedure(aero_volume), deferred :: wet_volume - procedure(aero_volume), deferred :: water_volume + procedure(aero_wet_volume), deferred :: wet_volume + procedure(aero_wet_volume), deferred :: water_volume procedure(aero_wet_diam), deferred :: wet_diameter procedure :: convcld_actfrac procedure :: sol_factb_interstitial @@ -230,7 +230,8 @@ end subroutine aero_hygroscopicity ! returns aerosol wet diameter and aerosol water concentration for a given ! radiation diagnostic list number and bin number !------------------------------------------------------------------------------ - subroutine aero_water_uptake(self, aero_props, bin_idx, ncol, nlev, dgnumwet, qaerwat) + subroutine aero_water_uptake(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn, dgnumwet, qaerwat) import :: aerosol_state, aerosol_properties, r8 class(aerosol_state), intent(in) :: self @@ -238,6 +239,11 @@ subroutine aero_water_uptake(self, aero_props, bin_idx, ncol, nlev, dgnumwet, qa integer, intent(in) :: bin_idx ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) real(r8),intent(out) :: dgnumwet(ncol,nlev) ! aerosol wet diameter (m) real(r8),intent(out) :: qaerwat(ncol,nlev) ! aerosol water concentration (g/g) @@ -270,6 +276,29 @@ function aero_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) end function aero_volume + !------------------------------------------------------------------------------ + ! aerosol wet/water volume interface -- carries the atmospheric state + ! needed to recompute water uptake for diagnostic radiation lists + !------------------------------------------------------------------------------ + function aero_wet_volume(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) result(vol) + import :: aerosol_state, aerosol_properties, r8 + + class(aerosol_state), intent(in) :: self + class(aerosol_properties), intent(in) :: aero_props + integer, intent(in) :: bin_idx ! bin number + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) + + real(r8) :: vol(ncol,nlev) ! m3/kg + + end function aero_wet_volume + !------------------------------------------------------------------------------ ! aerosol wet diameter !------------------------------------------------------------------------------ diff --git a/src/chemistry/aerosol/bulk_aerosol_state_mod.F90 b/src/chemistry/aerosol/bulk_aerosol_state_mod.F90 index 2c884c521e..34722a4031 100644 --- a/src/chemistry/aerosol/bulk_aerosol_state_mod.F90 +++ b/src/chemistry/aerosol/bulk_aerosol_state_mod.F90 @@ -378,13 +378,19 @@ end subroutine hygroscopicity ! returns aerosol wet diameter and aerosol water concentration for a given ! radiation diagnostic list number and bin number !------------------------------------------------------------------------------ - subroutine water_uptake(self, aero_props, bin_idx, ncol, nlev, dgnumwet, qaerwat) + subroutine water_uptake(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn, dgnumwet, qaerwat) class(bulk_aerosol_state), intent(in) :: self class(aerosol_properties), intent(in) :: aero_props integer, intent(in) :: bin_idx ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) real(r8),intent(out) :: dgnumwet(ncol,nlev) ! aerosol wet diameter (m) real(r8),intent(out) :: qaerwat(ncol,nlev) ! aerosol water concentration (g/g) @@ -418,7 +424,8 @@ end function dry_volume !------------------------------------------------------------------------------ ! aerosol wet volume (m3/kg) for given radiation diagnostic list number and bin number !------------------------------------------------------------------------------ - function wet_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) + function wet_volume(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) result(vol) class(bulk_aerosol_state), intent(in) :: self class(aerosol_properties), intent(in) :: aero_props @@ -426,18 +433,25 @@ function wet_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) integer, intent(in) :: bin_idx ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) real(r8) :: vol(ncol,nlev) ! m3/kg vol = self%dry_volume(aero_props, bin_idx, ncol, nlev) & - + self%water_volume(aero_props, bin_idx, ncol, nlev) + + self%water_volume(aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) end function wet_volume !------------------------------------------------------------------------------ ! aerosol water volume (m3/kg) for given radiation diagnostic list number and bin number !------------------------------------------------------------------------------ - function water_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) + function water_volume(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) result(vol) class(bulk_aerosol_state), intent(in) :: self class(aerosol_properties), intent(in) :: aero_props @@ -445,6 +459,11 @@ function water_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) integer, intent(in) :: bin_idx ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) real(r8) :: vol(ncol,nlev) ! m3/kg diff --git a/src/chemistry/aerosol/carma_aerosol_state_mod.F90 b/src/chemistry/aerosol/carma_aerosol_state_mod.F90 index 0f2ec81c57..68d5590f77 100644 --- a/src/chemistry/aerosol/carma_aerosol_state_mod.F90 +++ b/src/chemistry/aerosol/carma_aerosol_state_mod.F90 @@ -426,13 +426,19 @@ end subroutine hygroscopicity ! returns aerosol wet diameter and aerosol water concentration for a given ! radiation diagnostic list number and bin number !------------------------------------------------------------------------------ - subroutine water_uptake(self, aero_props, bin_idx, ncol, nlev, dgnumwet, qaerwat) + subroutine water_uptake(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn, dgnumwet, qaerwat) class(carma_aerosol_state), intent(in) :: self class(aerosol_properties), intent(in) :: aero_props integer, intent(in) :: bin_idx ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) real(r8),intent(out) :: dgnumwet(ncol,nlev) ! aerosol wet diameter (m) real(r8),intent(out) :: qaerwat(ncol,nlev) ! aerosol water concentration (g/g) @@ -495,7 +501,8 @@ end function dry_volume !------------------------------------------------------------------------------ ! aerosol wet volume (m3/kg) for given radiation diagnostic list number and bin number !------------------------------------------------------------------------------ - function wet_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) + function wet_volume(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) result(vol) class(carma_aerosol_state), intent(in) :: self class(aerosol_properties), intent(in) :: aero_props @@ -503,6 +510,11 @@ function wet_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) integer, intent(in) :: bin_idx ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) real(r8) :: vol(ncol,nlev) ! m3/kg @@ -534,7 +546,8 @@ end function wet_volume !------------------------------------------------------------------------------ ! aerosol water volume (m3/kg) for given radiation diagnostic list number and bin number !------------------------------------------------------------------------------ - function water_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) + function water_volume(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) result(vol) class(carma_aerosol_state), intent(in) :: self class(aerosol_properties), intent(in) :: aero_props @@ -542,13 +555,19 @@ function water_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) integer, intent(in) :: bin_idx ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) real(r8) :: vol(ncol,nlev) ! m3/kg real(r8) :: wetvol(ncol,nlev) real(r8) :: dryvol(ncol,nlev) - wetvol = self%wet_volume(aero_props, bin_idx, ncol, nlev) + wetvol = self%wet_volume(aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) dryvol = self%dry_volume(aero_props, bin_idx, ncol, nlev) vol(:ncol,:) = wetvol(:ncol,:) - dryvol(:ncol,:) diff --git a/src/chemistry/aerosol/cldaero_mod.F90 b/src/chemistry/aerosol/cldaero_mod.F90 index c199093efb..ca81dc94ed 100644 --- a/src/chemistry/aerosol/cldaero_mod.F90 +++ b/src/chemistry/aerosol/cldaero_mod.F90 @@ -2,11 +2,13 @@ ! low level utility module for cloud aerosols ! ! Created by Francis Vitt +! +! Portable (CCPP-ready): array sizes are runtime arguments and host constants +! are passed in; no CAM infrastructure dependencies. !---------------------------------------------------------------------------------- module cldaero_mod use shr_kind_mod, only : r8 => shr_kind_r8 - use ppgrid, only : pcols, pver implicit none private @@ -28,14 +30,17 @@ module cldaero_mod !---------------------------------------------------------------------------------- !---------------------------------------------------------------------------------- - function cldaero_allocate( ) result( cldconc ) + function cldaero_allocate( ncol, pver ) result( cldconc ) + integer, intent(in) :: ncol ! number of columns in chunk + integer, intent(in) :: pver ! number of vertical levels + type(cldaero_conc_t), pointer:: cldconc allocate( cldconc ) - allocate( cldconc%so4c(pcols,pver) ) - allocate( cldconc%nh4c(pcols,pver) ) - allocate( cldconc%no3c(pcols,pver) ) - allocate( cldconc%xlwc(pcols,pver) ) + allocate( cldconc%so4c(ncol,pver) ) + allocate( cldconc%nh4c(ncol,pver) ) + allocate( cldconc%no3c(ncol,pver) ) + allocate( cldconc%xlwc(ncol,pver) ) cldconc%so4c(:,:) = 0._r8 cldconc%nh4c(:,:) = 0._r8 @@ -79,10 +84,10 @@ end subroutine cldaero_deallocate ! utility function for cloud-borne aerosols !---------------------------------------------------------------------------------- - function cldaero_uptakerate( xl, cldnum, cfact, cldfrc, tfld, press ) result( uptkrate ) - use mo_constants, only : pi + function cldaero_uptakerate( xl, cldnum, cfact, cldfrc, tfld, press, pi ) result( uptkrate ) real(r8), intent(in) :: xl, cldnum, cfact, cldfrc, tfld, press + real(r8), intent(in) :: pi ! host value of pi (passed for bit-for-bit consistency) real(r8) :: uptkrate diff --git a/src/chemistry/aerosol/dust_common.F90 b/src/chemistry/aerosol/dust_common.F90 index b5469f6bd5..8ffbdb5e0f 100644 --- a/src/chemistry/aerosol/dust_common.F90 +++ b/src/chemistry/aerosol/dust_common.F90 @@ -1,17 +1,21 @@ !============================================================================= ! Common dust module +! Portable: host constants are passed as arguments; errors are reported +! through errmsg/errflg for the caller to handle. !============================================================================= module dust_common - use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl - use cam_abortutils, only: endrun - use cam_logfile, only: iulog + use shr_kind_mod, only: r8 => shr_kind_r8 implicit none private public :: dust_set_params + ! Dust aerosol material density used by the emissions number/mass flux + ! conversion and the settling parameters below (value from CAM mo_constants). + real(r8), public, parameter :: dust_density = 2.5e+3_r8 ! [kg m-3] + contains !============================================================================= @@ -27,14 +31,12 @@ module dust_common ! Modifications by C. Zender and later by S. Levis ! Rest of subroutine from C. Zender's dust model !============================================================================= - subroutine dust_set_params( nbin, dmt_grd, dmt_vwr, stk_crc ) + subroutine dust_set_params( nbin, dmt_grd, dmt_vwr, stk_crc, pi, rair, gravit, errmsg, errflg ) ! ! !USES ! - use physconst, only: pi,rair, gravit - use mo_constants, only: dust_density - use infnan, only: nan, assignment(=) + use shr_infnan_mod, only: nan => shr_infnan_nan, assignment(=) ! ! !ARGUMENTS: @@ -43,6 +45,11 @@ subroutine dust_set_params( nbin, dmt_grd, dmt_vwr, stk_crc ) real(r8),intent(in) :: dmt_grd(:) real(r8),intent(out) :: dmt_vwr(:) real(r8),intent(out) :: stk_crc(:) + real(r8),intent(in) :: pi ! host model constants + real(r8),intent(in) :: rair ! gas constant for dry air (J/K/kg) + real(r8),intent(in) :: gravit ! gravitational acceleration (m/s2) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! ! !REVISION HISTORY @@ -88,6 +95,9 @@ subroutine dust_set_params( nbin, dmt_grd, dmt_vwr, stk_crc ) real(r8) :: sz_ctr(sz_nbr) ![m] Size Bin centers real(r8) :: sz_dlt(sz_nbr) ![m] Size Bin widths + errmsg = '' + errflg = 0 + stk_crc(:) = nan dmt_vwr(:) = nan @@ -218,8 +228,10 @@ subroutine dust_set_params( nbin, dmt_grd, dmt_vwr, stk_crc ) else if (ryn_nbr_grv(m) < 2.0e5_r8) then cff_drg_grv(m) = 0.44_r8 !Sep97 p.463 (8.32) else - write(iulog,'(a,es9.2)') "ryn_nbr_grv(m) = ",ryn_nbr_grv(m) - call endrun ('Dustini error: Reynolds number too large in stk_crc_get()') + write(errmsg,'(a,es9.2)') & + 'Dustini error: Reynolds number too large in stk_crc_get(): ryn_nbr_grv(m) = ', ryn_nbr_grv(m) + errflg = 1 + return endif ! Update terminal velocity based on new Reynolds number and drag coeff @@ -233,9 +245,8 @@ subroutine dust_set_params( nbin, dmt_grd, dmt_vwr, stk_crc ) vlc_grv(m) = 0.5_r8 * (vlc_grv(m)+vlc_grv_old) ! [m s-1] endif if (itr_idx > 20) then - write(iulog,*) 'Dustini error: Terminal velocity not converging ',& - ' in stk_crc_get(), breaking loop...' - ! to next iteration + ! Dustini error: terminal velocity not converging in stk_crc_get(); + ! break the loop and accept the current value (was an iulog warning) exit eps_loop endif itr_idx = itr_idx + 1 diff --git a/src/chemistry/aerosol/dust_sediment_mod.F90 b/src/chemistry/aerosol/dust_sediment_mod.F90 index 96306a61e3..3963035b61 100644 --- a/src/chemistry/aerosol/dust_sediment_mod.F90 +++ b/src/chemistry/aerosol/dust_sediment_mod.F90 @@ -10,82 +10,23 @@ module dust_sediment_mod !--------------------------------------------------------------------------------- use shr_kind_mod, only: r8=>shr_kind_r8 - use ppgrid, only: pcols, pver, pverp - use physconst, only: gravit, rair - use cam_logfile, only: iulog - use cam_abortutils, only: endrun private - public :: dust_sediment_vel, dust_sediment_tend + public :: dust_sediment_tend - real (r8), parameter :: vland = 2.8_r8 ! dust fall velocity over land (cm/s) - real (r8), parameter :: vocean = 1.5_r8 ! dust fall velocity over ocean (cm/s) real (r8), parameter :: mxsedfac = 0.99_r8 ! maximum sedimentation flux factor contains -!=============================================================================== - subroutine dust_sediment_vel (ncol, & - icefrac , landfrac, ocnfrac , pmid , pdel , t , & - dustmr , pvdust ) - -!---------------------------------------------------------------------- - -! Compute gravitational sedimentation velocities for dust - - implicit none - -! Arguments - integer, intent(in) :: ncol ! number of colums to process - - real(r8), intent(in) :: icefrac (pcols) ! sea ice fraction (fraction) - real(r8), intent(in) :: landfrac(pcols) ! land fraction (fraction) - real(r8), intent(in) :: ocnfrac (pcols) ! ocean fraction (fraction) - real(r8), intent(in) :: pmid (pcols,pver) ! pressure of midpoint levels (Pa) - real(r8), intent(in) :: pdel (pcols,pver) ! pressure diff across layer (Pa) - real(r8), intent(in) :: t (pcols,pver) ! temperature (K) - real(r8), intent(in) :: dustmr(pcols,pver) ! dust (kg/kg) - - real(r8), intent(out) :: pvdust (pcols,pverp) ! vertical velocity of dust (Pa/s) -! -> note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) - -! Local variables - real (r8) :: rho(pcols,pver) ! air density in kg/m3 - real (r8) :: vfall(pcols) ! settling velocity of dust particles (m/s) - - integer i,k - - real (r8) :: lbound, ac, bc, cc - -!----------------------------------------------------------------------- -!--------------------- dust fall velocity ---------------------------- -!----------------------------------------------------------------------- - - do k = 1,pver - do i = 1,ncol - - ! merge the dust fall velocities for land and ocean (cm/s) - ! SHOULD ALSO ACCOUNT FOR ICEFRAC - vfall(i) = vland*landfrac(i) + vocean*(1._r8-landfrac(i)) - !! vfall(i) = vland*landfrac(i) + vocean*ocnfrac(i) + vseaice*icefrac(i) - - ! fall velocity (assume positive downward) - pvdust(i,k+1) = vfall(i) - end do - end do - - return - end subroutine dust_sediment_vel - - !=============================================================================== subroutine dust_sediment_tend ( & - ncol, dtime, pint, pmid, pdel, t, & - dustmr ,pvdust, dusttend, sfdust ) + ncol, dtime, pint, pdel, & + dustmr ,pvdust, dusttend, sfdust, & + pver, gravit, errmsg, errflg ) !---------------------------------------------------------------------- -! Apply Particle Gravitational Sedimentation +! Apply Particle Gravitational Sedimentation !---------------------------------------------------------------------- implicit none @@ -94,36 +35,43 @@ subroutine dust_sediment_tend ( & integer, intent(in) :: ncol ! number of colums to process real(r8), intent(in) :: dtime ! time step - real(r8), intent(in) :: pint (pcols,pverp) ! interfaces pressure (Pa) - real(r8), intent(in) :: pmid (pcols,pver) ! midpoint pressures (Pa) - real(r8), intent(in) :: pdel (pcols,pver) ! pressure diff across layer (Pa) - real(r8), intent(in) :: t (pcols,pver) ! temperature (K) - real(r8), intent(in) :: dustmr(pcols,pver) ! dust (kg/kg) - real(r8), intent(in) :: pvdust (pcols,pverp) ! vertical velocity of dust drops (Pa/s) + real(r8), intent(in) :: pint (:,:) ! interfaces pressure (Pa) + real(r8), intent(in) :: pdel (:,:) ! pressure diff across layer (Pa) + real(r8), intent(in) :: dustmr(:,:) ! dust (kg/kg) + real(r8), intent(in) :: pvdust (:,:) ! vertical velocity of dust drops (Pa/s) ! -> note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) - real(r8), intent(out) :: dusttend(pcols,pver) ! dust tend - real(r8), intent(out) :: sfdust (pcols) ! surface flux of dust (rain, kg/m/s) + real(r8), intent(out) :: dusttend(:,:) ! dust tend + real(r8), intent(out) :: sfdust (:) ! surface flux of dust (rain, kg/m/s) + + integer, intent(in) :: pver ! number of vertical levels + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! Local variables - real(r8) :: fxdust(pcols,pverp) ! fluxes at the interfaces, dust (positive = down) + real(r8) :: fxdust(ncol,pver+1) ! fluxes at the interfaces, dust (positive = down) integer :: i,k !---------------------------------------------------------------------- + errmsg = '' + errflg = 0 + ! initialize variables fxdust (:ncol,:) = 0._r8 ! flux at interfaces (dust) dusttend(:ncol,:) = 0._r8 ! tend (dust) sfdust(:ncol) = 0._r8 ! sedimentation flux out bot of column (dust) ! fluxes at interior points - call getflx(ncol, pint, dustmr, pvdust, dtime, fxdust) + call getflx(ncol, pint, dustmr, pvdust, dtime, fxdust, pver, errmsg, errflg) + if (errflg /= 0) return ! calculate fluxes at boundaries do i = 1,ncol fxdust(i,1) = 0 ! surface flux by upstream scheme - fxdust(i,pverp) = dustmr(i,pver) * pvdust(i,pverp) * dtime + fxdust(i,pver+1) = dustmr(i,pver) * pvdust(i,pver+1) * dtime end do ! filter out any negative fluxes from the getflx routine @@ -152,13 +100,13 @@ subroutine dust_sediment_tend ( & end do ! convert flux out the bottom to mass units Pa -> kg/m2/s - sfdust(:ncol) = fxdust(:ncol,pverp) / (dtime*gravit) + sfdust(:ncol) = fxdust(:ncol,pver+1) / (dtime*gravit) return end subroutine dust_sediment_tend !=============================================================================== - subroutine getflx(ncol, xw, phi, vel, deltat, flux) + subroutine getflx(ncol, xw, phi, vel, deltat, flux, pver, errmsg, errflg) !.....xw1.......xw2.......xw3.......xw4.......xw5.......xw6 !....psiw1.....psiw2.....psiw3.....psiw4.....psiw5.....psiw6 @@ -173,31 +121,39 @@ subroutine getflx(ncol, xw, phi, vel, deltat, flux) integer i integer k - real (r8) vel(pcols,pverp) - real (r8) flux(pcols,pverp) - real (r8) xw(pcols,pverp) - real (r8) psi(pcols,pverp) - real (r8) phi(pcols,pverp-1) - real (r8) fdot(pcols,pverp) - real (r8) xx(pcols) - real (r8) fxdot(pcols) - real (r8) fxdd(pcols) - - real (r8) psistar(pcols) + real (r8) vel(:,:) + real (r8) flux(:,:) + real (r8) xw(:,:) + real (r8) phi(:,:) real (r8) deltat - real (r8) xxk(pcols,pver) + integer, intent(in) :: pver ! number of vertical levels + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real (r8) psi(ncol,pver+1) + real (r8) fdot(ncol,pver+1) + real (r8) xx(ncol) + real (r8) fxdot(ncol) + real (r8) fxdd(ncol) + + real (r8) psistar(ncol) + + real (r8) xxk(ncol,pver) + + errmsg = '' + errflg = 0 do i = 1,ncol ! integral of phi psi(i,1) = 0._r8 ! fluxes at boundaries flux(i,1) = 0 - flux(i,pverp) = 0._r8 + flux(i,pver+1) = 0._r8 end do ! integral function - do k = 2,pverp + do k = 2,pver+1 do i = 1,ncol psi(i,k) = phi(i,k-1)*(xw(i,k)-xw(i,k-1)) + psi(i,k-1) end do @@ -205,7 +161,7 @@ subroutine getflx(ncol, xw, phi, vel, deltat, flux) ! calculate the derivatives for the interpolating polynomial - call cfdotmc_pro (ncol, xw, psi, fdot) + call cfdotmc_pro (ncol, xw, psi, fdot, pver) ! NEW WAY ! calculate fluxes at interior pts @@ -215,7 +171,8 @@ subroutine getflx(ncol, xw, phi, vel, deltat, flux) end do end do do k = 2,pver - call cfint2(ncol, xw, psi, fdot, xxk(1,k), fxdot, fxdd, psistar) + call cfint2(ncol, xw, psi, fdot, xxk(:,k), fxdot, fxdd, psistar, pver, errmsg, errflg) + if (errflg /= 0) return do i = 1,ncol flux(i,k) = (psi(i,k)-psistar(i)) end do @@ -229,7 +186,7 @@ end subroutine getflx !############################################################################## - subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar) + subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar, pver, errmsg, errflg) implicit none @@ -237,19 +194,24 @@ subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar) ! input integer ncol ! number of colums to process - real (r8) x(pcols, pverp) - real (r8) f(pcols, pverp) - real (r8) fdot(pcols, pverp) - real (r8) xin(pcols) + real (r8) x(:,:) + real (r8) f(:,:) + real (r8) fdot(:,:) + real (r8) xin(:) + + integer, intent(in) :: pver ! number of vertical levels ! output - real (r8) fxdot(pcols) - real (r8) fxdd(pcols) - real (r8) psistar(pcols) + real (r8) fxdot(:) + real (r8) fxdd(:) + real (r8) psistar(:) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg integer i integer k - integer intz(pcols) + integer intz(ncol) real (r8) dx real (r8) s real (r8) c2 @@ -259,7 +221,7 @@ subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar) real (r8) psi1, psi2, psi3, psim real (r8) cfint real (r8) cfnew - real (r8) xins(pcols) + real (r8) xins(ncol) ! the minmod function real (r8) a, b, c @@ -268,13 +230,16 @@ subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar) minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) medan(a,b,c) = a + minmod(b-a,c-a) + errmsg = '' + errflg = 0 + do i = 1,ncol - xins(i) = medan(x(i,1), xin(i), x(i,pverp)) + xins(i) = medan(x(i,1), xin(i), x(i,pver+1)) intz(i) = 0 end do -! first find the interval - do k = 1,pverp-1 +! first find the interval + do k = 1,pver do i = 1,ncol if ((xins(i)-x(i,k))*(x(i,k+1)-xins(i)).ge.0._r8) then intz(i) = k @@ -284,8 +249,9 @@ subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar) do i = 1,ncol if (intz(i).eq.0) then - write(iulog,*) ' interval was not found for col i ', i - call endrun('DUST_SEDIMENT_MOD:cfint2 -- interval was not found ') + write(errmsg,*) 'DUST_SEDIMENT_MOD:cfint2 -- interval was not found for col i ', i + errflg = 1 + return endif end do @@ -308,8 +274,8 @@ subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar) else psi2 = f(i,k) + (f(i,k)-f(i,k-1))*xx/(x(i,k)-x(i,k-1)) endif - if (k+1.eq.pverp) then - psi3 = f(i,pverp) + if (k+1.eq.pver+1) then + psi3 = f(i,pver+1) else psi3 = f(i,k+1) - (f(i,k+2)-f(i,k+1))*(dx-xx)/(x(i,k+2)-x(i,k+1)) endif @@ -335,7 +301,7 @@ end subroutine cfint2 !############################################################################## - subroutine cfdotmc_pro (ncol, x, f, fdot) + subroutine cfdotmc_pro (ncol, x, f, fdot, pver) ! prototype version; eventually replace with final SPITFIRE scheme @@ -348,10 +314,11 @@ subroutine cfdotmc_pro (ncol, x, f, fdot) ! input integer ncol ! number of colums to process - real (r8) x(pcols, pverp) - real (r8) f(pcols, pverp) + real (r8) x(:,:) + real (r8) f(:,:) + integer, intent(in) :: pver ! number of vertical levels ! output - real (r8) fdot(pcols, pverp) ! derivative at nodes + real (r8) fdot(:,:) ! derivative at nodes ! assumed variable distribution ! x1.......x2.......x3.......x4.......x5.......x6 1,pverp points @@ -377,22 +344,22 @@ subroutine cfdotmc_pro (ncol, x, f, fdot) real (r8) a ! work var real (r8) b ! work var real (r8) c ! work var - real (r8) s(pcols,pverp) ! first divided differences at nodes - real (r8) sh(pcols,pverp) ! first divided differences between nodes - real (r8) d(pcols,pverp) ! second divided differences at nodes - real (r8) dh(pcols,pverp) ! second divided differences between nodes - real (r8) e(pcols,pverp) ! third divided differences at nodes - real (r8) eh(pcols,pverp) ! third divided differences between nodes + real (r8) s(ncol,pver+1) ! first divided differences at nodes + real (r8) sh(ncol,pver+1) ! first divided differences between nodes + real (r8) d(ncol,pver+1) ! second divided differences at nodes + real (r8) dh(ncol,pver+1) ! second divided differences between nodes + real (r8) e(ncol,pver+1) ! third divided differences at nodes + real (r8) eh(ncol,pver+1) ! third divided differences between nodes real (r8) pp ! p prime - real (r8) ppl(pcols,pverp) ! p prime on left - real (r8) ppr(pcols,pverp) ! p prime on right + real (r8) ppl(ncol,pver+1) ! p prime on left + real (r8) ppr(ncol,pver+1) ! p prime on right real (r8) qpl real (r8) qpr real (r8) ttt real (r8) t real (r8) tmin real (r8) tmax - real (r8) delxh(pcols,pverp) + real (r8) delxh(ncol,pver+1) ! the minmod function @@ -435,9 +402,9 @@ subroutine cfdotmc_pro (ncol, x, f, fdot) fdot(i,1) = sh(i,1) - d(i,2)*delxh(i,1) & - eh(i,2)*delxh(i,1)*(x(i,1)-x(i,3)) fdot(i,1) = minmod(fdot(i,1),3*sh(i,1)) - fdot(i,pverp) = sh(i,pver) + d(i,pver)*delxh(i,pver) & - + eh(i,pver-1)*delxh(i,pver)*(x(i,pverp)-x(i,pver-1)) - fdot(i,pverp) = minmod(fdot(i,pverp),3*sh(i,pver)) + fdot(i,pver+1) = sh(i,pver) + d(i,pver)*delxh(i,pver) & + + eh(i,pver-1)*delxh(i,pver)*(x(i,pver+1)-x(i,pver-1)) + fdot(i,pver+1) = minmod(fdot(i,pver+1),3*sh(i,pver)) ! one in from boundary fdot(i,2) = sh(i,1) + d(i,2)*delxh(i,1) - eh(i,2)*delxh(i,1)*delxh(i,2) fdot(i,2) = minmod(fdot(i,2),3*s(i,2)) diff --git a/src/chemistry/aerosol/mo_setsox.F90 b/src/chemistry/aerosol/mo_setsox.F90 index 1b1a83fa63..dc86fa76e3 100644 --- a/src/chemistry/aerosol/mo_setsox.F90 +++ b/src/chemistry/aerosol/mo_setsox.F90 @@ -1,15 +1,18 @@ module mo_setsox + ! Portable (CCPP-ready) aqueous sulfur chemistry (setsox). + ! Species indices / invariant flags, the Henry's Law table indices and the + ! host physical constants are provided by the host through setsox_init / + ! setsox_sub arguments (CAM wrapper: mo_setsox_cam). The polymorphic + ! aerosol_state abstraction is deliberately host-portable. + use shr_kind_mod, only : r8 => shr_kind_r8 - use cam_logfile, only : iulog - use physics_types,only : physics_state use aerosol_state_mod, only: aerosol_state implicit none private - public :: sox_inti, setsox - public :: has_sox + public :: setsox_init, setsox_sub logical :: inv_o3 integer :: id_msa @@ -17,7 +20,6 @@ module mo_setsox integer :: id_so2, id_nh3, id_hno3, id_h2o2, id_o3, id_ho2 integer :: id_so4, id_h2so4 - logical :: has_sox = .true. logical :: inv_so2, inv_nh3, inv_hno3, inv_h2o2, inv_ho2 logical :: cloud_borne = .false. @@ -29,132 +31,76 @@ module mo_setsox !----------------------------------------------------------------------- !----------------------------------------------------------------------- - subroutine sox_inti(aero_props) + subroutine setsox_init( cloud_borne_in, & + id_so2_in, inv_so2_in, & + id_nh3_in, inv_nh3_in, & + id_hno3_in, inv_hno3_in, & + id_h2o2_in, inv_h2o2_in, & + id_ho2_in, inv_ho2_in, & + id_o3_in, inv_o3_in, & + id_h2so4_in, id_so4_in, id_msa_in, & + heff_id_hno3_in, heff_id_so2_in, heff_id_nh3_in, & + heff_id_co2_in, heff_id_h2o2_in, heff_id_o3_in ) !----------------------------------------------------------------------- ! ... initialize the hetero sox routine + ! + ! Store the species indices / invariant flags and the Henry's Law + ! constant table indices resolved by the host (CAM: sox_inti in + ! mo_setsox_cam). An id <= 0 marks the species as absent. !----------------------------------------------------------------------- - use mo_chem_utls, only : get_spc_ndx, get_inv_ndx - use spmd_utils, only : masterproc - use phys_control, only : phys_getopts - use carma_flags_mod, only : carma_do_cloudborne - use sox_cldaero_mod, only : sox_cldaero_init - use aerosol_properties_mod, only : aerosol_properties - - class(aerosol_properties), target, intent(in) :: aero_props - - logical :: modal_aerosols - - call phys_getopts( prog_modal_aero_out=modal_aerosols ) - cloud_borne = modal_aerosols .or. carma_do_cloudborne - - !----------------------------------------------------------------- - ! ... get species indicies - !----------------------------------------------------------------- - - if (cloud_borne) then - id_h2so4 = get_spc_ndx( 'H2SO4' ) - else - id_so4 = get_spc_ndx( 'SO4' ) - endif - id_msa = get_spc_ndx( 'MSA' ) - - inv_so2 = .false. - id_so2 = get_inv_ndx( 'SO2' ) - inv_so2 = id_so2 > 0 - if ( .not. inv_so2 ) then - id_so2 = get_spc_ndx( 'SO2' ) - endif - - inv_NH3 = .false. - id_NH3 = get_inv_ndx( 'NH3' ) - inv_NH3 = id_NH3 > 0 - if ( .not. inv_NH3 ) then - id_NH3 = get_spc_ndx( 'NH3' ) - endif - - inv_HNO3 = .false. - id_HNO3 = get_inv_ndx( 'HNO3' ) - inv_HNO3 = id_hno3 > 0 - if ( .not. inv_HNO3 ) then - id_HNO3 = get_spc_ndx( 'HNO3' ) - endif - - inv_H2O2 = .false. - id_H2O2 = get_inv_ndx( 'H2O2' ) - inv_H2O2 = id_H2O2 > 0 - if ( .not. inv_H2O2 ) then - id_H2O2 = get_spc_ndx( 'H2O2' ) - endif - - inv_HO2 = .false. - id_HO2 = get_inv_ndx( 'HO2' ) - inv_HO2 = id_HO2 > 0 - if ( .not. inv_HO2 ) then - id_HO2 = get_spc_ndx( 'HO2' ) - endif - - inv_o3 = get_inv_ndx( 'O3' ) > 0 - if (inv_o3) then - id_o3 = get_inv_ndx( 'O3' ) - else - id_o3 = get_spc_ndx( 'O3' ) - endif - inv_ho2 = get_inv_ndx( 'HO2' ) > 0 - if (inv_ho2) then - id_ho2 = get_inv_ndx( 'HO2' ) - else - id_ho2 = get_spc_ndx( 'HO2' ) - endif - - has_sox = (id_so2>0) .and. (id_h2o2>0) .and. (id_o3>0) .and. (id_ho2>0) - if (cloud_borne) then - has_sox = has_sox .and. (id_h2so4>0) - else - has_sox = has_sox .and. (id_so4>0) .and. (id_nh3>0) - endif - - ! Lookup Effective Henry's Law Constant parameters from the common - ! data file read in the shared code. - heff_id_hno3 = get_heff_index( 'HNO3' ) - heff_id_so2 = get_heff_index( 'SO2' ) - heff_id_nh3 = get_heff_index( 'NH3' ) - heff_id_co2 = get_heff_index( 'CO2' ) - heff_id_h2o2 = get_heff_index( 'H2O2' ) - heff_id_o3 = get_heff_index( 'OX' ) - - has_sox = has_sox .and. (heff_id_hno3 > 0) .and. (heff_id_so2 > 0) & - .and. (heff_id_nh3 > 0) .and. (heff_id_co2 > 0) & - .and. (heff_id_h2o2 > 0) .and. (heff_id_o3 > 0) - - if (masterproc) then - write(iulog,*) 'sox_inti: has_sox = ',has_sox - endif - - if( has_sox ) then - if (masterproc) then - write(iulog,*) '-----------------------------------------' - write(iulog,*) ' mo_setsox will do sox aerosols' - write(iulog,*) '-----------------------------------------' - endif - else - if (masterproc) then - write(iulog,*) '-----------------------------------------' - write(iulog,*) ' mo_setsox will not do sox aerosols' - write(iulog,*) '-----------------------------------------' - endif - return - end if - - call sox_cldaero_init(aero_props) - - end subroutine sox_inti + logical, intent(in) :: cloud_borne_in ! aqueous sulfate goes to cloud-borne aerosol + integer, intent(in) :: id_so2_in ! index in invariants (if inv flag) or solution array + logical, intent(in) :: inv_so2_in ! species is an invariant + integer, intent(in) :: id_nh3_in + logical, intent(in) :: inv_nh3_in + integer, intent(in) :: id_hno3_in + logical, intent(in) :: inv_hno3_in + integer, intent(in) :: id_h2o2_in + logical, intent(in) :: inv_h2o2_in + integer, intent(in) :: id_ho2_in + logical, intent(in) :: inv_ho2_in + integer, intent(in) :: id_o3_in + logical, intent(in) :: inv_o3_in + integer, intent(in) :: id_h2so4_in ! used when cloud_borne_in + integer, intent(in) :: id_so4_in ! used when .not. cloud_borne_in + integer, intent(in) :: id_msa_in + ! indices into the shared array of Henry's Law constant parameters (dheff) + integer, intent(in) :: heff_id_hno3_in, heff_id_so2_in, heff_id_nh3_in + integer, intent(in) :: heff_id_co2_in, heff_id_h2o2_in, heff_id_o3_in + + cloud_borne = cloud_borne_in + + id_so2 = id_so2_in + inv_so2 = inv_so2_in + id_nh3 = id_nh3_in + inv_nh3 = inv_nh3_in + id_hno3 = id_hno3_in + inv_hno3 = inv_hno3_in + id_h2o2 = id_h2o2_in + inv_h2o2 = inv_h2o2_in + id_ho2 = id_ho2_in + inv_ho2 = inv_ho2_in + id_o3 = id_o3_in + inv_o3 = inv_o3_in + id_h2so4 = id_h2so4_in + id_so4 = id_so4_in + id_msa = id_msa_in + + heff_id_hno3 = heff_id_hno3_in + heff_id_so2 = heff_id_so2_in + heff_id_nh3 = heff_id_nh3_in + heff_id_co2 = heff_id_co2_in + heff_id_h2o2 = heff_id_h2o2_in + heff_id_o3 = heff_id_o3_in + + end subroutine setsox_init !----------------------------------------------------------------------- !----------------------------------------------------------------------- - subroutine setsox( aero_state, state, & - pbuf, & + subroutine setsox_sub( aero_state, & ncol, & + pver, & dtime, & press, & pdel, & @@ -164,6 +110,14 @@ subroutine setsox( aero_state, state, & cldfrc, & cldnum, & invariants, & + co2_mass_mixing_ratio, & + dheff, & + AVOGADRO_KMOL, & + BOLTZMANN, & + GAS_CONSTANT_KMOL, & + MOLECULAR_WEIGHT_CO2_G_MOL, & + MOLECULAR_WEIGHT_DRY_AIR_G_MOL, & + gravit, & qcw, & qin, & xphlwc, & @@ -171,6 +125,8 @@ subroutine setsox( aero_state, state, & aqh2so4,& aqso4_h2o2, & aqso4_o3, & + errmsg, & + errflg, & yph_in, & aqso4_h2o2_3d, & aqso4_o3_3d & @@ -193,29 +149,16 @@ subroutine setsox( aero_state, state, & ! NOTE: This routine assumes an Ideal Gas. !----------------------------------------------------------------------- ! - use physconst, only : AVOGADRO_KMOL => avogad, & - BOLTZMANN => boltz, & - GAS_CONSTANT_KMOL => r_universal, & - MOLECULAR_WEIGHT_CO2_G_MOL => mwco2, & - MOLECULAR_WEIGHT_DRY_AIR_G_MOL => mwdry - use ppgrid, only : pcols, pver - use chem_mods, only : gas_pcnst, nfs - use physconst, only : mwdry, gravit - use mo_constants, only : pi use sox_cldaero_mod, only : sox_cldaero_update, sox_cldaero_create_obj, sox_cldaero_destroy_obj use cldaero_mod, only : cldaero_conc_t - use shr_drydep_mod, only : dheff - use physics_buffer, only : physics_buffer_desc - use rad_constituents, only : rad_cnst_get_gas ! !----------------------------------------------------------------------- ! ... Dummy arguments !----------------------------------------------------------------------- class(aerosol_state), intent(in) :: aero_state - type(physics_state), intent(in) :: state ! Physics state variables - type(physics_buffer_desc), pointer, intent(inout) :: pbuf(:) ! Physics buffer integer, intent(in) :: ncol ! num of columns in chunk + integer, intent(in) :: pver ! num of vertical levels real(r8), intent(in) :: dtime ! time step (sec) real(r8), intent(in) :: press(:,:) ! midpoint pressure ( Pa ) real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) @@ -225,6 +168,15 @@ subroutine setsox( aero_state, state, & real(r8), target, intent(in) :: cldfrc(:,:) ! cloud fraction real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) real(r8), intent(in) :: invariants(:,:,:) + real(r8), intent(in) :: co2_mass_mixing_ratio(:,:) ! kg kg-1 (host CO2; CAM: rad_cnst_get_gas) + real(r8), intent(in) :: dheff(:,:) ! Henry's Law constant parameters table + ! host physical constants (passed in for bit-for-bit consistency with the host) + real(r8), intent(in) :: AVOGADRO_KMOL ! Avogadro's number (molecules/kmol) + real(r8), intent(in) :: BOLTZMANN ! Boltzmann's constant (J/K/molecule) + real(r8), intent(in) :: GAS_CONSTANT_KMOL ! universal gas constant (J/K/kmol) + real(r8), intent(in) :: MOLECULAR_WEIGHT_CO2_G_MOL ! molecular weight of CO2 (g/mol) + real(r8), intent(in) :: MOLECULAR_WEIGHT_DRY_AIR_G_MOL ! molecular weight of dry air (g/mol) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) real(r8), target, intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) real(r8), intent(inout) :: qin(:,:,:) ! transported species ( vmr ) real(r8), intent(out) :: xphlwc(:,:) ! pH value multiplied by lwc @@ -233,6 +185,8 @@ subroutine setsox( aero_state, state, & real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg real(r8), intent(in), optional :: yph_in ! ph value real(r8), intent(out), optional :: aqso4_h2o2_3d(:, :) ! 3D SO4 aqueous phase chemistry due to H2O2 (kg/m2) real(r8), intent(out), optional :: aqso4_o3_3d(:, :) ! 3D SO4 aqueous phase chemistry due to O3 (kg/m2) @@ -250,10 +204,11 @@ subroutine setsox( aero_state, state, & real(r8), parameter :: G_TO_KG = 1.0e-3_r8 ! kg g-1 real(r8), parameter :: KMOL_TO_MOL = 1.0e3_r8 ! mol kmol-1 real(r8), parameter :: SMALL_NUMBER = 1.0e-30_r8 - real(r8), parameter :: AVOGADRO = AVOGADRO_KMOL / KMOL_TO_MOL ! molecule mol-1 - real(r8), parameter :: const0 = 1.e3_r8/AVOGADRO + ! derived from host physical constants (assigned below; formerly parameters) + real(r8) :: AVOGADRO ! molecule mol-1 + real(r8) :: const0 real(r8) :: MOLECULAR_WEIGHT_DRY_AIR ! kg mol-1 - real(r8), parameter :: MOLECULAR_WEIGHT_CO2 = MOLECULAR_WEIGHT_CO2_G_MOL * G_TO_KG ! kg mol-1 + real(r8) :: MOLECULAR_WEIGHT_CO2 ! kg mol-1 real(r8), parameter :: xa0 = 11._r8 real(r8), parameter :: xb0 = -.1_r8 real(r8), parameter :: xa1 = 1.053_r8 @@ -267,7 +222,7 @@ subroutine setsox( aero_state, state, & real(r8), parameter :: kh1 = 1.6e-5_r8 ! HO2(a) -> H+ + O2- Reference: JPL 19-5 real(r8), parameter :: kh2 = 8.3e5_r8 ! HO2(a) + ho2(a) -> h2o2(a) + o2 Reference: JPL; Bielski et al. 1985 real(r8), parameter :: kh3 = 9.7e7_r8 ! HO2(a) + o2- -> h2o2(a) + o2 Reference: JPL; Bielski et al. 1985 - real(r8), parameter :: Ra = GAS_CONSTANT_KMOL / KMOL_TO_MOL * M3_TO_L * PASCAL_TO_ATM ! universal constant (atm)/(M-K) + real(r8) :: Ra ! universal constant (atm)/(M-K) (assigned below; formerly a parameter) real(r8), parameter :: small_value = 1.e-20_r8 ! @@ -308,8 +263,6 @@ subroutine setsox( aero_state, state, & henh3, & ! henry law const for nh3 heo3 !!, & ! henry law const for o3 - real(r8), pointer :: co2_mass_mixing_ratio(:,:) ! kg kg-1 - real(r8), dimension(ncol) :: work1 logical :: converged @@ -328,6 +281,16 @@ subroutine setsox( aero_state, state, & real(r8) :: yph, yph_lo, yph_hi real(r8) :: ynetpos, ynetpos_lo, ynetpos_hi + errmsg = '' + errflg = 0 + + ! derived host-constant values (same expressions as the original + ! parameter declarations, computed from the host-passed constants) + AVOGADRO = AVOGADRO_KMOL / KMOL_TO_MOL ! molecule mol-1 + const0 = 1.e3_r8/AVOGADRO + MOLECULAR_WEIGHT_CO2 = MOLECULAR_WEIGHT_CO2_G_MOL * G_TO_KG ! kg mol-1 + Ra = GAS_CONSTANT_KMOL / KMOL_TO_MOL * M3_TO_L * PASCAL_TO_ATM ! universal constant (atm)/(M-K) + MOLECULAR_WEIGHT_DRY_AIR = MOLECULAR_WEIGHT_DRY_AIR_G_MOL * G_TO_KG ! kg mol-1 !----------------------------------------------------------------- @@ -342,8 +305,6 @@ subroutine setsox( aero_state, state, & !----------------------------------------------------------------- xhnm(:ncol,:) = press(:ncol,:) / (tfld(:ncol,:) * M3_TO_CM3 * BOLTZMANN) ! air number density (molecules cm-3) - call rad_cnst_get_gas(0, 'CO2', state, pbuf, co2_mass_mixing_ratio) - xph0 = 10._r8**(-ph0) ! initial PH value do k = 1,pver @@ -353,7 +314,7 @@ subroutine setsox( aero_state, state, & * 1.e-3_r8 ! Kg(a)/L(a) end do - cldconc => sox_cldaero_create_obj( cldfrc,qcw,lwc, cfact, ncol ) + cldconc => sox_cldaero_create_obj( cldfrc,qcw,lwc, cfact, ncol, pver ) xso4c => cldconc%so4c xnh4c => cldconc%nh4c xno3c => cldconc%no3c @@ -885,7 +846,8 @@ subroutine setsox( aero_state, state, & if (cloud_borne) then ! update cloud-borne aerosols call sox_cldaero_update( aero_state, & - ncol, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, cldconc%xlwc, & + ncol, pver, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, cldconc%xlwc, & + gravit, & xdelso4hp, xh2so4, xso4, xso4_init, nh3g, xnh3, xnh4c, xmsa, xso2, xh2o2, qcw, qin, & aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d=aqso4_h2o2_3d, aqso4_o3_3d=aqso4_o3_3d ) else @@ -909,21 +871,6 @@ subroutine setsox( aero_state, state, & call sox_cldaero_destroy_obj(cldconc) - end subroutine setsox - - !----------------------------------------------------------------- - ! ... looks up Effective Henry's Law Constant parameters - !----------------------------------------------------------------- - pure integer function get_heff_index(species_name) result(index) - use shr_drydep_mod, only: species_name_table - - character(len=*), intent(in) :: species_name - - do index = 1, size(species_name_table) - if (trim(adjustl(species_name)) == & - trim(adjustl(species_name_table(index)))) return - end do - index = -1 - end function get_heff_index + end subroutine setsox_sub end module mo_setsox diff --git a/src/chemistry/aerosol/mo_setsox_cam.F90 b/src/chemistry/aerosol/mo_setsox_cam.F90 new file mode 100644 index 0000000000..98e9f64443 --- /dev/null +++ b/src/chemistry/aerosol/mo_setsox_cam.F90 @@ -0,0 +1,321 @@ +!----------------------------------------------------------------------- +! CAM wrapper for mo_setsox (portable aqueous sulfur chemistry). +! +! Resolves the species indices / invariant flags and Henry's Law table +! indices, hands them (with the host physical constants) to the portable +! setsox_init / sox_cldaero_init, and marshals CAM structures (physics +! state / pbuf CO2, shr_drydep dheff table) into plain arguments for the +! portable setsox_sub. +!----------------------------------------------------------------------- +module mo_setsox_cam + + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_logfile, only : iulog + use physics_types,only : physics_state + use aerosol_state_mod, only: aerosol_state + + implicit none + + private + public :: sox_inti, setsox + public :: has_sox + + logical :: has_sox = .true. + +contains + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + subroutine sox_inti(aero_props) + !----------------------------------------------------------------------- + ! ... initialize the hetero sox routine + !----------------------------------------------------------------------- + + use mo_chem_utls, only : get_spc_ndx, get_inv_ndx + use spmd_utils, only : masterproc + use phys_control, only : phys_getopts, cam_chempkg_is + use carma_flags_mod, only : carma_do_cloudborne + use mo_setsox, only : setsox_init + use sox_cldaero_mod, only : sox_cldaero_init + use aerosol_properties_mod, only : aerosol_properties + use mo_constants, only : pi + use cam_abortutils, only : endrun + + class(aerosol_properties), target, intent(in) :: aero_props + + logical :: modal_aerosols + + logical :: cloud_borne + integer :: id_msa + integer :: id_so2, id_nh3, id_hno3, id_h2o2, id_o3, id_ho2 + integer :: id_so4, id_h2so4 + logical :: inv_so2, inv_nh3, inv_hno3, inv_h2o2, inv_ho2, inv_o3 + + ! Indices for species in the shared array of Henry's Law constant parameters + integer :: heff_id_hno3, heff_id_so2, heff_id_nh3, heff_id_co2, heff_id_h2o2, heff_id_o3 + + character(len=512) :: errmsg + integer :: errflg + + id_so4 = -1 + id_h2so4 = -1 + + call phys_getopts( prog_modal_aero_out=modal_aerosols ) + cloud_borne = modal_aerosols .or. carma_do_cloudborne + + !----------------------------------------------------------------- + ! ... get species indicies + !----------------------------------------------------------------- + + if (cloud_borne) then + id_h2so4 = get_spc_ndx( 'H2SO4' ) + else + id_so4 = get_spc_ndx( 'SO4' ) + endif + id_msa = get_spc_ndx( 'MSA' ) + + inv_so2 = .false. + id_so2 = get_inv_ndx( 'SO2' ) + inv_so2 = id_so2 > 0 + if ( .not. inv_so2 ) then + id_so2 = get_spc_ndx( 'SO2' ) + endif + + inv_NH3 = .false. + id_NH3 = get_inv_ndx( 'NH3' ) + inv_NH3 = id_NH3 > 0 + if ( .not. inv_NH3 ) then + id_NH3 = get_spc_ndx( 'NH3' ) + endif + + inv_HNO3 = .false. + id_HNO3 = get_inv_ndx( 'HNO3' ) + inv_HNO3 = id_hno3 > 0 + if ( .not. inv_HNO3 ) then + id_HNO3 = get_spc_ndx( 'HNO3' ) + endif + + inv_H2O2 = .false. + id_H2O2 = get_inv_ndx( 'H2O2' ) + inv_H2O2 = id_H2O2 > 0 + if ( .not. inv_H2O2 ) then + id_H2O2 = get_spc_ndx( 'H2O2' ) + endif + + inv_HO2 = .false. + id_HO2 = get_inv_ndx( 'HO2' ) + inv_HO2 = id_HO2 > 0 + if ( .not. inv_HO2 ) then + id_HO2 = get_spc_ndx( 'HO2' ) + endif + + inv_o3 = get_inv_ndx( 'O3' ) > 0 + if (inv_o3) then + id_o3 = get_inv_ndx( 'O3' ) + else + id_o3 = get_spc_ndx( 'O3' ) + endif + inv_ho2 = get_inv_ndx( 'HO2' ) > 0 + if (inv_ho2) then + id_ho2 = get_inv_ndx( 'HO2' ) + else + id_ho2 = get_spc_ndx( 'HO2' ) + endif + + has_sox = (id_so2>0) .and. (id_h2o2>0) .and. (id_o3>0) .and. (id_ho2>0) + if (cloud_borne) then + has_sox = has_sox .and. (id_h2so4>0) + else + has_sox = has_sox .and. (id_so4>0) .and. (id_nh3>0) + endif + + ! Lookup Effective Henry's Law Constant parameters from the common + ! data file read in the shared code. + heff_id_hno3 = get_heff_index( 'HNO3' ) + heff_id_so2 = get_heff_index( 'SO2' ) + heff_id_nh3 = get_heff_index( 'NH3' ) + heff_id_co2 = get_heff_index( 'CO2' ) + heff_id_h2o2 = get_heff_index( 'H2O2' ) + heff_id_o3 = get_heff_index( 'OX' ) + + has_sox = has_sox .and. (heff_id_hno3 > 0) .and. (heff_id_so2 > 0) & + .and. (heff_id_nh3 > 0) .and. (heff_id_co2 > 0) & + .and. (heff_id_h2o2 > 0) .and. (heff_id_o3 > 0) + + if (masterproc) then + write(iulog,*) 'sox_inti: has_sox = ',has_sox + endif + + if( has_sox ) then + if (masterproc) then + write(iulog,*) '-----------------------------------------' + write(iulog,*) ' mo_setsox will do sox aerosols' + write(iulog,*) '-----------------------------------------' + endif + else + if (masterproc) then + write(iulog,*) '-----------------------------------------' + write(iulog,*) ' mo_setsox will not do sox aerosols' + write(iulog,*) '-----------------------------------------' + endif + return + end if + + call setsox_init( cloud_borne_in=cloud_borne, & + id_so2_in=id_so2, inv_so2_in=inv_so2, & + id_nh3_in=id_nh3, inv_nh3_in=inv_nh3, & + id_hno3_in=id_hno3, inv_hno3_in=inv_hno3, & + id_h2o2_in=id_h2o2, inv_h2o2_in=inv_h2o2, & + id_ho2_in=id_ho2, inv_ho2_in=inv_ho2, & + id_o3_in=id_o3, inv_o3_in=inv_o3, & + id_h2so4_in=id_h2so4, id_so4_in=id_so4, id_msa_in=id_msa, & + heff_id_hno3_in=heff_id_hno3, heff_id_so2_in=heff_id_so2, & + heff_id_nh3_in=heff_id_nh3, heff_id_co2_in=heff_id_co2, & + heff_id_h2o2_in=heff_id_h2o2, heff_id_o3_in=heff_id_o3 ) + + ! sulfur oxidation is performed internally to GEOS-Chem, so the aerosol + ! and gas updates are not applied here (avoids double counting) + call sox_cldaero_init(aero_props, & + id_msa_in=id_msa, id_h2so4_in=id_h2so4, id_so2_in=id_so2, & + id_h2o2_in=id_h2o2, id_nh3_in=id_nh3, pi_in=pi, & + do_aqueous_sulfur_chemistry_aerosol_update_in=.not. cam_chempkg_is('geoschem_mam4'), & + errmsg=errmsg, errflg=errflg) + if (errflg /= 0) then + call endrun(trim(errmsg)) + end if + + end subroutine sox_inti + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + subroutine setsox( aero_state, state, & + pbuf, & + ncol, & + dtime, & + press, & + pdel, & + tfld, & + mbar, & + lwc, & + cldfrc, & + cldnum, & + invariants, & + qcw, & + qin, & + xphlwc, & + aqso4, & + aqh2so4,& + aqso4_h2o2, & + aqso4_o3, & + yph_in, & + aqso4_h2o2_3d, & + aqso4_o3_3d & + ) + + !----------------------------------------------------------------------- + ! CAM-facing setsox: marshal CAM structures (pbuf CO2 via rad_cnst, + ! shr_drydep dheff table, host physical constants) and call the + ! portable setsox_sub. + !----------------------------------------------------------------------- + + use physconst, only : avogad, boltz, r_universal, mwco2, mwdry, gravit + use ppgrid, only : pver + use shr_drydep_mod, only : dheff + use physics_buffer, only : physics_buffer_desc + use rad_constituents, only : rad_cnst_get_gas + use mo_setsox, only : setsox_sub + use cam_abortutils, only : endrun + + !----------------------------------------------------------------------- + ! ... Dummy arguments + !----------------------------------------------------------------------- + class(aerosol_state), intent(in) :: aero_state + type(physics_state), intent(in) :: state ! Physics state variables + type(physics_buffer_desc), pointer, intent(inout) :: pbuf(:) ! Physics buffer + integer, intent(in) :: ncol ! num of columns in chunk + real(r8), intent(in) :: dtime ! time step (sec) + real(r8), intent(in) :: press(:,:) ! midpoint pressure ( Pa ) + real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) + real(r8), intent(in) :: tfld(:,:) ! temperature + real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) + real(r8), target, intent(in) :: lwc(:,:) ! cloud liquid water content (kg/kg) + real(r8), target, intent(in) :: cldfrc(:,:) ! cloud fraction + real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) + real(r8), intent(in) :: invariants(:,:,:) + real(r8), target, intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) + real(r8), intent(inout) :: qin(:,:,:) ! transported species ( vmr ) + real(r8), intent(out) :: xphlwc(:,:) ! pH value multiplied by lwc + + real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry + real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry + real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) + real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) + real(r8), intent(in), optional :: yph_in ! ph value + real(r8), intent(out), optional :: aqso4_h2o2_3d(:, :) ! 3D SO4 aqueous phase chemistry due to H2O2 (kg/m2) + real(r8), intent(out), optional :: aqso4_o3_3d(:, :) ! 3D SO4 aqueous phase chemistry due to O3 (kg/m2) + + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + real(r8), pointer :: co2_mass_mixing_ratio(:,:) ! kg kg-1 + + character(len=512) :: errmsg + integer :: errflg + + call rad_cnst_get_gas(0, 'CO2', state, pbuf, co2_mass_mixing_ratio) + + call setsox_sub( aero_state = aero_state, & + ncol = ncol, & + pver = pver, & + dtime = dtime, & + press = press, & + pdel = pdel, & + tfld = tfld, & + mbar = mbar, & + lwc = lwc, & + cldfrc = cldfrc, & + cldnum = cldnum, & + invariants = invariants, & + co2_mass_mixing_ratio = co2_mass_mixing_ratio, & + dheff = dheff, & + AVOGADRO_KMOL = avogad, & + BOLTZMANN = boltz, & + GAS_CONSTANT_KMOL = r_universal, & + MOLECULAR_WEIGHT_CO2_G_MOL = mwco2, & + MOLECULAR_WEIGHT_DRY_AIR_G_MOL = mwdry, & + gravit = gravit, & + qcw = qcw, & + qin = qin, & + xphlwc = xphlwc, & + aqso4 = aqso4, & + aqh2so4 = aqh2so4, & + aqso4_h2o2 = aqso4_h2o2, & + aqso4_o3 = aqso4_o3, & + errmsg = errmsg, & + errflg = errflg, & + yph_in = yph_in, & + aqso4_h2o2_3d = aqso4_h2o2_3d, & + aqso4_o3_3d = aqso4_o3_3d ) + + if (errflg /= 0) then + call endrun(trim(errmsg)) + end if + + end subroutine setsox + + !----------------------------------------------------------------- + ! ... looks up Effective Henry's Law Constant parameters + !----------------------------------------------------------------- + pure integer function get_heff_index(species_name) result(index) + use shr_drydep_mod, only: species_name_table + + character(len=*), intent(in) :: species_name + + do index = 1, size(species_name_table) + if (trim(adjustl(species_name)) == & + trim(adjustl(species_name_table(index)))) return + end do + index = -1 + end function get_heff_index + +end module mo_setsox_cam diff --git a/src/chemistry/aerosol/modal_aero_data.F90 b/src/chemistry/aerosol/modal_aero_data.F90 index 456213b2f0..fbf06a7075 100644 --- a/src/chemistry/aerosol/modal_aero_data.F90 +++ b/src/chemistry/aerosol/modal_aero_data.F90 @@ -110,6 +110,8 @@ module modal_aero_data logical, public, protected :: soa_multi_species = .false. + logical, public :: modal_strat_sulfate = .false. + character(len=16), allocatable :: xname_massptr(:,:) ! names of species in each mode character(len=16), allocatable :: xname_massptrcw(:,:) ! names of cloud-borne species in each mode diff --git a/src/chemistry/aerosol/modal_aerosol_state_mod.F90 b/src/chemistry/aerosol/modal_aerosol_state_mod.F90 index aecbaf8f41..8474e90688 100644 --- a/src/chemistry/aerosol/modal_aerosol_state_mod.F90 +++ b/src/chemistry/aerosol/modal_aerosol_state_mod.F90 @@ -4,25 +4,23 @@ module modal_aerosol_state_mod use aerosol_state_mod, only: aerosol_state, ptr2d_t use radiative_aerosol, only: rad_aer_get_info, rad_aer_get_mode_props use aerosol_mmr_host, only: rad_cnst_get_aer_mmr, rad_cnst_get_mode_num, aero_host_binding_t - !REMOVECAM: no longer need pbuf and state after CAM is retired - use physics_buffer, only: pbuf_get_field, pbuf_get_index - !REMOVECAM_END + use aerosol_mmr_host, only: get_mode_dry_diameter, get_mode_wet_diameter, get_mode_aer_water use aerosol_properties_mod, only: aerosol_properties, aero_name_len - use physconst, only: rhoh2o + use physconst, only: rhoh2o, pi use cam_abortutils, only: endrun - use ppgrid, only: pver implicit none private public :: modal_aerosol_state + public :: modal_aerosol_state_register_water_uptake_diag type, extends(aerosol_state) :: modal_aerosol_state private - ! Opaque host-binding handle used to retrieve aerosol fields from - ! host model data; built by aerosol_instances_mod. - ! This keeps model-specific data structures outside of the aerosol interface. + ! Opaque host-binding handle used to retrieve aerosol fields from + ! host model data; built by host-side wiring (aerosol_instances_mod). + ! This keeps model-specific data structures outside of the aerosol interface. type(aero_host_binding_t) :: host_ contains @@ -58,10 +56,53 @@ module modal_aerosol_state_mod procedure :: constructor end interface modal_aerosol_state + ! Interface of the diagnostic-list water uptake recompute. The science + ! (modal_aero_wateruptake_diag) lives with the portable modal aerosol + ! schemes, which are not part of every build, so it is wired in by host + ! code at initialization through a procedure pointer rather than + ! referenced directly; when nothing is registered, diagnostic-list + ! water uptake aborts as unavailable. + abstract interface + subroutine water_uptake_diag_i(aero_props, aero_state, ncol, nlev, top_lev, & + pi, rhoh2o, t, pmid, h2ommr, cldn, bin_idx, dgnumwet, qaerwat, errmsg, errflg) + import :: aerosol_properties, aerosol_state, r8 + class(aerosol_properties), intent(in) :: aero_props + class(aerosol_state), intent(in) :: aero_state + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: nlev ! number of vertical levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8), intent(in) :: pi ! pi + real(r8), intent(in) :: rhoh2o ! density of liquid water (kg/m3) + real(r8), intent(in) :: t(:,:) ! temperature (K) + real(r8), intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8), intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8), intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) + integer, intent(in) :: bin_idx ! mode index of the returned slices + real(r8), intent(out) :: dgnumwet(:,:) ! wet number mode diameter of mode bin_idx (m) + real(r8), intent(out) :: qaerwat(:,:) ! aerosol water of mode bin_idx (g/g) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + end subroutine water_uptake_diag_i + end interface + + procedure(water_uptake_diag_i), pointer :: water_uptake_diag_fn => null() + real(r8), parameter :: rh2odens = 1._r8/rhoh2o contains + !------------------------------------------------------------------------------ + ! register the diagnostic-list water uptake implementation (host wiring; + ! called at initialization from code that has access to the portable + ! modal aerosol schemes) + !------------------------------------------------------------------------------ + subroutine modal_aerosol_state_register_water_uptake_diag(fn) + procedure(water_uptake_diag_i) :: fn + + water_uptake_diag_fn => fn + + end subroutine modal_aerosol_state_register_water_uptake_diag + !------------------------------------------------------------------------------ !------------------------------------------------------------------------------ function constructor(ncol, host, list_idx) result(newobj) @@ -248,7 +289,7 @@ subroutine icenuc_size_wght_arr(self, bin_ndx, ncol, nlev, species_type, use_pre wght(:ncol,:) = 1._r8 else call rad_aer_get_mode_props(0, bin_ndx, sigmag=sigmag_aitken) - call pbuf_get_field(self%host_%pbuf, pbuf_get_index('DGNUM' ), dgnum) + call get_mode_dry_diameter(self%host_, dgnum) do k = 1,nlev do i = 1,ncol if (dgnum(i,k,bin_ndx) > 0._r8) then @@ -309,7 +350,7 @@ subroutine icenuc_size_wght_val(self, bin_ndx, col_ndx, lyr_ndx, species_type, u wght = 1._r8 else call rad_aer_get_mode_props(0, bin_ndx, sigmag=sigmag_aitken) - call pbuf_get_field(self%host_%pbuf, pbuf_get_index('DGNUM' ), dgnum) + call get_mode_dry_diameter(self%host_, dgnum) if (dgnum(col_ndx,lyr_ndx,bin_ndx) > 0._r8) then ! only allow so4 with D>0.1 um in ice nucleation @@ -452,38 +493,41 @@ end subroutine hygroscopicity !------------------------------------------------------------------------------ ! returns aerosol wet diameter and aerosol water concentration for a given mode - !------------------------------------------------------------------------------ - !REMOVECAM - under CAM-SIMA, water uptake computed by CCPP scheme; results passed via constituent interface - subroutine water_uptake(self, aero_props, bin_idx, ncol, nlev, dgnumwet, qaerwat) - use modal_aero_wateruptake, only: modal_aero_wateruptake_dr - use modal_aero_calcsize, only: modal_aero_calcsize_diag + ! + ! For the climate list (list_idx==0) these were pre-computed by the water + ! uptake calculation and are retrieved via the aerosol_mmr_host accessors + ! (DGNUMWET/QAERWAT pbuf fields in CAM; dgncur_awet/qaerwat_aer registry + ! fields written by the CCPPized wateruptake scheme in CAM-SIMA). + ! Diagnostic lists are recomputed from the atmospheric state passed in by + ! the caller, via the registered portable implementation (see the + ! water_uptake_diag_i interface above). + !------------------------------------------------------------------------------ + subroutine water_uptake(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn, dgnumwet, qaerwat) class(modal_aerosol_state), intent(in) :: self class(aerosol_properties), intent(in) :: aero_props integer, intent(in) :: bin_idx ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) real(r8),intent(out) :: dgnumwet(ncol,nlev) ! aerosol wet diameter (m) real(r8),intent(out) :: qaerwat(ncol,nlev) ! aerosol water concentration (g/g) - integer :: istat, nmodes - real(r8), pointer :: dgnumdry_m(:,:,:) ! number mode dry diameter for all modes real(r8), pointer :: dgnumwet_m(:,:,:) ! number mode wet diameter for all modes real(r8), pointer :: qaerwat_m(:,:,:) ! aerosol water (g/g) for all modes - real(r8), pointer :: wetdens_m(:,:,:) ! - real(r8), pointer :: hygro_m(:,:,:) ! - real(r8), pointer :: dryvol_m(:,:,:) ! - real(r8), pointer :: dryrad_m(:,:,:) ! - real(r8), pointer :: drymass_m(:,:,:) ! - real(r8), pointer :: so4dryvol_m(:,:,:) ! - real(r8), pointer :: naer_m(:,:,:) ! - nmodes = aero_props%nbins() + character(len=512) :: errmsg + integer :: errflg if (self%list_idx_ == 0) then ! water uptake and wet radius for the climate list has already been calculated - call pbuf_get_field(self%host_%pbuf, pbuf_get_index('DGNUMWET'), dgnumwet_m) - call pbuf_get_field(self%host_%pbuf, pbuf_get_index('QAERWAT'), qaerwat_m) + call get_mode_wet_diameter(self%host_, dgnumwet_m) + call get_mode_aer_water(self%host_, qaerwat_m) dgnumwet(:ncol,:nlev) = dgnumwet_m(:ncol,:nlev,bin_idx) qaerwat (:ncol,:nlev) = qaerwat_m(:ncol,:nlev,bin_idx) @@ -491,38 +535,18 @@ subroutine water_uptake(self, aero_props, bin_idx, ncol, nlev, dgnumwet, qaerwat else ! If doing a diagnostic calculation then need to calculate the wet radius ! and water uptake for the diagnostic modes - allocate(dgnumdry_m(ncol,nlev,nmodes), dgnumwet_m(ncol,nlev,nmodes), & - qaerwat_m(ncol,nlev,nmodes), wetdens_m(ncol,nlev,nmodes), & - hygro_m(ncol,nlev,nmodes), dryvol_m(ncol,nlev,nmodes), & - dryrad_m(ncol,nlev,nmodes), drymass_m(ncol,nlev,nmodes), & - so4dryvol_m(ncol,nlev,nmodes), naer_m(ncol,nlev,nmodes), stat=istat) - if (istat > 0) then - dgnumwet = -huge(1._r8) - qaerwat = -huge(1._r8) - return + if (.not. associated(water_uptake_diag_fn)) then + call endrun('modal_aerosol_state::water_uptake: diagnostic-list water uptake ' // & + 'is not available: no implementation registered (the modal aerosol ' // & + 'schemes are not part of this build)') + end if + call water_uptake_diag_fn(aero_props, self, ncol, nlev, top_lev, pi, rhoh2o, & + t, pmid, h2ommr, cldn, bin_idx, dgnumwet, qaerwat, errmsg, errflg) + if (errflg /= 0) then + call endrun('modal_aerosol_state::water_uptake: '//trim(errmsg)) end if - call modal_aero_calcsize_diag(self%host_%state, self%host_%pbuf, aero_props, self, dgnumdry_m, hygro_m, & - dryvol_m, dryrad_m, drymass_m, so4dryvol_m, naer_m) - call modal_aero_wateruptake_dr(self%host_%state, self%host_%pbuf, aero_props, self, dgnumdry_m, dgnumwet_m, & - qaerwat_m, wetdens_m, hygro_m, dryvol_m, dryrad_m, & - drymass_m, so4dryvol_m, naer_m) - - dgnumwet(:ncol,:nlev) = dgnumwet_m(:ncol,:nlev,bin_idx) - qaerwat (:ncol,:nlev) = qaerwat_m(:ncol,:nlev,bin_idx) - - deallocate(dgnumdry_m) - deallocate(dgnumwet_m) - deallocate(qaerwat_m) - deallocate(wetdens_m) - deallocate(hygro_m) - deallocate(dryvol_m) - deallocate(dryrad_m) - deallocate(drymass_m) - deallocate(so4dryvol_m) - deallocate(naer_m) endif - end subroutine water_uptake !------------------------------------------------------------------------------ @@ -557,7 +581,8 @@ end function dry_volume !------------------------------------------------------------------------------ ! aerosol wet volume (m3/kg) for given radiation diagnostic list number and bin number !------------------------------------------------------------------------------ - function wet_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) + function wet_volume(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) result(vol) class(modal_aerosol_state), intent(in) :: self class(aerosol_properties), intent(in) :: aero_props @@ -565,6 +590,11 @@ function wet_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) integer, intent(in) :: bin_idx ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) real(r8) :: vol(ncol,nlev) ! m3/kg @@ -572,7 +602,8 @@ function wet_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) real(r8) :: watervol(ncol,nlev) dryvol = self%dry_volume(aero_props, bin_idx, ncol, nlev) - watervol = self%water_volume(aero_props, bin_idx, ncol, nlev) + watervol = self%water_volume(aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) vol = watervol + dryvol @@ -581,7 +612,8 @@ end function wet_volume !------------------------------------------------------------------------------ ! aerosol water volume (m3/kg) for given radiation diagnostic list number and bin number !------------------------------------------------------------------------------ - function water_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) + function water_volume(self, aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn) result(vol) class(modal_aerosol_state), intent(in) :: self class(aerosol_properties), intent(in) :: aero_props @@ -589,13 +621,19 @@ function water_volume(self, aero_props, bin_idx, ncol, nlev) result(vol) integer, intent(in) :: bin_idx ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) real(r8) :: vol(ncol,nlev) ! m3/kg real(r8) :: dgnumwet(ncol,nlev) real(r8) :: qaerwat(ncol,nlev) - call self%water_uptake(aero_props, bin_idx, ncol, nlev, dgnumwet, qaerwat) + call self%water_uptake(aero_props, bin_idx, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn, dgnumwet, qaerwat) vol(:ncol,:nlev) = qaerwat(:ncol,:nlev)*rh2odens where (vol<0._r8) @@ -607,7 +645,6 @@ end function water_volume !------------------------------------------------------------------------------ ! aerosol wet diameter for a given mode !------------------------------------------------------------------------------ - !REMOVECAM - under CAM-SIMA, wet diameter provided by CCPP scheme output function wet_diameter(self, bin_idx, ncol, nlev) result(diam) class(modal_aerosol_state), intent(in) :: self integer, intent(in) :: bin_idx ! bin number @@ -618,7 +655,7 @@ function wet_diameter(self, bin_idx, ncol, nlev) result(diam) real(r8), pointer :: dgnumwet(:,:,:) - call pbuf_get_field(self%host_%pbuf, pbuf_get_index('DGNUMWET'), dgnumwet) + call get_mode_wet_diameter(self%host_, dgnumwet) diam(:ncol,:nlev) = dgnumwet(:ncol,:nlev,bin_idx) @@ -729,12 +766,13 @@ subroutine aqu_gain_binfraction(self, aero_props, type, qcw, delso4_o3rxn, faqga real(r8), intent(out) :: faqgain(:,:,:) ! fraction gain in each mode / bin character(len=aero_name_len) :: modetype, spectype - integer :: i,k,l,m,n,mm, ncol, nbins + integer :: i,k,l,m,n,mm, ncol, nlev, nbins integer :: accum_n real(r8) :: sumf real(r8), allocatable :: qnum_c(:) ncol = self%ncol() + nlev = size(qcw, 2) nbins = aero_props%nbins() !------------------------------------------------------------------------- @@ -761,7 +799,7 @@ subroutine aqu_gain_binfraction(self, aero_props, type, qcw, delso4_o3rxn, faqga faqgain = 0.0_r8 - lev_loop: do k = 1,pver + lev_loop: do k = 1,nlev col_loop: do i = 1,ncol do m = 1, nbins mm = aero_props%indexer(m,0) @@ -851,7 +889,7 @@ subroutine surf_area_dens(self, aero_props, types_list, ncol, nlev, beglev, endl character(len=*), parameter :: subname = 'modal_aerosol_state_mod::surf_area_dens' - call pbuf_get_field(self%host_%pbuf, pbuf_get_index('DGNUMWET'), diam) + call get_mode_wet_diameter(self%host_, diam) ! ! Compute surface aero for each mode. diff --git a/src/chemistry/aerosol/refractive_aerosol_optics_mod.F90 b/src/chemistry/aerosol/refractive_aerosol_optics_mod.F90 index e96fa0c59e..427c66da8f 100644 --- a/src/chemistry/aerosol/refractive_aerosol_optics_mod.F90 +++ b/src/chemistry/aerosol/refractive_aerosol_optics_mod.F90 @@ -70,7 +70,8 @@ module refractive_aerosol_optics_mod !------------------------------------------------------------------------------ !------------------------------------------------------------------------------ - function constructor(aero_props, aero_state, ibin, ncol, nlev, nsw, nlw, crefwsw, crefwlw) & + function constructor(aero_props, aero_state, ibin, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn, nsw, nlw, crefwsw, crefwlw) & result(newobj) class(aerosol_properties),intent(in), target :: aero_props ! aerosol_properties object @@ -78,6 +79,11 @@ function constructor(aero_props, aero_state, ibin, ncol, nlev, nsw, nlw, crefwsw integer, intent(in) :: ibin ! bin number integer, intent(in) :: ncol ! number of columns integer, intent(in) :: nlev ! number of levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8),intent(in) :: t(:,:) ! temperature (K) + real(r8),intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8),intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8),intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) integer, intent(in) :: nsw ! number of short wave lengths integer, intent(in) :: nlw ! number of long wave lengths complex(r8), intent(in) :: crefwsw(nsw) ! complex refractive index for water visible @@ -150,7 +156,8 @@ function constructor(aero_props, aero_state, ibin, ncol, nlev, nsw, nlw, crefwsw end if newobj%crefwsw(:) = crefwsw(:) - call aero_state%water_uptake(aero_props, ibin, ncol, nlev, dgnumwet, qaerwat) + call aero_state%water_uptake(aero_props, ibin, ncol, nlev, top_lev, & + t, pmid, h2ommr, cldn, dgnumwet, qaerwat) nspec = aero_props%nspecies(ibin) diff --git a/src/chemistry/aerosol/sox_cldaero_mod.F90 b/src/chemistry/aerosol/sox_cldaero_mod.F90 index 4a8fc52dec..0565de7544 100644 --- a/src/chemistry/aerosol/sox_cldaero_mod.F90 +++ b/src/chemistry/aerosol/sox_cldaero_mod.F90 @@ -1,17 +1,14 @@ !---------------------------------------------------------------------------------- ! Generic aerosol implementation +! +! Portable (CCPP-ready): species indices, host constants and configuration are +! passed in through sox_cldaero_init; no CAM infrastructure dependencies. !---------------------------------------------------------------------------------- module sox_cldaero_mod use shr_kind_mod, only : r8 => shr_kind_r8 - use cam_abortutils, only : endrun - use ppgrid, only : pcols, pver - use mo_chem_utls, only : get_spc_ndx use cldaero_mod, only : cldaero_conc_t, cldaero_allocate, cldaero_deallocate - use physconst, only : gravit - use phys_control, only : cam_chempkg_is use cldaero_mod, only : cldaero_uptakerate - use chem_mods, only : gas_pcnst use aerosol_properties_mod, only: aerosol_properties use aerosol_state_mod, only: aerosol_state @@ -34,23 +31,47 @@ module sox_cldaero_mod logical :: has_msa = .false. + ! host value of pi (passed at init for bit-for-bit consistency) + real(r8) :: pi = -huge(1._r8) + + ! apply the aqueous sulfur oxidation update to the aerosol/gas state here; + ! .false. when the chemistry package does its own in-cloud sulfur oxidation + ! (e.g. GEOS-Chem), to avoid double counting + logical :: do_aqueous_sulfur_chemistry_aerosol_update = .true. + contains !---------------------------------------------------------------------------------- !---------------------------------------------------------------------------------- - subroutine sox_cldaero_init(aero_props_in) + subroutine sox_cldaero_init(aero_props_in, id_msa_in, id_h2so4_in, id_so2_in, & + id_h2o2_in, id_nh3_in, pi_in, do_aqueous_sulfur_chemistry_aerosol_update_in, & + errmsg, errflg) class(aerosol_properties), target, intent(in) :: aero_props_in - - id_msa = get_spc_ndx( 'MSA' ) - id_h2so4 = get_spc_ndx( 'H2SO4' ) - id_so2 = get_spc_ndx( 'SO2' ) - id_h2o2 = get_spc_ndx( 'H2O2' ) - id_nh3 = get_spc_ndx( 'NH3' ) + ! species indices in the chemistry solution array, resolved by the host + integer, intent(in) :: id_msa_in, id_h2so4_in, id_so2_in, id_h2o2_in, id_nh3_in + real(r8), intent(in) :: pi_in ! host value of pi + logical, intent(in) :: do_aqueous_sulfur_chemistry_aerosol_update_in + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + + id_msa = id_msa_in + id_h2so4 = id_h2so4_in + id_so2 = id_so2_in + id_h2o2 = id_h2o2_in + id_nh3 = id_nh3_in has_msa = id_msa>0 + pi = pi_in + do_aqueous_sulfur_chemistry_aerosol_update = do_aqueous_sulfur_chemistry_aerosol_update_in + if ( id_so2<1 ) then - call endrun('sox_cldaero_init: SO2 is not included in chemistry -- should not invoke sox_cldaero_mod...') + errflg = 1 + errmsg = 'sox_cldaero_init: SO2 is not included in chemistry -- should not invoke sox_cldaero_mod...' + return endif aero_props => aero_props_in @@ -62,13 +83,14 @@ end subroutine sox_cldaero_init !---------------------------------------------------------------------------------- !---------------------------------------------------------------------------------- - function sox_cldaero_create_obj(cldfrc, qcw, lwc, cfact, ncol) result( conc_obj ) + function sox_cldaero_create_obj(cldfrc, qcw, lwc, cfact, ncol, pver) result( conc_obj ) real(r8), intent(in) :: cldfrc(:,:) real(r8), intent(in) :: qcw(:,:,:) real(r8), intent(in) :: lwc(:,:) real(r8), intent(in) :: cfact(:,:) integer, intent(in) :: ncol + integer, intent(in) :: pver type(cldaero_conc_t), pointer :: conc_obj @@ -77,7 +99,7 @@ function sox_cldaero_create_obj(cldfrc, qcw, lwc, cfact, ncol) result( conc_obj integer :: i,k,mm, ntot_amode logical :: mode7 - conc_obj => cldaero_allocate() + conc_obj => cldaero_allocate(ncol, pver) if (aero_props%model_is('BAM')) then ! no cloud-borne aerosols @@ -130,17 +152,17 @@ end function sox_cldaero_create_obj ! Update the mixing ratios !---------------------------------------------------------------------------------- subroutine sox_cldaero_update( aero_state, & - ncol, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, xlwc, & + ncol, pver, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, xlwc, & + gravit, & delso4_hprxn, xh2so4, xso4, xso4_init, nh3g, xnh3, xnh4c, xmsa, xso2, xh2o2, qcw, qin, & aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d, aqso4_o3_3d) - use physics_types, only: physics_state - ! args class(aerosol_state), intent(in) :: aero_state integer, intent(in) :: ncol + integer, intent(in) :: pver real(r8), intent(in) :: dtime ! time step (sec) @@ -154,6 +176,8 @@ subroutine sox_cldaero_update( aero_state, & real(r8), intent(in) :: cfact(:,:) real(r8), intent(in) :: xlwc(:,:) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + real(r8), intent(in) :: delso4_hprxn(:,:) real(r8), intent(in) :: xh2so4(:,:) real(r8), intent(in) :: xso4(:,:) @@ -215,7 +239,8 @@ subroutine sox_cldaero_update( aero_state, & ! GEOS-Chem. If running with GEOS-Chem then sulfur oxidation ! is performed internally to GEOS-Chem. Here, we just return to the ! parent routine and thus we do not apply tendencies calculated by MAM. - if ( cam_chempkg_is('geoschem_mam4') ) return + ! (The host sets this flag; CAM passes .not. cam_chempkg_is('geoschem_mam4').) + if ( .not. do_aqueous_sulfur_chemistry_aerosol_update ) return where (cldfrc(:ncol,:) >= 1.0e-5_r8) delso4_ox(:ncol,:) = xso4(:ncol,:) - xso4_init(:ncol,:) @@ -244,7 +269,7 @@ subroutine sox_cldaero_update( aero_state, & ! faqgain_msa(n) = fraction of total msa_c gain going to mode n - uptkrate = cldaero_uptakerate( xl, cldnum(i,k), cfact(i,k), cldfrc(i,k), tfld(i,k), press(i,k) ) + uptkrate = cldaero_uptakerate( xl, cldnum(i,k), cfact(i,k), cldfrc(i,k), tfld(i,k), press(i,k), pi ) ! average uptake rate over dtime uptkrate = (1.0_r8 - exp(-min(100._r8,dtime*uptkrate))) / dtime diff --git a/src/chemistry/aerosol/wetdep.F90 b/src/chemistry/aerosol/wetdep.F90 index a1f80d9deb..b60791ea95 100644 --- a/src/chemistry/aerosol/wetdep.F90 +++ b/src/chemistry/aerosol/wetdep.F90 @@ -7,11 +7,8 @@ module wetdep !----------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pcols, pver -use physconst, only: gravit, rair, tmelt -use phys_control, only: cam_physpkg_is -use cam_logfile, only: iulog -use cam_abortutils, only: endrun +use aerosol_properties_mod, only: aerosol_properties +use shr_infnan_mod, only: nan => shr_infnan_nan, assignment(=) implicit none save @@ -19,163 +16,28 @@ module wetdep public :: wetdepa_v1 ! scavenging codes for very soluble aerosols -- CAM4 version 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 :: wetdep_inputs_t -public :: wetdep_init -public :: wetdep_inputs_set +public :: init_bcscavcoef ! build below-cloud impaction scavenging lookup table +public :: get_bcscavcoefs ! interpolate below-cloud impaction scavenging coefs real(r8), parameter :: cmftau = 3600._r8 real(r8), parameter :: rhoh2o = 1000._r8 ! density of water -real(r8), parameter :: molwta = 28.97_r8 ! molecular weight dry air gm/mole real(r8), parameter :: omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero -type wetdep_inputs_t - real(r8), pointer :: cldt(:,:) => null() ! cloud fraction - real(r8), pointer :: qme(:,:) => null() - real(r8), pointer :: prain(:,:) => null() - real(r8), pointer :: bergso(:,:) => null() - real(r8), pointer :: evapr(:,:) => null() - real(r8) :: cldcu(pcols,pver) ! convective cloud fraction, currently empty - real(r8) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation - real(r8) :: cmfdqr(pcols,pver) ! convective production of rain - real(r8) :: conicw(pcols,pver) ! convective in-cloud water - real(r8) :: totcond(pcols, pver) ! total condensate - real(r8) :: cldv(pcols,pver) ! cloudy volume undergoing wet chem and scavenging - real(r8) :: cldvcu(pcols,pver) ! Convective precipitation area at the top interface of current layer - real(r8) :: cldvst(pcols,pver) ! Stratiform precipitation area at the top interface of current layer -end type wetdep_inputs_t - -integer :: cld_idx = 0 -integer :: qme_idx = 0 -integer :: prain_idx = 0 -integer :: bergso_idx = 0 -integer :: nevapr_idx = 0 - -integer :: icwmrdp_idx = 0 -integer :: icwmrsh_idx = 0 -integer :: rprddp_idx = 0 -integer :: rprdsh_idx = 0 -integer :: sh_frac_idx = 0 -integer :: dp_frac_idx = 0 -integer :: nevapr_shcu_idx = 0 -integer :: nevapr_dpcu_idx = 0 -integer :: ixcldice, ixcldliq +! variables for table lookup of aerosol impaction/interception scavenging rates +integer, parameter :: nimptblgrow_mind=-7, nimptblgrow_maxd=12 +real(r8) :: dlndg_nimptblgrow +real(r8),allocatable :: scavimptblnum(:,:) +real(r8),allocatable :: scavimptblvol(:,:) !============================================================================== contains !============================================================================== -!============================================================================== -!============================================================================== -subroutine wetdep_init() - use physics_buffer, only: pbuf_get_index - use constituents, only: cnst_get_ind - - integer :: ierr - - cld_idx = pbuf_get_index('CLD') - qme_idx = pbuf_get_index('QME') - prain_idx = pbuf_get_index('PRAIN') - bergso_idx = pbuf_get_index('BERGSO', errcode=ierr ) - nevapr_idx = pbuf_get_index('NEVAPR') - - icwmrdp_idx = pbuf_get_index('ICWMRDP') - rprddp_idx = pbuf_get_index('RPRDDP') - icwmrsh_idx = pbuf_get_index('ICWMRSH') - rprdsh_idx = pbuf_get_index('RPRDSH') - sh_frac_idx = pbuf_get_index('SH_FRAC' ) - dp_frac_idx = pbuf_get_index('DP_FRAC') - nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') - nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') - - call cnst_get_ind('CLDICE', ixcldice) - call cnst_get_ind('CLDLIQ', ixcldliq) - -endsubroutine wetdep_init - -!============================================================================== -! gathers up the inputs needed for the wetdepa routines -!============================================================================== -subroutine wetdep_inputs_set( state, pbuf, inputs ) - use physics_types, only: physics_state - use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx - - ! args - - type(physics_state), intent(in ) :: state !! physics state - type(physics_buffer_desc), pointer :: pbuf(:) !! physics buffer - type(wetdep_inputs_t), intent(out) :: inputs !! collection of wetdepa inputs - - ! local vars - - real(r8), pointer :: icwmrdp(:,:) ! in cloud water mixing ratio, deep convection - real(r8), pointer :: rprddp(:,:) ! rain production, deep convection - real(r8), pointer :: icwmrsh(:,:) ! in cloud water mixing ratio, deep convection - real(r8), pointer :: rprdsh(:,:) ! rain production, deep convection - real(r8), pointer :: sh_frac(:,:) ! Shallow convective cloud fraction - real(r8), pointer :: dp_frac(:,:) ! Deep convective cloud fraction - real(r8), pointer :: evapcsh(:,:) ! Evaporation rate of shallow convective precipitation >=0. - real(r8), pointer :: evapcdp(:,:) ! Evaporation rate of deep convective precipitation >=0. - - real(r8) :: rainmr(pcols,pver) ! mixing ratio of rain within cloud volume - real(r8) :: cldst(pcols,pver) ! Stratiform cloud fraction - - integer :: itim, ncol - - ncol = state%ncol - itim = pbuf_old_tim_idx() - - call pbuf_get_field(pbuf, cld_idx, inputs%cldt, start=(/1,1,itim/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, qme_idx, inputs%qme ) - call pbuf_get_field(pbuf, prain_idx, inputs%prain ) - call pbuf_get_field(pbuf, nevapr_idx, inputs%evapr ) - call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp ) - call pbuf_get_field(pbuf, icwmrsh_idx, icwmrsh ) - call pbuf_get_field(pbuf, rprddp_idx, rprddp ) - call pbuf_get_field(pbuf, rprdsh_idx, rprdsh ) - call pbuf_get_field(pbuf, sh_frac_idx, sh_frac ) - call pbuf_get_field(pbuf, dp_frac_idx, dp_frac ) - call pbuf_get_field(pbuf, nevapr_shcu_idx, evapcsh ) - call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) - - if (bergso_idx>0) then - call pbuf_get_field(pbuf, bergso_idx, inputs%bergso ) - else - if (.not. associated(inputs%bergso)) then - allocate(inputs%bergso(pcols,pver)) - inputs%bergso(:,:) = 0.0_r8 - endif - endif - - inputs%cldcu(:ncol,:) = dp_frac(:ncol,:) + sh_frac(:ncol,:) - cldst(:ncol,:) = inputs%cldt(:ncol,:) - inputs%cldcu(:ncol,:) ! Stratiform cloud fraction - inputs%evapc(:ncol,:) = evapcsh(:ncol,:) + evapcdp(:ncol,:) - inputs%cmfdqr(:ncol,:) = rprddp(:ncol,:) + rprdsh(:ncol,:) - - ! sum deep and shallow convection contributions - if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then - ! Dec.29.2009. Sungsu - inputs%conicw(:ncol,:) = (icwmrdp(:ncol,:)*dp_frac(:ncol,:) + icwmrsh(:ncol,:)*sh_frac(:ncol,:))/ & - max(0.01_r8, sh_frac(:ncol,:) + dp_frac(:ncol,:)) - else - inputs%conicw(:ncol,:) = icwmrdp(:ncol,:) + icwmrsh(:ncol,:) - end if - - inputs%totcond(:ncol,:) = state%q(:ncol,:,ixcldliq) + state%q(:ncol,:,ixcldice) - - call clddiag( state%t, state%pmid, state%pdel, inputs%cmfdqr, inputs%evapc, & - inputs%cldt, inputs%cldcu, cldst, inputs%qme, inputs%evapr, & - inputs%prain, inputs%cldv, inputs%cldvcu, inputs%cldvst, rainmr, & - state%ncol ) - -end subroutine wetdep_inputs_set - subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & - cldt, cldcu, cldst, cme, evapr, & + cldt, cldcu, cldst, evapr, & prain, cldv, cldvcu, cldvst, rain, & - ncol) + ncol, pver, gravit, tmelt, rair) ! ------------------------------------------------------------------------------------ ! Estimate the cloudy volume which is occupied by rain or cloud water as @@ -188,43 +50,46 @@ subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & ! ------------------------------------------------------------------------------------ ! Input arguments: - real(r8), intent(in) :: t(pcols,pver) ! temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) ! pressure at layer midpoints - real(r8), intent(in) :: pdel(pcols,pver) ! pressure difference across layers - real(r8), intent(in) :: cmfdqr(pcols,pver) ! dq/dt due to convective rainout - real(r8), intent(in) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation ( >= 0 ) - real(r8), intent(in) :: cldt(pcols,pver) ! total cloud fraction - real(r8), intent(in) :: cldcu(pcols,pver) ! Cumulus cloud fraction - real(r8), intent(in) :: cldst(pcols,pver) ! Stratus cloud fraction - real(r8), intent(in) :: cme(pcols,pver) ! rate of cond-evap within the cloud - real(r8), intent(in) :: evapr(pcols,pver) ! rate of evaporation of falling precipitation (kg/kg/s) - real(r8), intent(in) :: prain(pcols,pver) ! rate of conversion of condensate to precipitation (kg/kg/s) + real(r8), intent(in) :: t(:,:) ! temperature (K) + real(r8), intent(in) :: pmid(:,:) ! pressure at layer midpoints + real(r8), intent(in) :: pdel(:,:) ! pressure difference across layers + real(r8), intent(in) :: cmfdqr(:,:) ! dq/dt due to convective rainout + real(r8), intent(in) :: evapc(:,:) ! Evaporation rate of convective precipitation ( >= 0 ) + real(r8), intent(in) :: cldt(:,:) ! total cloud fraction + real(r8), intent(in) :: cldcu(:,:) ! Cumulus cloud fraction + real(r8), intent(in) :: cldst(:,:) ! Stratus cloud fraction + real(r8), intent(in) :: evapr(:,:) ! rate of evaporation of falling precipitation (kg/kg/s) + real(r8), intent(in) :: prain(:,:) ! rate of conversion of condensate to precipitation (kg/kg/s) integer, intent(in) :: ncol + integer, intent(in) :: pver + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + real(r8), intent(in) :: tmelt ! freezing point of water (K) + real(r8), intent(in) :: rair ! dry air gas constant (J/K/kg) ! Output arguments: - real(r8), intent(out) :: cldv(pcols,pver) ! fraction occupied by rain or cloud water - real(r8), intent(out) :: cldvcu(pcols,pver) ! Convective precipitation volume - real(r8), intent(out) :: cldvst(pcols,pver) ! Stratiform precipitation volume - real(r8), intent(out) :: rain(pcols,pver) ! mixing ratio of rain (kg/kg) + real(r8), intent(out) :: cldv(:,:) ! fraction occupied by rain or cloud water + real(r8), intent(out) :: cldvcu(:,:) ! Convective precipitation volume + real(r8), intent(out) :: cldvst(:,:) ! Stratiform precipitation volume + real(r8), intent(out) :: rain(:,:) ! mixing ratio of rain (kg/kg) ! Local variables: integer i, k real(r8) convfw ! used in fallspeed calculation; taken from findmcnew - real(r8) sumppr(pcols) ! precipitation rate (kg/m2-s) - real(r8) sumpppr(pcols) ! sum of positive precips from above - real(r8) cldv1(pcols) ! precip weighted cloud fraction from above + real(r8) sumppr(ncol) ! precipitation rate (kg/m2-s) + real(r8) sumpppr(ncol) ! sum of positive precips from above + real(r8) cldv1(ncol) ! precip weighted cloud fraction from above real(r8) lprec ! local production rate of precip (kg/m2/s) real(r8) lprecp ! local production rate of precip (kg/m2/s) if positive real(r8) rho ! air density real(r8) vfall - real(r8) sumppr_cu(pcols) ! Convective precipitation rate (kg/m2-s) - real(r8) sumpppr_cu(pcols) ! Sum of positive convective precips from above - real(r8) cldv1_cu(pcols) ! Convective precip weighted convective cloud fraction from above + real(r8) sumppr_cu(ncol) ! Convective precipitation rate (kg/m2-s) + real(r8) sumpppr_cu(ncol) ! Sum of positive convective precips from above + real(r8) cldv1_cu(ncol) ! Convective precip weighted convective cloud fraction from above real(r8) lprec_cu ! Local production rate of convective precip (kg/m2/s) real(r8) lprecp_cu ! Local production rate of convective precip (kg/m2/s) if positive - real(r8) sumppr_st(pcols) ! Stratiform precipitation rate (kg/m2-s) - real(r8) sumpppr_st(pcols) ! Sum of positive stratiform precips from above - real(r8) cldv1_st(pcols) ! Stratiform precip weighted stratiform cloud fraction from above + real(r8) sumppr_st(ncol) ! Stratiform precipitation rate (kg/m2-s) + real(r8) sumpppr_st(ncol) ! Sum of positive stratiform precips from above + real(r8) cldv1_st(ncol) ! Stratiform precip weighted stratiform cloud fraction from above real(r8) lprec_st ! Local production rate of stratiform precip (kg/m2/s) real(r8) lprecp_st ! Local production rate of stratiform precip (kg/m2/s) if positive ! ----------------------------------------------------------------------- @@ -290,11 +155,12 @@ end subroutine clddiag ! This is the CAM5 version of wetdepa. subroutine wetdepa_v2( & - p, q, pdel, cldt, cldc, & - cmfdqr, evapc, conicw, precs, conds, & + pdel, cldt, cldc, & + cmfdqr, evapc, conicw, precs, & evaps, cwat, tracer, deltat, scavt, & iscavt, cldvcu, cldvst, dlf, fracis, & - sol_fact, ncol, scavcoef, is_strat_cloudborne, qqcw, & + sol_fact, ncol, scavcoef, gravit, pver, errmsg, errflg, & + is_strat_cloudborne, qqcw, & f_act_conv, icscavt, isscavt, bcscavt, bsscavt, & convproc_do_aer, rcscavt, rsscavt, & sol_facti_in, sol_factic_in, convproc_do_evaprain_atonce_in, bergso_in ) @@ -306,23 +172,20 @@ subroutine wetdepa_v2( & !----------------------------------------------------------------------- real(r8), intent(in) ::& - 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 - evapc(pcols,pver), &! Evaporation rate of convective precipitation - 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 - 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] + pdel(:,:), &! pressure thikness + cldt(:,:), &! total cloud fraction + cldc(:,:), &! convective cloud fraction + cmfdqr(:,:), &! rate of production of convective precip + evapc(:,:), &! Evaporation rate of convective precipitation + conicw(:,:), &! convective cloud water + cwat(:,:), &! cloud water amount + precs(:,:), &! rate of production of stratiform precip + evaps(:,:), &! rate of evaporation of precip + cldvcu(:,:), &! Convective precipitation area at the top interface of each layer + cldvst(:,:), &! Stratiform precipitation area at the top interface of each layer + dlf(:,:), &! Detrainment of convective condensate [kg/kg/s] deltat, &! time step - tracer(pcols,pver) ! trace species + tracer(:,:) ! trace species ! If subroutine is called with just sol_fact: ! sol_fact is used for both in- and below-cloud scavenging @@ -330,13 +193,17 @@ subroutine wetdepa_v2( & ! sol_fact is used for below cloud scavenging ! sol_facti is used for in cloud scavenging - real(r8), intent(in) :: sol_fact(pcols,pver) + real(r8), intent(in) :: sol_fact(:,:) 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(in) :: scavcoef(:,:) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + integer, intent(in) :: pver + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged + scavt(:,:), &! scavenging tend + iscavt(:,:), &! incloud scavenging tends + fracis(:,:) ! fraction of species not scavenged ! Setting is_strat_cloudborne=.true. indicates that tracer is stratiform-cloudborne aerosol. ! This is only used by MAM code. The optional args qqcw and f_act_conv are not referenced @@ -345,75 +212,78 @@ subroutine wetdepa_v2( & ! interstitial modal aerosols. In this case the optional qqcw (the cloud borne mixing ratio ! corresponding to the interstitial aerosol) must be provided, as well as the optional f_act_conv. logical, intent(in), optional :: is_strat_cloudborne - real(r8), intent(in), optional :: qqcw(pcols,pver) - real(r8), intent(in), optional :: f_act_conv(pcols,pver) + real(r8), intent(in), optional :: qqcw(:,:) + real(r8), intent(in), optional :: f_act_conv(:,:) - real(r8), intent(in), optional :: sol_facti_in(pcols,pver) ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds + real(r8), intent(in), optional :: sol_facti_in(:,:) ! solubility factor (frac of aerosol scavenged in cloud) + real(r8), intent(in), optional :: sol_factic_in(:,:) ! sol_facti_in for convective clouds - 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 :: icscavt(:,:) ! incloud, convective + real(r8), intent(out), optional :: isscavt(:,:) ! incloud, stratiform + real(r8), intent(out), optional :: bcscavt(:,:) ! below cloud, convective + real(r8), intent(out), optional :: bsscavt(:,:) ! below cloud, stratiform ! Setting convproc_do_aer=.true. removes the resuspension term from bcscavt and ! bsscavt and returns those terms as rcscavt and rsscavt respectively. logical, intent(in), optional :: convproc_do_aer - real(r8), intent(out), optional :: rcscavt(pcols,pver) ! resuspension, convective - real(r8), intent(out), optional :: rsscavt(pcols,pver) ! resuspension, stratiform + real(r8), intent(out), optional :: rcscavt(:,:) ! resuspension, convective + real(r8), intent(out), optional :: rsscavt(:,:) ! resuspension, stratiform logical, intent(in), optional :: convproc_do_evaprain_atonce_in - real(r8), intent(in), optional :: bergso_in(pcols,pver) + real(r8), intent(in), optional :: bergso_in(:,:) ! local variables integer :: i, k logical :: out_resuspension - real(r8) :: clds(pcols) ! stratiform cloud fraction - real(r8) :: fracev(pcols) ! fraction of precip from above that is evaporating - real(r8) :: fracev_cu(pcols) ! Fraction of convective precip from above that is evaporating - real(r8) :: fracp(pcols) ! fraction of cloud water converted to precip - real(r8) :: pdog(pcols) ! work variable (pdel/gravit) - real(r8) :: rpdog(pcols) ! work variable (gravit/pdel) - real(r8) :: precabc(pcols) ! conv precip from above (work array) - real(r8) :: precabs(pcols) ! strat precip from above (work array) - real(r8) :: rat(pcols) ! ratio of amount available to amount removed - real(r8) :: scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) :: scavabc(pcols) ! scavenged tracer flux from above (work array) - real(r8) :: srcc(pcols) ! tend for convective rain - real(r8) :: srcs(pcols) ! tend for stratiform rain - real(r8) :: srct(pcols) ! work variable - - real(r8) :: fins(pcols) ! fraction of rem. rate by strat rain - real(r8) :: finc(pcols) ! fraction of rem. rate by conv. rain - real(r8) :: conv_scav_ic(pcols) ! convective scavenging incloud - real(r8) :: conv_scav_bc(pcols) ! convective scavenging below cloud - real(r8) :: st_scav_ic(pcols) ! stratiform scavenging incloud - real(r8) :: st_scav_bc(pcols) ! stratiform scavenging below cloud - - real(r8) :: odds(pcols) ! limit on removal rate (proportional to prec) - real(r8) :: dblchek(pcols) + real(r8) :: clds(ncol) ! stratiform cloud fraction + real(r8) :: fracev(ncol) ! fraction of precip from above that is evaporating + real(r8) :: fracev_cu(ncol) ! Fraction of convective precip from above that is evaporating + real(r8) :: fracp(ncol) ! fraction of cloud water converted to precip + real(r8) :: pdog(ncol) ! work variable (pdel/gravit) + real(r8) :: rpdog(ncol) ! work variable (gravit/pdel) + real(r8) :: precabc(ncol) ! conv precip from above (work array) + real(r8) :: precabs(ncol) ! strat precip from above (work array) + real(r8) :: rat(ncol) ! ratio of amount available to amount removed + real(r8) :: scavab(ncol) ! scavenged tracer flux from above (work array) + real(r8) :: scavabc(ncol) ! scavenged tracer flux from above (work array) + real(r8) :: srcc(ncol) ! tend for convective rain + real(r8) :: srcs(ncol) ! tend for stratiform rain + real(r8) :: srct(ncol) ! work variable + + real(r8) :: fins(ncol) ! fraction of rem. rate by strat rain + real(r8) :: finc(ncol) ! fraction of rem. rate by conv. rain + real(r8) :: conv_scav_ic(ncol) ! convective scavenging incloud + real(r8) :: conv_scav_bc(ncol) ! convective scavenging below cloud + real(r8) :: st_scav_ic(ncol) ! stratiform scavenging incloud + real(r8) :: st_scav_bc(ncol) ! stratiform scavenging below cloud + + real(r8) :: odds(ncol) ! limit on removal rate (proportional to prec) + real(r8) :: dblchek(ncol) logical :: found - real(r8) :: trac_qqcw(pcols) - real(r8) :: tracer_incu(pcols) - real(r8) :: tracer_mean(pcols) + real(r8) :: trac_qqcw(ncol) + real(r8) :: tracer_incu(ncol) + real(r8) :: tracer_mean(ncol) ! 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. - real(r8) :: sol_facti(pcols,pver) ! in cloud fraction of aerosol scavenged - real(r8) :: sol_factb(pcols,pver) ! below cloud fraction of aerosol scavenged - real(r8) :: sol_factic(pcols,pver) ! in cloud fraction of aerosol scavenged for convective clouds + real(r8) :: sol_facti(ncol,pver) ! in cloud fraction of aerosol scavenged + real(r8) :: sol_factb(ncol,pver) ! below cloud fraction of aerosol scavenged + real(r8) :: sol_factic(ncol,pver) ! in cloud fraction of aerosol scavenged for convective clouds real(r8) :: rdeltat logical :: convproc_do_evaprain_atonce ! ------------------------------------------------------------------------ + errmsg = '' + errflg = 0 + if (present(convproc_do_evaprain_atonce_in)) then convproc_do_evaprain_atonce = convproc_do_evaprain_atonce_in else @@ -437,8 +307,10 @@ subroutine wetdepa_v2( & present(rcscavt) .and. present(rsscavt) ) then out_resuspension = .true. else - call endrun('wetdepa_v2: bcscavt, bsscavt, rcscavt, rsscavt'// & - ' must be present when convproc_do_aero true') + errmsg = 'wetdepa_v2: bcscavt, bsscavt, rcscavt, rsscavt'// & + ' must be present when convproc_do_aero true' + errflg = 1 + return end if end if end if @@ -652,13 +524,13 @@ subroutine wetdepa_v2( & ! catch the larger negative values, ignore insignificant small negaive values if (dblchek(i) < -1.e-10_r8) then found = .true. - write(iulog,*) ' wetdapa_v2: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) endif end do if (found) then - call endrun('wetdapa_v2: negative values found') + errmsg = 'wetdapa_v2: negative values found' + errflg = 1 + return end if #endif @@ -672,11 +544,12 @@ end subroutine wetdepa_v2 ! This is the frozen CAM4 version of wetdepa. - subroutine wetdepa_v1( t, p, q, pdel, & - cldt, cldc, cmfdqr, conicw, precs, conds, & + subroutine wetdepa_v1( t, pdel, & + cldt, cmfdqr, conicw, precs, & evaps, cwat, tracer, deltat, & scavt, iscavt, cldv, fracis, sol_fact, ncol, & - scavcoef,icscavt, isscavt, bcscavt, bsscavt, & + scavcoef, tmelt, gravit, pver, errmsg, errflg, & + icscavt, isscavt, bcscavt, bsscavt, & sol_facti_in, sol_factbi_in, sol_factii_in, & sol_factic_in, sol_factiic_in ) @@ -691,21 +564,17 @@ subroutine wetdepa_v1( t, p, q, pdel, & implicit none real(r8), intent(in) ::& - 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 - 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 - cldv(pcols,pver), &! total cloud fraction + t(:,:), &! temperature + pdel(:,:), &! pressure thikness + cldt(:,:), &! total cloud fraction + cmfdqr(:,:), &! rate of production of convective precip + conicw(:,:), &! convective cloud water + cwat(:,:), &! cloud water amount + precs(:,:), &! rate of production of stratiform precip + evaps(:,:), &! rate of evaporation of precip + cldv(:,:), &! total cloud fraction deltat, &! time step - tracer(pcols,pver) ! trace species + tracer(:,:) ! 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: @@ -715,53 +584,43 @@ subroutine wetdepa_v1( t, p, q, pdel, & 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_factic_in(:,:) ! sol_facti_in for convective clouds real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) + real(r8), intent(in) :: scavcoef(:,:) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) integer, intent(in) :: ncol + integer, intent(in) :: pver + real(r8), intent(in) :: tmelt ! freezing point of water (K) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged + scavt(:,:), &! scavenging tend + iscavt(:,:), &! incloud scavenging tends + fracis(:,:) ! fraction of species not scavenged - 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 :: icscavt(:,:) ! incloud, convective + real(r8), intent(out), optional :: isscavt(:,:) ! incloud, stratiform + real(r8), intent(out), optional :: bcscavt(:,:) ! below cloud, convective + real(r8), intent(out), optional :: bsscavt(:,:) ! below cloud, stratiform ! local variables integer i ! x index integer k ! z index - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) fracev(pcols) ! fraction of precip from above that is evaporating + real(r8) fracev(ncol) ! fraction of precip from above that is evaporating real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precabc(pcols) ! conv precip from above (work array) - real(r8) precabs(pcols) ! strat precip from above (work array) - real(r8) precbl ! precip falling out of level (work array) - real(r8) precmin ! minimum convective precip causing scavenging - real(r8) rat(pcols) ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) + real(r8) precabc(ncol) ! conv precip from above (work array) + real(r8) precabs(ncol) ! strat precip from above (work array) + real(r8) rat(ncol) ! ratio of amount available to amount removed + real(r8) scavab(ncol) ! scavenged tracer flux from above (work array) + real(r8) scavabc(ncol) ! scavenged tracer flux from above (work array) real(r8) srcc ! tend for convective rain real(r8) srcs ! tend for stratiform rain - real(r8) srct(pcols) ! work variable - real(r8) tracab(pcols) ! column integrated tracer amount + real(r8) srct(ncol) ! work variable + real(r8) tracab(ncol) ! column integrated tracer amount real(r8) fins ! fraction of rem. rate by strat rain real(r8) finc ! fraction of rem. rate by conv. rain @@ -769,15 +628,15 @@ subroutine wetdepa_v1( t, p, q, pdel, & real(r8) srcs2 ! work variable real(r8) tc ! temp in celcius real(r8) weight ! fraction of condensate which is ice - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level + real(r8) cldmabs(ncol) ! maximum cloud at or above this level + real(r8) cldmabc(ncol) ! maximum cloud at or above this level real(r8) odds ! limit on removal rate (proportional to prec) - real(r8) dblchek(pcols) + real(r8) dblchek(ncol) logical :: found 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_factic(ncol,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, @@ -786,9 +645,8 @@ subroutine wetdepa_v1( t, p, q, pdel, & ! and sol_factic is 1.0 for both cloudborne and interstitial. ! ------------------------------------------------------------------------ - precmin = 0.1_r8/8.64e4_r8 ! set critical value to 0.1 mm/day in kg/m2/s - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme + errmsg = '' + errflg = 0 ! default (if other sol_facts aren't in call, set all to required sol_fact sol_facti = sol_fact @@ -814,7 +672,7 @@ subroutine wetdepa_v1( t, p, q, pdel, & ! the amount of tracer which is pulled out. ! - do i = 1,pcols + do i = 1,ncol precabs(i) = 0 precabc(i) = 0 scavab(i) = 0 @@ -830,8 +688,6 @@ subroutine wetdepa_v1( t, p, q, pdel, & weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice weight = 0._r8 ! assume no ice - pdog = pdel(i,k)/gravit - ! ****************** Evaporation ************************** ! calculate the fraction of strat precip from above ! which evaporates within this layer @@ -973,13 +829,13 @@ subroutine wetdepa_v1( t, p, q, pdel, & ! catch the larger negative values, ignore insignificant small negaive values if (dblchek(i) < -1.e-10_r8) then found = .true. - write(iulog,*) ' wetdapa_v1: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) endif end do if (found) then - call endrun('wetdapa_v1: negative values found') + errmsg = 'wetdapa_v1: negative values found' + errflg = 1 + return end if #endif @@ -987,237 +843,434 @@ subroutine wetdepa_v1( t, p, q, pdel, & end subroutine wetdepa_v1 -!============================================================================== - -! wetdepg is currently being used for both CAM4 and CAM5 by making use of the -! cam_physpkg_is method. - - subroutine wetdepg( t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, precs, evaps, & - rain, cwat, tracer, deltat, molwt, & - solconst, scavt, iscavt, cldv, icwmr1, & - icwmr2, fracis, ncol ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging of gas phase constituents by henry's law - ! - ! Author: P. Rasch - !----------------------------------------------------------------------- - - real(r8), intent(in) ::& - 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 - rain (pcols,pver), &! total rainwater mixing ratio - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - evaps(pcols,pver), &! rate of evaporation of precip -! Sungsu - evapc(pcols,pver), &! Rate of evaporation of convective precipitation -! Sungsu - cldv(pcols,pver), &! estimate of local volume occupied by clouds - icwmr1 (pcols,pver), &! in cloud water mixing ration for zhang scheme - icwmr2 (pcols,pver), &! in cloud water mixing ration for hack scheme - deltat, &! time step - tracer(pcols,pver), &! trace species - molwt ! molecular weights - - integer, intent(in) :: ncol - - real(r8) & - solconst(pcols,pver) ! Henry's law coefficient - - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols, pver) ! fraction of constituent that is insoluble - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatl ! local cloud liq water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) cwatpl ! local water amount falling from above precip (liq) - real(r8) cwatt ! local sum of strat + conv total water amount - real(r8) cwatti ! cwatt/cldv = cloudy grid volume mixing ratio - real(r8) fracev ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precab(pcols) ! precip from above (work array) - real(r8) precbl ! precip work variable - real(r8) precxx ! precip work variable - real(r8) precxx2 ! - real(r8) precic ! precip work variable - real(r8) rat ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - - real(r8) scavmax ! an estimate of the max tracer avail for removal - real(r8) scavbl ! flux removed at bottom of layer - real(r8) fins ! in cloud fraction removed by strat rain - real(r8) finc ! in cloud fraction removed by conv rain - real(r8) rate ! max removal rate estimate - real(r8) scavlimt ! limiting value 1 - real(r8) scavt1 ! limiting value 2 - real(r8) scavin ! scavenging by incloud processes - real(r8) scavbc ! scavenging by below cloud processes - real(r8) tc - real(r8) weight ! ice fraction - real(r8) wtpl ! work variable - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - !----------------------------------------------------------- - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! zero accumulators - do i = 1,pcols - precab(i) = 1.e-36_r8 - scavab(i) = 0._r8 - cldmabs(i) = 0._r8 - end do - - do k = 1,pver - 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 - - cldmabs(i) = max(cldmabs(i),cldt(i,k)) +!############################################################################## - ! partitioning coefs for gas and aqueous phase - ! take as a cloud water amount, the sum of the stratiform amount - ! plus the convective rain water amount - ! convective amnt is just the local precip rate from the hack scheme - ! since there is no storage of water, this ignores that falling from above - ! cwatc = cmfdqr(i,k)*deltat/adjfac - !++mcb -- test cwatc - cwatc = (icwmr1(i,k) + icwmr2(i,k)) * (1._r8-weight) - !--mcb +!############################################################################## - ! strat cloud water amount and also ignore the part falling from above - cwats = cwat(i,k) +! below cloud impaction scavenging coefs +subroutine get_bcscavcoefs( m, ncol, pver, isprx, diam_wet, scavcoefnum, scavcoefvol, aero_props ) + + integer,intent(in) :: m, ncol, pver + logical,intent(in):: isprx(:,:) + real(r8), intent(in) :: diam_wet(:,:) + real(r8), intent(out) :: scavcoefnum(:,:), scavcoefvol(:,:) + class(aerosol_properties), intent(in) :: aero_props + + integer i, k, jgrow + real(r8) dumdgratio, xgrow, dumfhi, dumflo, scavimpvol, scavimpnum + + do k = 1, pver + do i = 1, ncol + + ! do only if no precip + if ( isprx(i,k) .and. diam_wet(i,k)>0.0_r8) then + ! + ! interpolate table values using log of (actual-wet-size)/(base-dry-size) + + dumdgratio = diam_wet(i,k)/aero_props%scav_diam(m) + if ((dumdgratio >= 0.99_r8) .and. (dumdgratio <= 1.01_r8)) then + scavimpvol = scavimptblvol(0,m) + scavimpnum = scavimptblnum(0,m) + else + xgrow = log( dumdgratio ) / dlndg_nimptblgrow + jgrow = int( xgrow ) + if (xgrow < 0._r8) jgrow = jgrow - 1 + if (jgrow < nimptblgrow_mind) then + jgrow = nimptblgrow_mind + xgrow = jgrow + else + jgrow = min( jgrow, nimptblgrow_maxd-1 ) + end if + + dumfhi = xgrow - jgrow + dumflo = 1._r8 - dumfhi + + scavimpvol = dumflo*scavimptblvol(jgrow,m) + & + dumfhi*scavimptblvol(jgrow+1,m) + scavimpnum = dumflo*scavimptblnum(jgrow,m) + & + dumfhi*scavimptblnum(jgrow+1,m) + + end if + + ! impaction scavenging removal amount for volume + scavcoefvol(i,k) = exp( scavimpvol ) + ! impaction scavenging removal amount to number + scavcoefnum(i,k) = exp( scavimpnum ) + + else + scavcoefvol(i,k) = 0._r8 + scavcoefnum(i,k) = 0._r8 + end if + + end do + end do + +end subroutine get_bcscavcoefs - ! cloud water as liq - !++mcb -- add cwatc later (in cwatti) - ! cwatl = (1.-weight)*(cwatc+cwats) - cwatl = (1._r8-weight)*cwats - ! cloud water as ice - !*not used cwati = weight*(cwatc+cwats) +!############################################################################## - ! total suspended condensate as liquid - cwatt = cwatl + rain(i,k) +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ +subroutine init_bcscavcoef( aero_props, pi, boltz_cgs, rgas_cgs, & + errmsg, errflg ) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Computes lookup table for aerosol impaction/interception scavenging rates + ! + ! Authors: R. Easter + ! Simone Tilmes Nov 2021 + ! added modifications for bin model, assuming sigma = 1. + ! + !----------------------------------------------------------------------- + + class(aerosol_properties), intent(in) :: aero_props + real(r8), intent(in) :: pi ! ratio of circle circumference to diameter + real(r8), intent(in) :: boltz_cgs ! Boltzmann's constant (erg/K) + real(r8), intent(in) :: rgas_cgs ! universal gas constant (erg/mol/K) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer nnfit_maxd + parameter (nnfit_maxd=27) + + integer m, jgrow, nnfit + integer astat + + real(r8) dg0, dg0_cgs, press, dg0_base, & + rhodryaero, rhowetaero, rhowetaero_cgs, & + scavratenum, scavratevol, logsig, & + temp, wetdiaratio, wetvolratio + + real(r8) :: xxfitnum(1,nnfit_maxd), yyfitnum(nnfit_maxd) + real(r8) :: xxfitvol(1,nnfit_maxd), yyfitvol(nnfit_maxd) + + character(len=*), parameter :: subname = 'wetdep::init_bcscavcoef' + + errmsg = '' + errflg = 0 + + allocate(scavimptblnum(nimptblgrow_mind:nimptblgrow_maxd, aero_props%nbins()), stat=astat) + if (astat/=0) then + errmsg = subname//' : not able to allocate scavimptblnum array' + errflg = 1 + return + end if + allocate(scavimptblvol(nimptblgrow_mind:nimptblgrow_maxd, aero_props%nbins()), stat=astat) + if (astat/=0) then + errmsg = subname//' : not able to allocate scavimptblvol array' + errflg = 1 + return + end if + scavimptblnum = nan + scavimptblvol = nan - ! incloud version - !++mcb -- add cwatc here - cwatti = cwatt/max(cldv(i,k), 0.00001_r8) + cwatc + dlndg_nimptblgrow = log( 1.25_r8 ) - ! partitioning terms - patm = p(i,k)/1.013e5_r8 ! pressure in atmospheres - hconst = molwta*patm*solconst(i,k)*cwatti/rhoh2o - aqfrac = hconst/(1._r8+hconst) - gafrac = 1/(1._r8+hconst) - fracis(i,k) = gafrac + ! bin model: main loop over aerosol bins + modeloop: do m = 1, aero_props%nbins() - ! partial pressure of the tracer in the gridbox in atmospheres - part = patm*gafrac*tracer(i,k)*molwta/molwt + ! for setting up the lookup table, use the dry density of the first species + ! -- assume the first species of the mode/bin is the dominate species + call aero_props%get(m,1,density=rhodryaero) - ! use henrys law to give moles tracer /liter of water - ! in this volume - ! then convert to kg tracer /liter of water (kg tracer / kg water) - mplb = solconst(i,k)*part*molwt/1000._r8 + dg0_base = aero_props%scav_diam(m) + logsig = aero_props%alogsig(m) - pdog = pdel(i,k)/gravit + growloop: do jgrow = nimptblgrow_mind, nimptblgrow_maxd - ! this part of precip will be carried downward but at a new molarity of mpl - precic = pdog*(precs(i,k) + cmfdqr(i,k)) + wetdiaratio = exp( jgrow*dlndg_nimptblgrow ) + dg0 = dg0_base*wetdiaratio - ! we cant take out more than entered, plus that available in the cloud - ! scavmax = scavab(i)+tracer(i,k)*cldt(i,k)/deltat*pdog - scavmax = scavab(i)+tracer(i,k)*cldv(i,k)/deltat*pdog + wetvolratio = exp( jgrow*dlndg_nimptblgrow*3._r8 ) + rhowetaero = 1.0_r8 + (rhodryaero-1.0_r8)/wetvolratio + rhowetaero = min( rhowetaero, rhodryaero ) - ! flux of tracer by incloud processes - scavin = precic*(1._r8-weight)*mplb + ! + ! compute impaction scavenging rates at 1 temp-press pair and save + ! + nnfit = 0 - ! fraction of precip which entered above that leaves below - if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then - ! Sungsu added evaporation of convective precipitation below. - precxx = precab(i)-pdog*(evaps(i,k)+evapc(i,k)) - else - precxx = precab(i)-pdog*evaps(i,k) - end if - precxx = max (precxx,0.0_r8) - - ! flux of tracer by below cloud processes - !++mcb -- removed wtpl because it is now not assigned and previously - ! when it was assigned it was unnecessary: if(tc.gt.0)wtpl=1 - if (tc>0.0_r8) then - ! scavbc = precxx*wtpl*mplb ! if liquid - scavbc = precxx*mplb ! if liquid - else - precxx2=max(precxx,1.e-36_r8) - scavbc = scavab(i)*precxx2/(precab(i)) ! if ice - endif - - scavbl = min(scavbc + scavin, scavmax) - - ! first guess assuming that henries law works - scavt1 = (scavab(i)-scavbl)/pdog*omsm - - ! pjr this should not be required, but we put it in to make sure we cant remove too much - ! remember, scavt1 is generally negative (indicating removal) - scavt1 = max(scavt1,-tracer(i,k)*cldv(i,k)/deltat) + temp = 273.16_r8 + press = 0.75e6_r8 ! dynes/cm2 + rhowetaero = rhodryaero - !++mcb -- remove this limitation for gas species - !c use the dana and hales or balkanski limit on scavenging - !c rate = precab(i)*0.1 - ! rate = (precic + precxx)*0.1 - ! scavlimt = -tracer(i,k)*cldv(i,k) - ! $ *rate/(1.+rate*deltat) + dg0_cgs = dg0*1.0e2_r8 ! m to cm - ! scavt(i,k) = max(scavt1, scavlimt) + rhowetaero_cgs = rhowetaero*1.0e-3_r8 ! kg/m3 to g/cm3 - ! instead just set scavt to scavt1 - scavt(i,k) = scavt1 - !--mcb + call calc_1_impact_rate( & + dg0_cgs, logsig, rhowetaero_cgs, temp, press, & + scavratenum, scavratevol, & + pi, boltz_cgs, rgas_cgs, errmsg, errflg ) + if (errflg /= 0) return - ! now update the amount leaving the layer - scavbl = scavab(i) - scavt(i,k)*pdog + nnfit = nnfit + 1 + if (nnfit > nnfit_maxd) then + errmsg = subname//' : nnfit > nnfit_maxd' + errflg = 1 + return + end if - ! in cloud amount is that formed locally over the total flux out bottom - fins = scavin/(scavin + scavbc + 1.e-36_r8) - iscavt(i,k) = scavt(i,k)*fins + xxfitnum(1,nnfit) = 1._r8 + yyfitnum(nnfit) = log( scavratenum ) - scavab(i) = scavbl - precab(i) = max(precxx + precic,1.e-36_r8) + xxfitvol(1,nnfit) = 1._r8 + yyfitvol(nnfit) = log( scavratevol ) + !depends on both bins and different species + scavimptblnum(jgrow,m) = yyfitnum(1) + scavimptblvol(jgrow,m) = yyfitvol(1) + enddo growloop + enddo modeloop - end do - end do +contains - end subroutine wetdepg + !=============================================================================== + subroutine calc_1_impact_rate( & + dg0, logsig, rhoaero, temp, press, & + scavratenum, scavratevol, & + pi, boltz_cgs, rgas, errmsg, errflg ) + ! + ! routine computes a single impaction scavenging rate + ! for precipitation rate of 1 mm/h + ! + ! dg0 = geometric mean diameter of aerosol number size distrib. (cm) + ! sigmag = geometric standard deviation of size distrib. + ! rhoaero = density of aerosol particles (g/cm^3) + ! temp = temperature (K) + ! press = pressure (dyne/cm^2) + ! scavratenum = number scavenging rate (1/h) + ! scavratevol = volume or mass scavenging rate (1/h) + ! errmsg/errflg = error message and flag (returned on error) + ! + + implicit none + + ! subr. parameters + real(r8), intent(in) :: dg0, logsig, rhoaero, temp, press + real(r8), intent(out) :: scavratenum, scavratevol + real(r8), intent(in) :: pi ! ratio of circle circumference to diameter + real(r8), intent(in) :: boltz_cgs ! Boltzmann's constant (erg/K) + real(r8), intent(in) :: rgas ! universal gas constant (erg/mol/K) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer nrainsvmax + parameter (nrainsvmax=50) + real(r8) rrainsv(nrainsvmax), xnumrainsv(nrainsvmax),& + vfallrainsv(nrainsvmax) + + integer naerosvmax + parameter (naerosvmax=51) + real(r8) aaerosv(naerosvmax), & + ynumaerosv(naerosvmax), yvolaerosv(naerosvmax) + + integer i, ja, jr, na, nr + real(r8) a, aerodiffus, aeromass, ag0, airdynvisc, airkinvisc + real(r8) anumsum, avolsum, cair, chi + real(r8) d, dr, dum, dumfuchs, dx + real(r8) ebrown, eimpact, eintercept, etotal, freepath + real(r8) precip, precipmmhr, precipsum + real(r8) r, rainsweepout, reynolds, rhi, rhoair, rlo, rnumsum + real(r8) scavsumnum, scavsumnumbb + real(r8) scavsumvol, scavsumvolbb + real(r8) schmidt, sqrtreynolds, sstar, stokes, sx + real(r8) taurelax, vfall, vfallstp + real(r8) x, xg0, xg3, xhi, xlo, xmuwaterair + + errmsg = '' + errflg = 0 + + rlo = .005_r8 + rhi = .250_r8 + dr = 0.005_r8 + nr = 1 + nint( (rhi-rlo)/dr ) + if (nr > nrainsvmax) then + errmsg = subname//' : nr > nrainsvmax' + errflg = 1 + return + end if + + precipmmhr = 1.0_r8 + precip = precipmmhr/36000._r8 + + ag0 = dg0/2._r8 + sx = logsig + xg0 = log( ag0 ) + xg3 = xg0 + 3._r8*sx*sx + + xlo = xg3 - 4._r8*sx + xhi = xg3 + 4._r8*sx + dx = 0.2_r8*sx + + dx = max( 0.2_r8*sx, 0.01_r8 ) + xlo = xg3 - max( 4._r8*sx, 2._r8*dx ) + xhi = xg3 + max( 4._r8*sx, 2._r8*dx ) + + na = 1 + nint( (xhi-xlo)/dx ) + if (na > naerosvmax) then + errmsg = subname//' : na > naerosvmax' + errflg = 1 + return + end if + + ! air molar density + cair = press/(rgas*temp) + ! air mass density + rhoair = 28.966_r8*cair + ! molecular freepath + freepath = 2.8052e-10_r8/cair + ! air dynamic viscosity + airdynvisc = 1.8325e-4_r8 * (416.16_r8/(temp+120._r8)) * & + ((temp/296.16_r8)**1.5_r8) + ! air kinemaic viscosity + airkinvisc = airdynvisc/rhoair + ! ratio of water viscosity to air viscosity (from Slinn) + xmuwaterair = 60.0_r8 + + ! + ! compute rain drop number concentrations + ! rrainsv = raindrop radius (cm) + ! xnumrainsv = raindrop number concentration (#/cm^3) + ! (number in the bin, not number density) + ! vfallrainsv = fall velocity (cm/s) + ! + precipsum = 0._r8 + do i = 1, nr + r = rlo + (i-1)*dr + rrainsv(i) = r + xnumrainsv(i) = exp( -r/2.7e-2_r8 ) + + d = 2._r8*r + if (d <= 0.007_r8) then + vfallstp = 2.88e5_r8 * d**2._r8 + else if (d <= 0.025_r8) then + vfallstp = 2.8008e4_r8 * d**1.528_r8 + else if (d <= 0.1_r8) then + vfallstp = 4104.9_r8 * d**1.008_r8 + else if (d <= 0.25_r8) then + vfallstp = 1812.1_r8 * d**0.638_r8 + else + vfallstp = 1069.8_r8 * d**0.235_r8 + end if + + vfall = vfallstp * sqrt(1.204e-3_r8/rhoair) + vfallrainsv(i) = vfall + precipsum = precipsum + vfall*(r**3)*xnumrainsv(i) + end do + precipsum = precipsum*pi*1.333333_r8 + + rnumsum = 0._r8 + do i = 1, nr + xnumrainsv(i) = xnumrainsv(i)*(precip/precipsum) + rnumsum = rnumsum + xnumrainsv(i) + end do + + ! + ! compute aerosol concentrations + ! aaerosv = particle radius (cm) + ! fnumaerosv = fraction of total number in the bin (--) + ! fvolaerosv = fraction of total volume in the bin (--) + ! + anumsum = 0._r8 + avolsum = 0._r8 + do i = 1, na + x = xlo + (i-1)*dx + a = exp( x ) + aaerosv(i) = a + dum = (x - xg0)/sx + ynumaerosv(i) = exp( -0.5_r8*dum*dum ) + yvolaerosv(i) = ynumaerosv(i)*1.3333_r8*pi*a*a*a + anumsum = anumsum + ynumaerosv(i) + avolsum = avolsum + yvolaerosv(i) + end do + + do i = 1, na + ynumaerosv(i) = ynumaerosv(i)/anumsum + yvolaerosv(i) = yvolaerosv(i)/avolsum + end do + + ! + ! compute scavenging + ! + scavsumnum = 0._r8 + scavsumvol = 0._r8 + ! + ! outer loop for rain drop radius + ! + jr_loop: do jr = 1, nr + + r = rrainsv(jr) + vfall = vfallrainsv(jr) + + reynolds = r * vfall / airkinvisc + sqrtreynolds = sqrt( reynolds ) + + ! + ! inner loop for aerosol particle radius + ! + scavsumnumbb = 0._r8 + scavsumvolbb = 0._r8 + + ja_loop: do ja = 1, na + + a = aaerosv(ja) + + chi = a/r + + dum = freepath/a + dumfuchs = 1._r8 + 1.246_r8*dum + 0.42_r8*dum*exp(-0.87_r8/dum) + taurelax = 2._r8*rhoaero*a*a*dumfuchs/(9._r8*rhoair*airkinvisc) + + aeromass = 4._r8*pi*a*a*a*rhoaero/3._r8 + aerodiffus = boltz_cgs*temp*taurelax/aeromass + + schmidt = airkinvisc/aerodiffus + stokes = vfall*taurelax/r + + ebrown = 4._r8*(1._r8 + 0.4_r8*sqrtreynolds*(schmidt**0.3333333_r8)) / & + (reynolds*schmidt) + + dum = (1._r8 + 2._r8*xmuwaterair*chi) / & + (1._r8 + xmuwaterair/sqrtreynolds) + eintercept = 4._r8*chi*(chi + dum) + + dum = log( 1._r8 + reynolds ) + sstar = (1.2_r8 + dum/12._r8) / (1._r8 + dum) + eimpact = 0._r8 + if (stokes > sstar) then + dum = stokes - sstar + eimpact = (dum/(dum+0.6666667_r8)) ** 1.5_r8 + end if + + etotal = ebrown + eintercept + eimpact + etotal = min( etotal, 1.0_r8 ) + + rainsweepout = xnumrainsv(jr)*4._r8*pi*r*r*vfall + + scavsumnumbb = scavsumnumbb + rainsweepout*etotal*ynumaerosv(ja) + scavsumvolbb = scavsumvolbb + rainsweepout*etotal*yvolaerosv(ja) + + enddo ja_loop + + scavsumnum = scavsumnum + scavsumnumbb + scavsumvol = scavsumvol + scavsumvolbb + + enddo jr_loop + + scavratenum = scavsumnum*3600._r8 + scavratevol = scavsumvol*3600._r8 + + end subroutine calc_1_impact_rate + +end subroutine init_bcscavcoef !############################################################################## diff --git a/src/chemistry/aerosol/wetdep_cam.F90 b/src/chemistry/aerosol/wetdep_cam.F90 new file mode 100644 index 0000000000..157d71dd81 --- /dev/null +++ b/src/chemistry/aerosol/wetdep_cam.F90 @@ -0,0 +1,402 @@ +module wetdep_cam + +!----------------------------------------------------------------------- +! +! CAM host interface for the portable wetdep module. Gathers the wetdepa +! inputs from the physics state/pbuf (wetdep_inputs_t / wetdep_init / +! wetdep_inputs_set) and retains wetdepg (gas-phase Henry's-law scavenging), +! which has no portable caller. +! +!----------------------------------------------------------------------- + +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only: pcols, pver +use physconst, only: gravit, rair, tmelt +use phys_control, only: cam_physpkg_is + +use wetdep, only: clddiag + +implicit none +save +private + +public :: wetdepg ! scavenging of gas phase constituents by henry's law +public :: wetdep_inputs_t +public :: wetdep_init +public :: wetdep_inputs_set + +real(r8), parameter :: cmftau = 3600._r8 +real(r8), parameter :: rhoh2o = 1000._r8 ! density of water +real(r8), parameter :: molwta = 28.97_r8 ! molecular weight dry air gm/mole +real(r8), parameter :: omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero + +type wetdep_inputs_t + real(r8), pointer :: cldt(:,:) => null() ! cloud fraction + real(r8), pointer :: prain(:,:) => null() + real(r8), pointer :: bergso(:,:) => null() + real(r8), pointer :: evapr(:,:) => null() + real(r8) :: cldcu(pcols,pver) ! convective cloud fraction, currently empty + real(r8) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation + real(r8) :: cmfdqr(pcols,pver) ! convective production of rain + real(r8) :: conicw(pcols,pver) ! convective in-cloud water + real(r8) :: totcond(pcols, pver) ! total condensate + real(r8) :: cldv(pcols,pver) ! cloudy volume undergoing wet chem and scavenging + real(r8) :: cldvcu(pcols,pver) ! Convective precipitation area at the top interface of current layer + real(r8) :: cldvst(pcols,pver) ! Stratiform precipitation area at the top interface of current layer +end type wetdep_inputs_t + +integer :: cld_idx = 0 +integer :: prain_idx = 0 +integer :: bergso_idx = 0 +integer :: nevapr_idx = 0 + +integer :: icwmrdp_idx = 0 +integer :: icwmrsh_idx = 0 +integer :: rprddp_idx = 0 +integer :: rprdsh_idx = 0 +integer :: sh_frac_idx = 0 +integer :: dp_frac_idx = 0 +integer :: nevapr_shcu_idx = 0 +integer :: nevapr_dpcu_idx = 0 +integer :: ixcldice, ixcldliq + +!============================================================================== +contains +!============================================================================== + +!============================================================================== +!============================================================================== +subroutine wetdep_init() + use physics_buffer, only: pbuf_get_index + use constituents, only: cnst_get_ind + + integer :: ierr + + cld_idx = pbuf_get_index('CLD') + prain_idx = pbuf_get_index('PRAIN') + bergso_idx = pbuf_get_index('BERGSO', errcode=ierr ) + nevapr_idx = pbuf_get_index('NEVAPR') + + icwmrdp_idx = pbuf_get_index('ICWMRDP') + rprddp_idx = pbuf_get_index('RPRDDP') + icwmrsh_idx = pbuf_get_index('ICWMRSH') + rprdsh_idx = pbuf_get_index('RPRDSH') + sh_frac_idx = pbuf_get_index('SH_FRAC' ) + dp_frac_idx = pbuf_get_index('DP_FRAC') + nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') + nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') + + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('CLDLIQ', ixcldliq) + +endsubroutine wetdep_init + +!============================================================================== +! gathers up the inputs needed for the wetdepa routines +!============================================================================== +subroutine wetdep_inputs_set( state, pbuf, inputs ) + use physics_types, only: physics_state + use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx + + ! args + + type(physics_state), intent(in ) :: state !! physics state + type(physics_buffer_desc), pointer :: pbuf(:) !! physics buffer + type(wetdep_inputs_t), intent(out) :: inputs !! collection of wetdepa inputs + + ! local vars + + real(r8), pointer :: icwmrdp(:,:) ! in cloud water mixing ratio, deep convection + real(r8), pointer :: rprddp(:,:) ! rain production, deep convection + real(r8), pointer :: icwmrsh(:,:) ! in cloud water mixing ratio, deep convection + real(r8), pointer :: rprdsh(:,:) ! rain production, deep convection + real(r8), pointer :: sh_frac(:,:) ! Shallow convective cloud fraction + real(r8), pointer :: dp_frac(:,:) ! Deep convective cloud fraction + real(r8), pointer :: evapcsh(:,:) ! Evaporation rate of shallow convective precipitation >=0. + real(r8), pointer :: evapcdp(:,:) ! Evaporation rate of deep convective precipitation >=0. + + real(r8) :: rainmr(pcols,pver) ! mixing ratio of rain within cloud volume + real(r8) :: cldst(pcols,pver) ! Stratiform cloud fraction + + integer :: itim, ncol + + ncol = state%ncol + itim = pbuf_old_tim_idx() + + call pbuf_get_field(pbuf, cld_idx, inputs%cldt, start=(/1,1,itim/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, prain_idx, inputs%prain ) + call pbuf_get_field(pbuf, nevapr_idx, inputs%evapr ) + call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp ) + call pbuf_get_field(pbuf, icwmrsh_idx, icwmrsh ) + call pbuf_get_field(pbuf, rprddp_idx, rprddp ) + call pbuf_get_field(pbuf, rprdsh_idx, rprdsh ) + call pbuf_get_field(pbuf, sh_frac_idx, sh_frac ) + call pbuf_get_field(pbuf, dp_frac_idx, dp_frac ) + call pbuf_get_field(pbuf, nevapr_shcu_idx, evapcsh ) + call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) + + if (bergso_idx>0) then + call pbuf_get_field(pbuf, bergso_idx, inputs%bergso ) + else + if (.not. associated(inputs%bergso)) then + allocate(inputs%bergso(pcols,pver)) + inputs%bergso(:,:) = 0.0_r8 + endif + endif + + inputs%cldcu(:ncol,:) = dp_frac(:ncol,:) + sh_frac(:ncol,:) + cldst(:ncol,:) = inputs%cldt(:ncol,:) - inputs%cldcu(:ncol,:) ! Stratiform cloud fraction + inputs%evapc(:ncol,:) = evapcsh(:ncol,:) + evapcdp(:ncol,:) + inputs%cmfdqr(:ncol,:) = rprddp(:ncol,:) + rprdsh(:ncol,:) + + ! sum deep and shallow convection contributions + if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then + ! Dec.29.2009. Sungsu + inputs%conicw(:ncol,:) = (icwmrdp(:ncol,:)*dp_frac(:ncol,:) + icwmrsh(:ncol,:)*sh_frac(:ncol,:))/ & + max(0.01_r8, sh_frac(:ncol,:) + dp_frac(:ncol,:)) + else + inputs%conicw(:ncol,:) = icwmrdp(:ncol,:) + icwmrsh(:ncol,:) + end if + + inputs%totcond(:ncol,:) = state%q(:ncol,:,ixcldliq) + state%q(:ncol,:,ixcldice) + + call clddiag( state%t, state%pmid, state%pdel, inputs%cmfdqr, inputs%evapc, & + inputs%cldt, inputs%cldcu, cldst, inputs%evapr, & + inputs%prain, inputs%cldv, inputs%cldvcu, inputs%cldvst, rainmr, & + state%ncol, pver, gravit, tmelt, rair ) + +end subroutine wetdep_inputs_set + +!============================================================================== + +! wetdepg is currently being used for both CAM4 and CAM5 by making use of the +! cam_physpkg_is method. + + subroutine wetdepg( t, p, q, pdel, & + cldt, cldc, cmfdqr, evapc, precs, evaps, & + rain, cwat, tracer, deltat, molwt, & + solconst, scavt, iscavt, cldv, icwmr1, & + icwmr2, fracis, ncol ) + + !----------------------------------------------------------------------- + ! Purpose: + ! scavenging of gas phase constituents by henry's law + ! + ! Author: P. Rasch + !----------------------------------------------------------------------- + + real(r8), intent(in) ::& + 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 + rain (pcols,pver), &! total rainwater mixing ratio + cwat(pcols,pver), &! cloud water amount + precs(pcols,pver), &! rate of production of stratiform precip + evaps(pcols,pver), &! rate of evaporation of precip +! Sungsu + evapc(pcols,pver), &! Rate of evaporation of convective precipitation +! Sungsu + cldv(pcols,pver), &! estimate of local volume occupied by clouds + icwmr1 (pcols,pver), &! in cloud water mixing ration for zhang scheme + icwmr2 (pcols,pver), &! in cloud water mixing ration for hack scheme + deltat, &! time step + tracer(pcols,pver), &! trace species + molwt ! molecular weights + + integer, intent(in) :: ncol + + real(r8) & + solconst(pcols,pver) ! Henry's law coefficient + + real(r8), intent(out) ::& + scavt(pcols,pver), &! scavenging tend + iscavt(pcols,pver), &! incloud scavenging tends + fracis(pcols, pver) ! fraction of constituent that is insoluble + + ! local variables + + integer i ! x index + integer k ! z index + + real(r8) adjfac ! factor stolen from cmfmca + real(r8) aqfrac ! fraction of tracer in aqueous phase + real(r8) cwatc ! local convective total water amount + real(r8) cwats ! local stratiform total water amount + real(r8) cwatl ! local cloud liq water amount + real(r8) cwatp ! local water amount falling from above precip + real(r8) cwatpl ! local water amount falling from above precip (liq) + real(r8) cwatt ! local sum of strat + conv total water amount + real(r8) cwatti ! cwatt/cldv = cloudy grid volume mixing ratio + real(r8) fracev ! fraction of precip from above that is evaporating + real(r8) fracp ! fraction of cloud water converted to precip + real(r8) gafrac ! fraction of tracer in gas phasea + real(r8) hconst ! henry's law solubility constant when equation is expressed + ! in terms of mixing ratios + real(r8) mpla ! moles / liter H2O entering the layer from above + real(r8) mplb ! moles / liter H2O leaving the layer below + real(r8) part ! partial pressure of tracer in atmospheres + real(r8) patm ! total pressure in atmospheres + real(r8) pdog ! work variable (pdel/gravit) + real(r8) precab(pcols) ! precip from above (work array) + real(r8) precbl ! precip work variable + real(r8) precxx ! precip work variable + real(r8) precxx2 ! + real(r8) precic ! precip work variable + real(r8) rat ! ratio of amount available to amount removed + real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) + real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) + + real(r8) scavmax ! an estimate of the max tracer avail for removal + real(r8) scavbl ! flux removed at bottom of layer + real(r8) fins ! in cloud fraction removed by strat rain + real(r8) finc ! in cloud fraction removed by conv rain + real(r8) rate ! max removal rate estimate + real(r8) scavlimt ! limiting value 1 + real(r8) scavt1 ! limiting value 2 + real(r8) scavin ! scavenging by incloud processes + real(r8) scavbc ! scavenging by below cloud processes + real(r8) tc + real(r8) weight ! ice fraction + real(r8) wtpl ! work variable + real(r8) cldmabs(pcols) ! maximum cloud at or above this level + real(r8) cldmabc(pcols) ! maximum cloud at or above this level + !----------------------------------------------------------- + + adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme + + ! zero accumulators + do i = 1,pcols + precab(i) = 1.e-36_r8 + scavab(i) = 0._r8 + cldmabs(i) = 0._r8 + end do + + do k = 1,pver + 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 + + cldmabs(i) = max(cldmabs(i),cldt(i,k)) + + ! partitioning coefs for gas and aqueous phase + ! take as a cloud water amount, the sum of the stratiform amount + ! plus the convective rain water amount + + ! convective amnt is just the local precip rate from the hack scheme + ! since there is no storage of water, this ignores that falling from above + ! cwatc = cmfdqr(i,k)*deltat/adjfac + !++mcb -- test cwatc + cwatc = (icwmr1(i,k) + icwmr2(i,k)) * (1._r8-weight) + !--mcb + + ! strat cloud water amount and also ignore the part falling from above + cwats = cwat(i,k) + + ! cloud water as liq + !++mcb -- add cwatc later (in cwatti) + ! cwatl = (1.-weight)*(cwatc+cwats) + cwatl = (1._r8-weight)*cwats + ! cloud water as ice + !*not used cwati = weight*(cwatc+cwats) + + ! total suspended condensate as liquid + cwatt = cwatl + rain(i,k) + + ! incloud version + !++mcb -- add cwatc here + cwatti = cwatt/max(cldv(i,k), 0.00001_r8) + cwatc + + ! partitioning terms + patm = p(i,k)/1.013e5_r8 ! pressure in atmospheres + hconst = molwta*patm*solconst(i,k)*cwatti/rhoh2o + aqfrac = hconst/(1._r8+hconst) + gafrac = 1/(1._r8+hconst) + fracis(i,k) = gafrac + + + ! partial pressure of the tracer in the gridbox in atmospheres + part = patm*gafrac*tracer(i,k)*molwta/molwt + + ! use henrys law to give moles tracer /liter of water + ! in this volume + ! then convert to kg tracer /liter of water (kg tracer / kg water) + mplb = solconst(i,k)*part*molwt/1000._r8 + + + pdog = pdel(i,k)/gravit + + ! this part of precip will be carried downward but at a new molarity of mpl + precic = pdog*(precs(i,k) + cmfdqr(i,k)) + + ! we cant take out more than entered, plus that available in the cloud + ! scavmax = scavab(i)+tracer(i,k)*cldt(i,k)/deltat*pdog + scavmax = scavab(i)+tracer(i,k)*cldv(i,k)/deltat*pdog + + ! flux of tracer by incloud processes + scavin = precic*(1._r8-weight)*mplb + + ! fraction of precip which entered above that leaves below + if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then + ! Sungsu added evaporation of convective precipitation below. + precxx = precab(i)-pdog*(evaps(i,k)+evapc(i,k)) + else + precxx = precab(i)-pdog*evaps(i,k) + end if + precxx = max (precxx,0.0_r8) + + ! flux of tracer by below cloud processes + !++mcb -- removed wtpl because it is now not assigned and previously + ! when it was assigned it was unnecessary: if(tc.gt.0)wtpl=1 + if (tc>0.0_r8) then + ! scavbc = precxx*wtpl*mplb ! if liquid + scavbc = precxx*mplb ! if liquid + else + precxx2=max(precxx,1.e-36_r8) + scavbc = scavab(i)*precxx2/(precab(i)) ! if ice + endif + + scavbl = min(scavbc + scavin, scavmax) + + ! first guess assuming that henries law works + scavt1 = (scavab(i)-scavbl)/pdog*omsm + + ! pjr this should not be required, but we put it in to make sure we cant remove too much + ! remember, scavt1 is generally negative (indicating removal) + scavt1 = max(scavt1,-tracer(i,k)*cldv(i,k)/deltat) + + !++mcb -- remove this limitation for gas species + !c use the dana and hales or balkanski limit on scavenging + !c rate = precab(i)*0.1 + ! rate = (precic + precxx)*0.1 + ! scavlimt = -tracer(i,k)*cldv(i,k) + ! $ *rate/(1.+rate*deltat) + + ! scavt(i,k) = max(scavt1, scavlimt) + + ! instead just set scavt to scavt1 + scavt(i,k) = scavt1 + !--mcb + + ! now update the amount leaving the layer + scavbl = scavab(i) - scavt(i,k)*pdog + + ! in cloud amount is that formed locally over the total flux out bottom + fins = scavin/(scavin + scavbc + 1.e-36_r8) + iscavt(i,k) = scavt(i,k)*fins + + scavab(i) = scavbl + precab(i) = max(precxx + precic,1.e-36_r8) + + + + end do + end do + + end subroutine wetdepg + +end module wetdep_cam diff --git a/src/chemistry/bulk_aero/aero_model.F90 b/src/chemistry/bulk_aero/aero_model.F90 index 4d05083a68..3e97116513 100644 --- a/src/chemistry/bulk_aero/aero_model.F90 +++ b/src/chemistry/bulk_aero/aero_model.F90 @@ -12,7 +12,7 @@ module aero_model use aerodep_flx, only: aerodep_flx_prescribed use physics_types, only: physics_state, physics_ptend, physics_ptend_init use physics_buffer, only: physics_buffer_desc - use physconst, only: gravit, rair + use physconst, only: gravit, rair, tmelt use dust_model, only: dust_active, dust_names, dust_nbin use seasalt_model, only: sslt_active=>seasalt_active, seasalt_names, seasalt_nbin use spmd_utils, only: masterproc @@ -154,10 +154,9 @@ subroutine aero_model_init( pbuf2d ) use mo_setsoa, only: soa_inti use dust_model, only: dust_init use seasalt_model, only: seasalt_init - use aer_drydep_mod, only: inidrydep - use wetdep, only: wetdep_init - use mo_setsox, only: has_sox - use mo_setsox, only: sox_inti + use wetdep_cam, only: wetdep_init + use mo_setsox_cam, only: has_sox + use mo_setsox_cam, only: sox_inti ! args type(physics_buffer_desc), pointer :: pbuf2d(:,:) @@ -278,8 +277,6 @@ subroutine aero_model_init( pbuf2d ) if (ndrydep>0) then - call inidrydep(rair, gravit) - dummy = 'RAM1' call addfld (dummy,horiz_only, 'A','frac','RAM1') if ( history_aerosol ) then @@ -424,7 +421,7 @@ end subroutine aero_model_init subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend ) use dust_sediment_mod, only: dust_sediment_tend - use aer_drydep_mod, only: d3ddflux, calcram + use aero_drydep_core, only: calcram use dust_model, only: dust_depvel, dust_nbin, dust_names use seasalt_model, only: sslt_depvel=>seasalt_depvel, sslt_nbin=>seasalt_nbin, sslt_names=>seasalt_names @@ -472,11 +469,13 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, real(r8) :: pvaeros(pcols,pverp) ! sedimentation velocity in Pa real(r8) :: sflx(pcols) - real(r8) :: tvs(pcols,pver) real(r8) :: rho(pcols,pver) ! air density in kg/m3 integer :: m,mm, i, im + character(len=512) :: errmsg + integer :: errflg + if (ndrydep<1) return landfrac => cam_in%landfrac(:) @@ -491,7 +490,7 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ! calc ram and fv over ocean and sea ice ... call calcram( ncol,landfrac,icefrac,ocnfrac,obklen,& ustar,ram1in,ram1,state%t(:,pver),state%pmid(:,pver),& - state%pdel(:,pver),fvin,fv) + state%pdel(:,pver),fvin,fv,rair,gravit) call outfld( 'airFV', fv(:), pcols, lchnk ) call outfld( 'RAM1', ram1(:), pcols, lchnk ) @@ -507,7 +506,6 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, lchnk = state%lchnk ncol = state%ncol - tvs(:ncol,:) = state%t(:ncol,:) rho(:ncol,:) = state%pmid(:ncol,:)/(rair*state%t(:ncol,:)) ! compute dep velocities for sea salt and dust... @@ -536,18 +534,16 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, call outfld( trim(cnst_name(mm))//'DV', pvaeros(:,2:pverp), pcols, lchnk ) - if(.true.) then ! use phil's method - ! convert from meters/sec to pascals/sec - ! pvaeros(:,1) is assumed zero, use density from layer above in conversion - pvaeros(:ncol,2:pverp) = pvaeros(:ncol,2:pverp) * rho(:ncol,:)*gravit - - ! calculate the tendencies and sfc fluxes from the above velocities - call dust_sediment_tend( & - ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & - state%q(:,:,mm) , pvaeros , ptend%q(:,:,mm), sflx ) - else !use charlie's method - call d3ddflux(ncol, vlc_dry(:,:,im), state%q(:,:,mm),state%pmid,state%pdel, tvs,sflx,ptend%q(:,:,mm),dt) - endif + ! convert from meters/sec to pascals/sec + ! pvaeros(:,1) is assumed zero, use density from layer above in conversion + pvaeros(:ncol,2:pverp) = pvaeros(:ncol,2:pverp) * rho(:ncol,:)*gravit + + ! calculate the tendencies and sfc fluxes from the above velocities + call dust_sediment_tend( & + ncol, dt, state%pint(:,:), state%pdel, & + state%q(:,:,mm) , pvaeros , ptend%q(:,:,mm), sflx, & + pver, gravit, errmsg, errflg ) + if (errflg /= 0) call endrun('aero_model_drydep: '//trim(errmsg)) ! apportion dry deposition into turb and gravitational settling for tapes do i=1,ncol dep_trb(i)=sflx(i)*vlc_trb(i,im)/vlc_dry(i,pver,im) @@ -595,7 +591,8 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, !============================================================================= subroutine aero_model_wetdep( state, dt, dlf, cam_out, ptend, pbuf) - use wetdep, only : wetdepa_v1, wetdep_inputs_set, wetdep_inputs_t + use wetdep, only : wetdepa_v1 + use wetdep_cam, only : wetdep_inputs_set, wetdep_inputs_t use dust_model, only : dust_names use seasalt_model, only : sslt_names=>seasalt_names @@ -628,6 +625,8 @@ subroutine aero_model_wetdep( state, dt, dlf, cam_out, ptend, pbuf) real(r8) :: bsscavt(pcols, pver) real(r8) :: sol_factb, sol_facti + character(len=512) :: errmsg ! error handling for the portable wetdepa_v1 + integer :: errflg real(r8) :: rainmr(pcols,pver) ! mixing ratio of rain within cloud volume real(r8) :: cldv(pcols,pver) ! cloudy volume undergoing scavenging @@ -661,15 +660,16 @@ subroutine aero_model_wetdep( state, dt, dlf, cam_out, ptend, pbuf) scavcoef(:ncol,:) = aer_scav_coef(m) - call wetdepa_v1( state%t, state%pmid, state%q(:,:,1), state%pdel, & - dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & - dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & + call wetdepa_v1( state%t, state%pdel, & + dep_inputs%cldt, dep_inputs%cmfdqr, & + dep_inputs%conicw, dep_inputs%prain, & dep_inputs%evapr, dep_inputs%totcond, state%q(:,:,mm), dt, & scavt, iscavt, dep_inputs%cldv, & fracis(:,:,mm), sol_factb, ncol, & - scavcoef, & + scavcoef, tmelt, gravit, pver, errmsg, errflg, & sol_facti_in=sol_facti, & icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt ) + if (errflg /= 0) call endrun(trim(errmsg)) ptend%q(:ncol,:,mm)=scavt(:ncol,:) @@ -1058,7 +1058,7 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re use chem_mods, only : gas_pcnst use mo_aerosols, only : aerosols_formation, has_aerosols - use mo_setsox, only : setsox, has_sox + use mo_setsox_cam, only : setsox, has_sox use mo_setsoa, only : setsoa, has_soa use aerosol_state_mod, only : aerosol_state diff --git a/src/chemistry/bulk_aero/dust_model.F90 b/src/chemistry/bulk_aero/dust_model.F90 index 6b559200c6..f69b911329 100644 --- a/src/chemistry/bulk_aero/dust_model.F90 +++ b/src/chemistry/bulk_aero/dust_model.F90 @@ -108,8 +108,11 @@ subroutine dust_init() use soil_erod_mod, only: soil_erod_init use constituents, only: cnst_get_ind use dust_common, only: dust_set_params + use physconst, only: pi, rair, gravit integer :: n + character(len=256) :: errmsg + integer :: errflg do n = 1, dust_nbin call cnst_get_ind(dust_names(n), dust_indices(n),abort=.false.) @@ -121,7 +124,11 @@ subroutine dust_init() call soil_erod_init( dust_emis_fact, soil_erod_file ) endif - call dust_set_params( dust_nbin, dust_dmt_grd, dust_dmt_vwr, dust_stk_crc ) + call dust_set_params( dust_nbin, dust_dmt_grd, dust_dmt_vwr, dust_stk_crc, & + pi, rair, gravit, errmsg, errflg ) + if (errflg /= 0) then + call endrun('dust_init: '//trim(errmsg)) + end if end subroutine dust_init diff --git a/src/chemistry/carma_aero/aero_model.F90 b/src/chemistry/carma_aero/aero_model.F90 index dc2f57dd05..d84de075e0 100644 --- a/src/chemistry/carma_aero/aero_model.F90 +++ b/src/chemistry/carma_aero/aero_model.F90 @@ -22,7 +22,7 @@ module aero_model use radiative_aerosol, only: rad_aer_get_info, rad_aer_get_info_by_bin, rad_aer_get_info_by_bin_spec, & rad_aer_get_bin_props_by_idx use aerosol_mmr_host, only: rad_cnst_get_bin_mmr_by_idx - use mo_setsox, only: setsox, has_sox + use mo_setsox_cam, only: setsox, has_sox use aerosol_properties_mod, only: aerosol_properties use aerosol_instances_mod, only: aerosol_instances_get_props, & aerosol_instances_get_state, aerosol_instances_get_num_models @@ -198,7 +198,7 @@ subroutine aero_model_init( pbuf2d ) use cam_history, only: addfld, add_default, horiz_only use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx use aero_wetdep_cam, only: aero_wetdep_init - use mo_setsox, only: sox_inti + use mo_setsox_cam, only: sox_inti use carma_aero_gasaerexch, only: carma_aero_gasaerexch_init use time_manager, only: is_first_step diff --git a/src/chemistry/geoschem/chemistry.F90 b/src/chemistry/geoschem/chemistry.F90 index 8c54d071f9..9ea6c33b8d 100644 --- a/src/chemistry/geoschem/chemistry.F90 +++ b/src/chemistry/geoschem/chemistry.F90 @@ -997,7 +997,7 @@ subroutine chem_init(phys_state, pbuf2d) use tracer_srcs, only : tracer_srcs_init #if defined( MODAL_AERO ) use aero_model, only : aero_model_init - use mo_setsox, only : sox_inti + use mo_setsox_cam, only : sox_inti use mo_drydep, only : drydep_inti use modal_aero_data, only : ntot_amode, nspec_amode #endif diff --git a/src/chemistry/modal_aero/aero_model.F90 b/src/chemistry/modal_aero/aero_model.F90 index 662dcca297..8c2199bd4d 100644 --- a/src/chemistry/modal_aero/aero_model.F90 +++ b/src/chemistry/modal_aero/aero_model.F90 @@ -24,11 +24,11 @@ module aero_model use modal_aero_data,only: cnst_name_cw, lptr_so4_cw_amode use modal_aero_data,only: ntot_amode, modename_amode, nspec_max + use modal_aero_data,only: modal_strat_sulfate use ref_pres, only: top_lev => clim_modal_aero_top_lev - use modal_aero_wateruptake, only: modal_strat_sulfate - use mo_setsox, only: setsox, has_sox + use mo_setsox_cam, only: setsox, has_sox use aerosol_properties_mod, only: aerosol_properties use aerosol_state_mod, only: aerosol_state use aerosol_instances_mod, only: aerosol_instances_get_props, & @@ -46,7 +46,6 @@ module aero_model public :: aero_model_emissions ! aerosol emissions public :: aero_model_surfarea ! tropopspheric aerosol wet surface area for chemistry public :: aero_model_strat_surfarea ! stratospheric aerosol wet surface area for chemistry - public :: calc_1_impact_rate public :: nimptblgrow_mind, nimptblgrow_maxd @@ -202,16 +201,15 @@ subroutine aero_model_init( pbuf2d ) use radiative_aerosol,only: rad_aer_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 aer_drydep_mod, only: inidrydep use aero_wetdep_cam, only: aero_wetdep_init - use mo_setsox, only: sox_inti + use mo_setsox_cam, only: sox_inti - use modal_aero_calcsize, only: modal_aero_calcsize_init - use modal_aero_coag, only: modal_aero_coag_init + use modal_aero_calcsize_cam, only: modal_aero_calcsize_init + use modal_aero_coag_cam, only: modal_aero_coag_cam_init use aero_deposition_cam, only: aero_deposition_cam_init - use modal_aero_gasaerexch, only: modal_aero_gasaerexch_init - use modal_aero_newnuc, only: modal_aero_newnuc_init - use modal_aero_rename, only: modal_aero_rename_init + use modal_aero_gasaerexch_cam, only: modal_aero_gasaerexch_cam_init + use modal_aero_newnuc_cam, only: modal_aero_newnuc_cam_init + use modal_aero_rename_cam, only: modal_aero_rename_cam_init use aerosol_spec_utils, only: spec_type_in_list ! args @@ -281,13 +279,13 @@ subroutine aero_model_init( pbuf2d ) call modal_aero_data_init(pbuf2d) call modal_aero_bcscavcoef_init() - call modal_aero_rename_init( modal_accum_coarse_exch ) + call modal_aero_rename_cam_init( modal_accum_coarse_exch ) ! calcsize call must follow rename call call modal_aero_calcsize_init( pbuf2d ) - call modal_aero_gasaerexch_init + call modal_aero_gasaerexch_cam_init() ! coag call must follow gasaerexch call - call modal_aero_coag_init - call modal_aero_newnuc_init + call modal_aero_coag_cam_init + call modal_aero_newnuc_cam_init ! call aero_deposition_cam_init only if the user has not specified ! prescribed aerosol deposition fluxes @@ -324,8 +322,6 @@ subroutine aero_model_init( pbuf2d ) if (ndrydep>0) then - call inidrydep(rair, gravit) - dummy = 'RAM1' call addfld (dummy,horiz_only, 'A','frac','RAM1') if ( history_aerosol ) then @@ -601,7 +597,9 @@ end subroutine aero_model_init subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend ) use dust_sediment_mod, only: dust_sediment_tend - use aer_drydep_mod, only: d3ddflux, calcram + use aero_drydep_core, only: modal_aero_depvel_part, calcram + use mo_drydep, only: n_land_type, fraction_landuse + use physconst, only: pi, boltz use modal_aero_data, only: qqcw_get_field use modal_aero_data, only: cnst_name_cw use modal_aero_data, only: alnsg_amode @@ -642,7 +640,6 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, integer :: mm ! tracer index integer :: i - real(r8) :: tvs(pcols,pver) real(r8) :: rho(pcols,pver) ! air density in kg/m3 real(r8) :: sflx(pcols) ! deposition flux real(r8) :: dep_trb(pcols) !kg/m2/s @@ -669,6 +666,9 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, logical :: aspherical + character(len=512) :: errmsg_local + integer :: errflg_local + landfrac => cam_in%landfrac(:) icefrac => cam_in%icefrac(:) ocnfrac => cam_in%ocnfrac(:) @@ -681,7 +681,7 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ! calc ram and fv over ocean and sea ice ... call calcram( ncol,landfrac,icefrac,ocnfrac,obklen,& ustar,ram1in,ram1,state%t(:,pver),state%pmid(:,pver),& - state%pdel(:,pver),fvin,fv) + state%pdel(:,pver),fvin,fv,rair,gravit) call outfld( 'airFV', fv(:), pcols, lchnk ) call outfld( 'RAM1', ram1(:), pcols, lchnk ) @@ -695,7 +695,6 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, call pbuf_get_field(pbuf, wetdens_ap_idx, wetdens, start=(/1,1,1/), kount=(/pcols,pver,nmodes/) ) call pbuf_get_field(pbuf, qaerwat_idx, qaerwat, start=(/1,1,1/), kount=(/pcols,pver,nmodes/) ) - tvs(:ncol,:) = state%t(:ncol,:)!*(1+state%q(:ncol,k) rho(:ncol,:)= state%pmid(:ncol,:)/(rair*state%t(:ncol,:)) ! @@ -708,11 +707,15 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, jvlc = 3 ! dmleung: jvlc = 3, moment = 0 => dry dep velocity for number of cloud-borne aerosols call modal_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 0, lchnk) + rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 0, & + pver, top_lev, n_land_type, fraction_landuse(:,:,lchnk), & + pi, boltz, gravit, rair) jvlc = 4 ! jvlc = 4, moment = 3 => dry dep velocity for vol/mass of cloud-borne aerosols call modal_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 3, lchnk) + rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 3, & + pver, top_lev, n_land_type, fraction_landuse(:,:,lchnk), & + pi, boltz, gravit, rair) do m = 1, ntot_amode ! main loop over aerosol modes @@ -740,11 +743,15 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, jvlc = 1 ! dmleung: jvlc = 1, moment = 0 => dry dep velocity for number of interstitial aerosols call modal_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 0, lchnk, aspherical=aspherical) + rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 0, & + pver, top_lev, n_land_type, fraction_landuse(:,:,lchnk), & + pi, boltz, gravit, rair, aspherical=aspherical) jvlc = 2 ! jvlc = 2, moment = 3 => dry dep velocity for vol/mass of interstitial aerosols call modal_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk, aspherical=aspherical) + rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, & + pver, top_lev, n_land_type, fraction_landuse(:,:,lchnk), & + pi, boltz, gravit, rair, aspherical=aspherical) end if @@ -792,19 +799,16 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, call outfld( trim(cnst_name(mm))//'DDV', pvmzaer(:,2:pverp), pcols, lchnk ) - if(.true.) then ! use phil's method ! convert from meters/sec to pascals/sec ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit ! calculate the tendencies and sfc fluxes from the above velocities call dust_sediment_tend( & - ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & - state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx ) - else !use charlie's method - call d3ddflux( ncol, vlc_dry(:,:,jvlc), state%q(:,:,mm), state%pmid, & - state%pdel, tvs, sflx, ptend%q(:,:,mm), dt ) - endif + ncol, dt, state%pint(:,:), state%pdel, & + state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx, & + pver, gravit, errmsg_local, errflg_local ) + if (errflg_local /= 0) call endrun('aero_model_drydep: '//trim(errmsg_local)) ! apportion dry deposition into turb and gravitational settling for tapes dep_trb = 0._r8 @@ -827,19 +831,16 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, pvmzaer(:ncol,1)=0._r8 pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) - if(.true.) then ! use phil's method ! convert from meters/sec to pascals/sec ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit ! calculate the tendencies and sfc fluxes from the above velocities call dust_sediment_tend( & - ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & - qaerwat(:,:,mm), pvmzaer, dqdt_tmp(:,:), sflx ) - else !use charlie's method - call d3ddflux( ncol, vlc_dry(:,:,jvlc), qaerwat(:,:,mm), state%pmid, & - state%pdel, tvs, sflx, dqdt_tmp(:,:), dt ) - endif + ncol, dt, state%pint(:,:), state%pdel, & + qaerwat(:,:,mm), pvmzaer, dqdt_tmp(:,:), sflx, & + pver, gravit, errmsg_local, errflg_local ) + if (errflg_local /= 0) call endrun('aero_model_drydep: '//trim(errmsg_local)) ! apportion dry deposition into turb and gravitational settling for tapes dep_trb = 0._r8 @@ -859,19 +860,16 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) fldcw => qqcw_get_field(pbuf, mm,lchnk) - if(.true.) then ! use phil's method ! convert from meters/sec to pascals/sec ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit ! calculate the tendencies and sfc fluxes from the above velocities call dust_sediment_tend( & - ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & - fldcw(:,:), pvmzaer, dqdt_tmp(:,:), sflx ) - else !use charlie's method - call d3ddflux( ncol, vlc_dry(:,:,jvlc), fldcw(:,:), state%pmid, & - state%pdel, tvs, sflx, dqdt_tmp(:,:), dt ) - endif + ncol, dt, state%pint(:,:), state%pdel, & + fldcw(:,:), pvmzaer, dqdt_tmp(:,:), sflx, & + pver, gravit, errmsg_local, errflg_local ) + if (errflg_local /= 0) call endrun('aero_model_drydep: '//trim(errmsg_local)) ! apportion dry deposition into turb and gravitational settling for tapes dep_trb = 0._r8 @@ -1026,11 +1024,27 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re vmr0, vmr, pbuf ) use time_manager, only : get_nstep - 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 - use modal_aero_data, only : cnst_name_cw, qqcw_get_field + use modal_aero_coag, only : modal_aero_coag_run + use modal_aero_gasaerexch, only : modal_aero_gasaerexch_run, modefrm_pcage + use modal_aero_rename, only : modal_aero_rename_run + use modal_aero_rename_cam, only : npair_renamexf, modefrm_renamexf, modetoo_renamexf, & + nspecfrm_renamexf, lspecfrma_renamexf, lspecfrmc_renamexf, & + lspectooa_renamexf, lspectooc_renamexf, & + igrow_shrink_renamexf, ixferable_all_renamexf, & + ixferable_a_renamexf, ixferable_c_renamexf, strat_only_renamexf + use modal_aero_newnuc, only : modal_aero_newnuc_run + use modal_aero_data, only : cnst_name_cw, qqcw_get_field, & + nsoa, lptr2_soa_a_amode, lptr2_soa_g_amode, & + nspec_amode, & + alnsg_amode, voltonumblo_amode, voltonumbhi_amode, & + dgnum_amode, specmw_amode, specdens_amode, & + lmassptr_amode, lmassptrcw_amode, numptr_amode, & + numptrcw_amode, modeptr_accum, modeptr_coarse, & + modeptr_stracoar + use mo_constants, only : pi use mo_chem_utls, only : get_spc_ndx + use constituents, only : pcnst, cnst_name + use physconst, only : mwdry !----------------------------------------------------------------------- ! ... dummy arguments @@ -1092,7 +1106,49 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re character(len=32) :: specname class(aerosol_state), pointer :: aero_state + ! Local arrays for refactored gasaerexch call + real(r8) :: dqdt_gaex(ncol,pver,gas_pcnst) + real(r8) :: dqdt_gaex_conden(ncol,pver,gas_pcnst) ! conden-only snapshot (pre-rename) for diagnostics + real(r8) :: dqdt_rnpos_unused(ncol,pver,gas_pcnst) ! required rename output, unused by CAM + logical :: dotend_gaex(gas_pcnst) + real(r8) :: dqqcwdt_gaex(ncol,pver,gas_pcnst) + logical :: dotendrn(gas_pcnst), dotendqqcwrn(gas_pcnst) + logical :: is_dorename_atik, dorename_atik(ncol,pver) + integer, parameter :: jsrflx_gaexch = 1 + integer, parameter :: jsrflx_rename = 2 + integer, parameter :: nsrflx = 2 + real(r8) :: qsrflx(pcols,gas_pcnst,nsrflx) + real(r8) :: qqcwsrflx(pcols,gas_pcnst,nsrflx) + real(r8) :: qsrflx_gaexch_out(ncol,gas_pcnst) ! column-integrated gaexch source/sink from the scheme + ! Local arrays for refactored newnuc call + real(r8) :: dqdt_nnuc(ncol,pver,gas_pcnst) + logical :: dotend_nnuc(gas_pcnst) + real(r8) :: qsrflx_nnuc(pcols,gas_pcnst,1) ! column-integrated nucleation source/sink + ! Local arrays for refactored coag call (dqdt_coag is diagnostic-only; + ! the scheme updates vmr in place) + real(r8) :: dqdt_coag(ncol,pver,gas_pcnst) + logical :: dotend_coag(gas_pcnst) + real(r8) :: qsrflx_coag(pcols) ! column-integrated coagulation source/sink + character(len=fieldname_len+3) :: fieldname + integer :: jac, jsrf, jsoa, lb + logical :: use_sulfeq + character(len=512) :: errmsg_local + integer :: errflg_local + ! Zero-initialized dummy array for intent(in) placeholders (e.g. sulfeq + ! when use_sulfeq=.false.). Sized to the common (ncol,pver,ntot_amode) shape. + real(r8) :: dummy_3d(ncol,pver,ntot_amode) + + ! SOA condensation/evaporation diagnostics + real(r8) :: qconff(pcols,pver),qevapff(pcols,pver) + real(r8) :: qconbb(pcols,pver),qevapbb(pcols,pver) + real(r8) :: qconbg(pcols,pver),qevapbg(pcols,pver) + real(r8) :: qcon(pcols,pver),qevap(pcols,pver) + real(r8) :: dqdt_soa_val + integer :: l_soa + aero_state => aerosol_instances_get_state(iaermod_, 0, lchnk) + + dummy_3d(:,:,:) = 0.0_r8 ! ! ... initialize nh3 ! @@ -1205,32 +1261,298 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re ! 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') if ( sulfeq_idx>0 ) then call pbuf_get_field( pbuf, sulfeq_idx, sulfeq ) + use_sulfeq = .true. else nullify( sulfeq ) + use_sulfeq = .false. endif - call modal_aero_gasaerexch_sub( & - lchnk, ncol, nstep, & - loffset, delt, & - tfld, pmid, pdel, & - qh2o, troplev, & - vmr, vmrcw, & - dvmrdt, dvmrcwdt, & - dgnum, dgnumwet, & - sulfeq ) + ! Call portable gasaerexch_run to get tendencies + dqdt_gaex(:,:,:) = 0.0_r8 + dotend_gaex(:) = .false. + if (use_sulfeq) then + call modal_aero_gasaerexch_run( & + ncol = ncol, & + pver = pver, & + deltat = delt, & + top_lev = top_lev, & + loffset = loffset, & + t = tfld(:ncol,:), & + pmid = pmid(:ncol,:), & + pdel = pdel(:ncol,:), & + gravit = gravit, & + troplev = troplev(:ncol), & + dgncur_a = dgnum(:ncol,:,:), & + dgncur_awet = dgnumwet(:ncol,:,:), & + use_sulfeq = .true., & + sulfeq = sulfeq(:ncol,:,:), & + num_q = gas_pcnst, & + q = vmr(:ncol,:,:), & + dqdt = dqdt_gaex, & + dotend = dotend_gaex, & + qsrflx_gaexch = qsrflx_gaexch_out, & + errmsg = errmsg_local, & + errflg = errflg_local) + else + call modal_aero_gasaerexch_run( & + ncol = ncol, & + pver = pver, & + deltat = delt, & + top_lev = top_lev, & + loffset = loffset, & + t = tfld(:ncol,:), & + pmid = pmid(:ncol,:), & + pdel = pdel(:ncol,:), & + gravit = gravit, & + troplev = troplev(:ncol), & + dgncur_a = dgnum(:ncol,:,:), & + dgncur_awet = dgnumwet(:ncol,:,:), & + use_sulfeq = .false., & + sulfeq = dummy_3d, & + num_q = gas_pcnst, & + q = vmr(:ncol,:,:), & + dqdt = dqdt_gaex, & + dotend = dotend_gaex, & + qsrflx_gaexch = qsrflx_gaexch_out, & + errmsg = errmsg_local, & + errflg = errflg_local) + end if + + if (errflg_local /= 0) then + call endrun('aero_model_gasaerexch: ' // trim(errmsg_local)) + end if + + ! Snapshot conden-only tendencies before modal_aero_rename_run adds its + ! mode-transfer tendencies into dqdt_gaex in place. The _sfgaex1 and SOA + ! cond/evap diagnostics below use these pre-rename values, matching the + ! original where qsrflx/qcon were accumulated before the rename call. + dqdt_gaex_conden(:,:,:) = dqdt_gaex(:,:,:) + + if (ndx_h2so4 > 0) then + ! Snapshot h2so4 vmr before applying tendencies. del_h2so4_aeruptk is + ! recovered below as (vmr_after - vmr_before) after the apply loop, matching + ! the original which bracketed the in-place gasaerexch_sub update. + ! A clearer formulation is + ! del_h2so4_aeruptk(1:ncol,:) = dqdt_gaex(1:ncol,:,ndx_h2so4) * delt + ! but is not bit-for-bit and the difference propagates down to newnuc. + del_h2so4_aeruptk(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) + else + del_h2so4_aeruptk(:,:) = 0.0_r8 + end if + + ! Call rename as a separate step (was embedded in gasaerexch_sub). + ! Marshal MAM mode metadata + the resolved renaming-pair tables (owned by + ! modal_aero_rename_cam) into the portable modal_aero_rename_run directly. + dqqcwdt_gaex(:,:,:) = 0.0_r8 + dotendrn(:) = .false. + dotendqqcwrn(:) = .false. + dorename_atik(1:ncol,:) = .true. + is_dorename_atik = .true. + ! Zero the (pcols-padded) column-tendency outputs over the full domain; the + ! scheme is called on :ncol and defines only that subset. + qsrflx(:,:,:) = 0.0_r8 + qqcwsrflx(:,:,:) = 0.0_r8 + call modal_aero_rename_run( & + ncol = ncol, & + loffset = loffset, & + deltat = delt, & + pdel = pdel(:ncol,:), & + troplev = troplev(:ncol), & + dotendrn = dotendrn, & + q = vmr(:ncol,:,:), & + dqdt = dqdt_gaex(:ncol,:,:), & + dqdt_other = dvmrdt(:ncol,:,:), & + dotendqqcwrn = dotendqqcwrn, & + qqcw = vmrcw(:ncol,:,:), & + dqqcwdt = dqqcwdt_gaex(:ncol,:,:), & + dqqcwdt_other = dvmrcwdt(:ncol,:,:), & + is_dorename_atik = is_dorename_atik, & + dorename_atik = dorename_atik(:ncol,:), & + jsrflx_rename = jsrflx_rename, & + nsrflx = nsrflx, & + qsrflx = qsrflx(:ncol,:,:), & + qqcwsrflx = qqcwsrflx(:ncol,:,:), & + dqdt_rnpos = dqdt_rnpos_unused, & + ntot_amode = ntot_amode, & + npair_renamexf = npair_renamexf, & + modefrm_renamexf = modefrm_renamexf, & + modetoo_renamexf = modetoo_renamexf, & + nspecfrm_renamexf = nspecfrm_renamexf, & + lspecfrma_renamexf = lspecfrma_renamexf, & + lspecfrmc_renamexf = lspecfrmc_renamexf, & + lspectooa_renamexf = lspectooa_renamexf, & + lspectooc_renamexf = lspectooc_renamexf, & + alnsg_amode = alnsg_amode, & + voltonumblo_amode = voltonumblo_amode, & + voltonumbhi_amode = voltonumbhi_amode, & + dgnum_amode = dgnum_amode, & + nspec_amode = nspec_amode, & + specmw_amode = specmw_amode, & + specdens_amode = specdens_amode, & + lmassptr_amode = lmassptr_amode, & + lmassptrcw_amode = lmassptrcw_amode, & + numptr_amode = numptr_amode, & + numptrcw_amode = numptrcw_amode, & + pi = pi, & + modeptr_accum = modeptr_accum, & + modeptr_coarse = modeptr_coarse, & + modeptr_stracoar = modeptr_stracoar, & + igrow_shrink_renamexf = igrow_shrink_renamexf, & + ixferable_all_renamexf = ixferable_all_renamexf, & + ixferable_a_renamexf = ixferable_a_renamexf, & + ixferable_c_renamexf = ixferable_c_renamexf, & + strat_only_renamexf = strat_only_renamexf, & + modal_accum_coarse_exch = modal_accum_coarse_exch, & + pver = pver, & + gravit = gravit, & + errmsg = errmsg_local, & + errflg = errflg_local ) + + if (errflg_local /= 0) then + call endrun('aero_model_gasaerexch (rename): ' // trim(errmsg_local)) + end if + ! Apply tendencies to vmr and vmrcw + do l = 1, gas_pcnst + if ( dotend_gaex(l) .or. dotendrn(l) ) then + do k = top_lev, pver + do i = 1, ncol + vmr(i,k,l) = vmr(i,k,l) + dqdt_gaex(i,k,l)*delt + end do + end do + end if + if ( dotendqqcwrn(l) ) then + do k = top_lev, pver + do i = 1, ncol + vmrcw(i,k,l) = vmrcw(i,k,l) + dqqcwdt_gaex(i,k,l)*delt + end do + end do + end if + end do + + ! Recover del_h2so4_aeruptk = vmr_after - vmr_before (see snapshot above). if (ndx_h2so4 > 0) then del_h2so4_aeruptk(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) - del_h2so4_aeruptk(1:ncol,:) + end if + + ! Diagnostics: column tendencies for gas-aerosol exchange and renaming. + ! The gaexch column source/sink (qsrflx, jsrflx_gaexch) is accumulated inside the + ! scheme: the per-mode and primary-carbon-aging contributions must be summed term + ! by term (and with pdel/gravit in that operand order) to stay bit-for-bit with the + ! original; the host only sees the combined tendency and cannot reproduce it. + qsrflx(:ncol,:,jsrflx_gaexch) = qsrflx_gaexch_out(:ncol,:) + + ! Output history fields + do l = 1, gas_pcnst + lb = l + loffset + do jsrf = 1, 2 + do jac = 1, 2 + if (jac == 1) then + if (jsrf == jsrflx_gaexch) then + if ( .not. dotend_gaex(l) ) cycle + fieldname = trim(cnst_name(lb)) // '_sfgaex1' + else if (jsrf == jsrflx_rename) then + if ( .not. dotendrn(l) ) cycle + fieldname = trim(cnst_name(lb)) // '_sfgaex2' + else + cycle + end if + do i = 1, ncol + qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf)*(adv_mass(l)/mwdry) + end do + call outfld( fieldname, qsrflx(:,l,jsrf), pcols, lchnk ) + else + if (jsrf == jsrflx_gaexch) then + cycle + else if (jsrf == jsrflx_rename) then + if ( .not. dotendqqcwrn(l) ) cycle + fieldname = trim(cnst_name_cw(lb)) // '_sfgaex2' + else + cycle + end if + do i = 1, ncol + qqcwsrflx(i,l,jsrf) = qqcwsrflx(i,l,jsrf)*(adv_mass(l)/mwdry) + end do + call outfld( fieldname, qqcwsrflx(:,l,jsrf), pcols, lchnk ) + end if + end do ! jac = ... + end do ! jsrf = ... + end do ! l = ... + + ! SOA condensation/evaporation diagnostics + ! Reconstruct from the pre-rename conden tendencies (dqdt_gaex_conden). + ! NOTE: for the accumulation mode this is not exactly b4b with the original, + ! which used the per-mode conden tendency dqdt_soa(n,jsoa); the species-indexed + ! tendency here also absorbs primary-carbon-aged SOA. History-diagnostic only. + qconff(:,:) = 0.0_r8 + qevapff(:,:) = 0.0_r8 + qconbb(:,:) = 0.0_r8 + qevapbb(:,:) = 0.0_r8 + qconbg(:,:) = 0.0_r8 + qevapbg(:,:) = 0.0_r8 + qcon(:,:) = 0.0_r8 + qevap(:,:) = 0.0_r8 + + do n = 1, ntot_amode + do jsoa = 1, nsoa + l_soa = lptr2_soa_a_amode(n,jsoa) - loffset + if ((l_soa <= 0) .or. (l_soa > gas_pcnst)) cycle + ! Skip pcage from-mode: only accumulated for ido_soaa==1 + if (modefrm_pcage > 0 .and. n == modefrm_pcage) cycle + do k = top_lev, pver + do i = 1, ncol + dqdt_soa_val = dqdt_gaex_conden(i,k,l_soa) + if (nsoa.eq.15) then !check for current SOA package + if(jsoa.ge.1.and.jsoa.le.5) then ! Fossil SOA species + if (dqdt_soa_val.ge.0.0_r8) then + qconff(i,k)=qconff(i,k)+dqdt_soa_val*(adv_mass(l_soa)/mwdry) + elseif(dqdt_soa_val.lt.0.0_r8) then + qevapff(i,k)=qevapff(i,k)+dqdt_soa_val*(adv_mass(l_soa)/mwdry) + endif + + elseif(jsoa.ge.6.and.jsoa.le.10) then ! Biomass SOA species + if (dqdt_soa_val.ge.0.0_r8) then + qconbb(i,k)=qconbb(i,k)+dqdt_soa_val*(adv_mass(l_soa)/mwdry) + elseif(dqdt_soa_val.lt.0.0_r8) then + qevapbb(i,k)=qevapbb(i,k)+dqdt_soa_val*(adv_mass(l_soa)/mwdry) + endif + + elseif(jsoa.ge.11.and.jsoa.le.15) then ! Biogenic SOA species + if (dqdt_soa_val.ge.0.0_r8) then + qconbg(i,k)=qconbg(i,k)+dqdt_soa_val*(adv_mass(l_soa)/mwdry) + elseif(dqdt_soa_val.lt.0.0_r8) then + qevapbg(i,k)=qevapbg(i,k)+dqdt_soa_val*(adv_mass(l_soa)/mwdry) + endif + + endif ! jsoa + endif !nsoa + if (nsoa.eq.5) then !check for current SOA package + if (dqdt_soa_val.ge.0.0_r8) then + qcon(i,k)=qcon(i,k)+dqdt_soa_val*(adv_mass(l_soa)/mwdry) + elseif(dqdt_soa_val.lt.0.0_r8) then + qevap(i,k)=qevap(i,k)+dqdt_soa_val*(adv_mass(l_soa)/mwdry) + endif + endif !nsoa + end do ! i + end do ! k + end do ! jsoa + end do ! n + + if (nsoa.eq.5) then + call outfld(trim('qcon_gaex'), qcon(:,:), pcols, lchnk ) + call outfld(trim('qevap_gaex'), qevap(:,:), pcols, lchnk ) + endif + if (nsoa.eq.15) then + call outfld(trim('qconff_gaex'), qconff(:,:), pcols, lchnk ) + call outfld(trim('qevapff_gaex'), qevapff(:,:), pcols, lchnk ) + call outfld(trim('qconbb_gaex'), qconbb(:,:), pcols, lchnk ) + call outfld(trim('qevapbb_gaex'), qevapbb(:,:), pcols, lchnk ) + call outfld(trim('qconbg_gaex'), qconbg(:,:), pcols, lchnk ) + call outfld(trim('qevapbg_gaex'), qevapbg(:,:), pcols, lchnk ) endif call t_stopf('modal_gas-aer_exchng') @@ -1238,27 +1560,106 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re call t_startf('modal_nucl') ! 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 ) + ! Zero the (pcols-padded) column-tendency output over the full domain; the + ! scheme is called on :ncol and defines only that subset. + qsrflx_nnuc(:,:,:) = 0.0_r8 + call modal_aero_newnuc_run( & + ncol = ncol, & + pver = pver, & + top_lev = top_lev, & + num_q = gas_pcnst, & + loffset = loffset, & + deltat = delt, & + t = tfld(:ncol,:), & + pmid = pmid(:ncol,:), & + pdel = pdel(:ncol,:), & + zm = zm(:ncol,:), & + pblh = pblh(:ncol), & + qv = qh2o(:ncol,:), & + cld = cldfr(:ncol,:), & + q = vmr(:ncol,:,:), & + gravit = gravit, & + del_h2so4_gasprod = del_h2so4_gasprod(:ncol,:), & + del_h2so4_aeruptk = del_h2so4_aeruptk(:ncol,:), & + dqdt = dqdt_nnuc, & + dotend = dotend_nnuc, & + qsrflx = qsrflx_nnuc(:ncol,:,:), & + errmsg = errmsg_local, & + errflg = errflg_local ) + + if (errflg_local /= 0) then + call endrun('aero_model_gasaerexch (newnuc): ' // trim(errmsg_local)) + end if + + ! Apply nucleation tendencies to vmr (was applied in place by the scheme) + do l = 1, gas_pcnst + if ( dotend_nnuc(l) ) then + do k = top_lev, pver + do i = 1, ncol + vmr(i,k,l) = vmr(i,k,l) + dqdt_nnuc(i,k,l)*delt + end do + end do + end if + end do + + ! do history file column-tendency fields + do l = 1, gas_pcnst + if ( .not. dotend_nnuc(l) ) cycle + lb = l + loffset + do i = 1, ncol + qsrflx_nnuc(i,l,1) = qsrflx_nnuc(i,l,1)*(adv_mass(l)/mwdry) + end do + fieldname = trim(cnst_name(lb)) // '_sfnnuc1' + call outfld( fieldname, qsrflx_nnuc(:,l,1), pcols, lchnk ) + end do ! l = ... call t_stopf('modal_nucl') call t_startf('modal_coag') ! do aerosol coagulation - call modal_aero_coag_sub( & - lchnk, ncol, nstep, & - loffset, delt, & - tfld, pmid, pdel, & - vmr, & - dgnum, dgnumwet, & - wetdens ) + ! vmr is updated in place by the scheme; dqdt_coag is returned for the + ! history diagnostics only (dqdt*delt is not bit-identical to the stored + ! change, so it must not be re-applied) + call modal_aero_coag_run( & + ncol = ncol, & + pver = pver, & + top_lev = top_lev, & + num_q = gas_pcnst, & + loffset = loffset, & + nstep = nstep, & + deltat_main = delt, & + t = tfld(:ncol,:), & + pmid = pmid(:ncol,:), & + pdel = pdel(:ncol,:), & + q = vmr(:ncol,:,:), & + dgncur_a = dgnum(:ncol,:,:), & + dgncur_awet = dgnumwet(:ncol,:,:), & + wetdens_a = wetdens(:ncol,:,:), & + dqdt = dqdt_coag, & + dotend = dotend_coag, & + errmsg = errmsg_local, & + errflg = errflg_local ) + + if (errflg_local /= 0) then + call endrun('aero_model_gasaerexch (coag): ' // trim(errmsg_local)) + end if + + ! do history file column-tendency fields + do l = 1, gas_pcnst + if ( .not. dotend_coag(l) ) cycle + lb = l + loffset + + qsrflx_coag(:) = 0.0_r8 + do k = top_lev, pver + do i = 1, ncol + qsrflx_coag(i) = qsrflx_coag(i) + dqdt_coag(i,k,l)*pdel(i,k) + end do + end do + qsrflx_coag(:) = qsrflx_coag(:)*(adv_mass(l)/(gravit*mwdry)) + fieldname = trim(cnst_name(lb)) // '_sfcoag1' + call outfld( fieldname, qsrflx_coag, pcols, lchnk ) + end do ! l = ... call t_stopf('modal_coag') @@ -1299,8 +1700,6 @@ subroutine aero_model_emissions( state, cam_in ) integer :: m, mm real(r8) :: soil_erod_tmp(pcols) real(r8) :: sflx(pcols) ! accumulate over all bins for output - real(r8) :: u10cubed(pcols) - real (r8), parameter :: z0=0.0001_r8 ! m roughness length over oceans--from ocean model lchnk = state%lchnk ncol = state%ncol @@ -1321,18 +1720,10 @@ subroutine aero_model_emissions( state, cam_in ) endif if (seasalt_active) then - u10cubed(:ncol)=sqrt(state%u(:ncol,pver)**2+state%v(:ncol,pver)**2) - ! move the winds to 10m high from the midpoint of the gridbox: - ! follows Tie and Seinfeld and Pandis, p.859 with math. - - u10cubed(:ncol)=u10cubed(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) - - ! we need them to the 3.41 power, according to Gong et al., 1997: - u10cubed(:ncol)=u10cubed(:ncol)**3.41_r8 - sflx(:)=0._r8 - call seasalt_emis( u10cubed, cam_in%sst, cam_in%ocnfrac, ncol, cam_in%cflx ) + call seasalt_emis( state%u(:ncol,pver), state%v(:ncol,pver), state%zm(:ncol,pver), & + cam_in%sst, cam_in%ocnfrac, ncol, cam_in%cflx ) do m=1,seasalt_nbin mm = seasalt_indices(m) @@ -1454,203 +1845,6 @@ subroutine modal_aero_bcscavcoef_init return end subroutine modal_aero_bcscavcoef_init - !=============================================================================== - !=============================================================================== - subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc_grv, & - radius_part, density_part, sig_part, moment, lchnk, aspherical ) ! dmleung added aspherical flag 20 Oct 2025 - -! calculates surface deposition velocity of particles -! L. Zhang, S. Gong, J. Padro, and L. Barrie -! A size-seggregated particle dry deposition scheme for an atmospheric aerosol module -! Atmospheric Environment, 35, 549-560, 2001. -! -! Authors: X. Liu - - ! - ! !USES - ! - use physconst, only: pi,boltz, gravit, rair - use mo_drydep, only: n_land_type, fraction_landuse - - ! !ARGUMENTS: - ! - implicit none - ! - real(r8), intent(in) :: t(pcols,pver) !atm temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) !atm pressure (Pa) - real(r8), intent(in) :: fv(pcols) !friction velocity (m/s) - real(r8), intent(in) :: ram1(pcols) !aerodynamical resistance (s/m) - real(r8), intent(in) :: radius_part(pcols,pver) ! mean (volume/number) particle radius (m) - real(r8), intent(in) :: density_part(pcols,pver) ! density of particle material (kg/m3) - real(r8), intent(in) :: sig_part(pcols,pver) ! geometric standard deviation of particles - integer, intent(in) :: moment ! moment of size distribution (0 for number, 2 for surface area, 3 for volume) - integer, intent(in) :: ncol - integer, intent(in) :: lchnk - - real(r8), intent(out) :: vlc_trb(pcols) !Turbulent deposn velocity (m/s) - real(r8), intent(out) :: vlc_grv(pcols,pver) !grav deposn velocity (m/s) - real(r8), intent(out) :: vlc_dry(pcols,pver) !dry deposn velocity (m/s) - logical, intent(in), OPTIONAL :: aspherical ! dmleung: asphericity is strong for coarse-mode interstitial - ! aerosols only, mostly dust and seasalt. For coarse mode aerosols, asphericity reduces coarse-mode gravitational - ! settling velocity by 20 % following Fig. 4 of Yue Huang et al. (2020). - !------------------------------------------------------------------------ - - !------------------------------------------------------------------------ - ! Local Variables - integer :: m,i,k,ix !indices - real(r8) :: rho !atm density (kg/m**3) - real(r8) :: vsc_dyn_atm(pcols,pver) ![kg m-1 s-1] Dynamic viscosity of air - real(r8) :: vsc_knm_atm(pcols,pver) ![m2 s-1] Kinematic viscosity of atmosphere - real(r8) :: shm_nbr ![frc] Schmidt number - real(r8) :: stk_nbr ![frc] Stokes number - real(r8) :: mfp_atm(pcols,pver) ![m] Mean free path of air - real(r8) :: dff_aer ![m2 s-1] Brownian diffusivity of particle - real(r8) :: slp_crc(pcols,pver) ![frc] Slip correction factor - real(r8) :: rss_trb ![s m-1] Resistance to turbulent deposition - real(r8) :: rss_lmn ![s m-1] Quasi-laminar layer resistance - real(r8) :: brownian ! collection efficiency for Browning diffusion - real(r8) :: impaction ! collection efficiency for impaction - real(r8) :: interception ! collection efficiency for interception - real(r8) :: stickfrac ! fraction of particles sticking to surface - real(r8) :: radius_moment(pcols,pver) ! median radius (m) for moment - real(r8) :: lnsig ! ln(sig_part) - real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity - ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) - - integer :: lt - real(r8) :: lnd_frc - real(r8) :: wrk1, wrk2, wrk3 - - ! constants - - real(r8), parameter :: asphericaldust_drydep = 0.8_r8 ! dmleung added 20 Oct 2025: aspherical dust reduces - ! gravitational settling velocity by 15-20 %. Yue Huang et al. (2020) - ! Climate Models and Remote Sensing Retrievals Neglect Substantial Desert Dust Asphericity - - real(r8) gamma(11) ! exponent of schmidt number -! data gamma/0.54d+00, 0.56d+00, 0.57d+00, 0.54d+00, 0.54d+00, & -! 0.56d+00, 0.54d+00, 0.54d+00, 0.54d+00, 0.56d+00, & -! 0.50d+00/ - data gamma/0.56e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.56e+00_r8, 0.56e+00_r8, & - 0.56e+00_r8, 0.50e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.54e+00_r8, & - 0.54e+00_r8/ - save gamma - - real(r8) alpha(11) ! parameter for impaction -! data alpha/50.00d+00, 0.95d+00, 0.80d+00, 1.20d+00, 1.30d+00, & -! 0.80d+00, 50.00d+00, 50.00d+00, 2.00d+00, 1.50d+00, & -! 100.00d+00/ - data alpha/1.50e+00_r8, 1.20e+00_r8, 1.20e+00_r8, 0.80e+00_r8, 1.00e+00_r8, & - 0.80e+00_r8, 100.00e+00_r8, 50.00e+00_r8, 2.00e+00_r8, 1.20e+00_r8, & - 50.00e+00_r8/ - save alpha - - real(r8) radius_collector(11) ! radius (m) of surface collectors -! data radius_collector/-1.00d+00, 5.10d-03, 3.50d-03, 3.20d-03, 10.00d-03, & -! 5.00d-03, -1.00d+00, -1.00d+00, 10.00d-03, 10.00d-03, & -! -1.00d+00/ - data radius_collector/10.00e-03_r8, 3.50e-03_r8, 3.50e-03_r8, 5.10e-03_r8, 2.00e-03_r8, & - 5.00e-03_r8, -1.00e+00_r8, -1.00e+00_r8, 10.00e-03_r8, 3.50e-03_r8, & - -1.00e+00_r8/ - save radius_collector - - integer :: iwet(11) ! flag for wet surface = 1, otherwise = -1 -! data iwet/1, -1, -1, -1, -1, & -! -1, -1, -1, 1, -1, & -! 1/ - data iwet/-1, -1, -1, -1, -1, & - -1, 1, -1, 1, -1, & - -1/ - save iwet - - - vlc_trb = 0._r8 - vlc_grv = 0._r8 - vlc_dry = 0._r8 - - !------------------------------------------------------------------------ - do k=top_lev,pver ! radius_part is not defined above top_lev - do i=1,ncol - - lnsig = log(sig_part(i,k)) -! use a maximum radius of 50 microns when calculating deposition velocity - radius_moment(i,k) = min(50.0e-6_r8,radius_part(i,k))* & - exp((float(moment)-1.5_r8)*lnsig*lnsig) - dispersion = exp(2._r8*lnsig*lnsig) - - rho=pmid(i,k)/rair/t(i,k) - - ! Quasi-laminar layer resistance: call rss_lmn_get - ! Size-independent thermokinetic properties - vsc_dyn_atm(i,k) = 1.72e-5_r8 * ((t(i,k)/273.0_r8)**1.5_r8) * 393.0_r8 / & - (t(i,k)+120.0_r8) ![kg m-1 s-1] RoY94 p. 102 - mfp_atm(i,k) = 2.0_r8 * vsc_dyn_atm(i,k) / & ![m] SeP97 p. 455 - (pmid(i,k)*sqrt(8.0_r8/(pi*rair*t(i,k)))) - vsc_knm_atm(i,k) = vsc_dyn_atm(i,k) / rho ![m2 s-1] Kinematic viscosity of air - - slp_crc(i,k) = 1.0_r8 + mfp_atm(i,k) * & - (1.257_r8+0.4_r8*exp(-1.1_r8*radius_moment(i,k)/(mfp_atm(i,k)))) / & - radius_moment(i,k) ![frc] Slip correction factor SeP97 p. 464 - vlc_grv(i,k) = (4.0_r8/18.0_r8) * radius_moment(i,k)*radius_moment(i,k)*density_part(i,k)* & - gravit*slp_crc(i,k) / vsc_dyn_atm(i,k) ![m s-1] Stokes' settling velocity SeP97 p. 466 - vlc_grv(i,k) = vlc_grv(i,k) * dispersion - - ! dmleung edited 20 Oct 2025 based on Longlei Li's edits ++ - ! asphericity reduces gravitational settling velocity of coarse-mode aerosols by 20 %. - ! scale flag is only true for coarse mode (m == n_coarse_dust). - if (present(aspherical)) then - if(aspherical) then - vlc_grv(i,k) = vlc_grv(i,k) * asphericaldust_drydep - end if - end if - ! dmleung -- - - vlc_dry(i,k)=vlc_grv(i,k) - enddo - enddo - k=pver ! only look at bottom level for next part - do i=1,ncol - dff_aer = boltz * t(i,k) * slp_crc(i,k) / & ![m2 s-1] - (6.0_r8*pi*vsc_dyn_atm(i,k)*radius_moment(i,k)) !SeP97 p.474 - shm_nbr = vsc_knm_atm(i,k) / dff_aer ![frc] SeP97 p.972 - - wrk2 = 0._r8 - wrk3 = 0._r8 - do lt = 1,n_land_type - lnd_frc = fraction_landuse(i,lt,lchnk) - if ( lnd_frc /= 0._r8 ) then - brownian = shm_nbr**(-gamma(lt)) - if (radius_collector(lt) > 0.0_r8) then -! vegetated surface - stk_nbr = vlc_grv(i,k) * fv(i) / (gravit*radius_collector(lt)) - interception = 2.0_r8*(radius_moment(i,k)/radius_collector(lt))**2.0_r8 - else -! non-vegetated surface - stk_nbr = vlc_grv(i,k) * fv(i) * fv(i) / (gravit*vsc_knm_atm(i,k)) ![frc] SeP97 p.965 - interception = 0.0_r8 - endif - impaction = (stk_nbr/(alpha(lt)+stk_nbr))**2.0_r8 - - if (iwet(lt) > 0) then - stickfrac = 1.0_r8 - else - stickfrac = exp(-sqrt(stk_nbr)) - if (stickfrac < 1.0e-10_r8) stickfrac = 1.0e-10_r8 - endif - rss_lmn = 1.0_r8 / (3.0_r8 * fv(i) * stickfrac * (brownian+interception+impaction)) - rss_trb = ram1(i) + rss_lmn + ram1(i)*rss_lmn*vlc_grv(i,k) - - wrk1 = 1.0_r8 / rss_trb - wrk2 = wrk2 + lnd_frc*( wrk1 ) - wrk3 = wrk3 + lnd_frc*( wrk1 + vlc_grv(i,k) ) - endif - enddo ! n_land_type - vlc_trb(i) = wrk2 - vlc_dry(i,k) = wrk3 - enddo !ncol - - return - end subroutine modal_aero_depvel_part !=============================================================================== subroutine modal_aero_bcscavcoef_get( m, ncol, isprx, dgn_awet, scavcoefnum, scavcoefvol ) diff --git a/src/chemistry/modal_aero/dust_model.F90 b/src/chemistry/modal_aero/dust_model.F90 index ad85a0bbfd..5367c293ce 100644 --- a/src/chemistry/modal_aero/dust_model.F90 +++ b/src/chemistry/modal_aero/dust_model.F90 @@ -25,12 +25,10 @@ module dust_model integer, protected :: dust_nnum != 2 character(len=6), protected, allocatable :: dust_names(:) - real(r8), allocatable :: dust_dmt_grd(:) real(r8), allocatable :: dust_emis_sclfctr(:) integer , protected, allocatable :: dust_indices(:) real(r8), allocatable :: dust_dmt_vwr(:) - real(r8), allocatable :: dust_stk_crc(:) real(r8) :: dust_emis_fact = 0._r8 ! tuning parameter for dust emissions character(len=cl) :: soil_erod_file = 'none' ! full pathname for soil erodibility dataset @@ -107,43 +105,23 @@ subroutine dust_init() use constituents, only: cnst_get_ind use aerosol_instances_mod, only: aerosol_instances_get_props, aerosol_instances_get_num_models use aerosol_properties_mod, only: aerosol_properties - use dust_common, only: dust_set_params + use physconst, only: pi, rair, gravit + use modal_dust_emissions, only: modal_dust_emissions_init integer :: l, m, mm, ndx, nspec, iaermod character(len=32) :: spec_name integer, parameter :: mymodes(7) = (/ 2, 1, 3, 4, 5, 6, 7 /) ! tricky order ... class(aerosol_properties), pointer :: aero_props_modal + character(len=256) :: errmsg + integer :: errflg dust_nbin = ndst dust_nnum = ndst allocate( dust_names(2*ndst) ) allocate( dust_indices(2*ndst) ) - allocate( dust_dmt_grd(ndst+1) ) allocate( dust_emis_sclfctr(ndst) ) allocate( dust_dmt_vwr(ndst) ) - allocate( dust_stk_crc(ndst) ) - - ! dmleung edited the mass fraction of the emitted dust size distribution. 27 Oct 2025 ++ - ! The new mass fraction comes from Jun Meng et al. (2022) and MERRA-2. - ! Jun Meng's table indicates 2.1 % mass for 0.1-1 um and 97.9 % mass for 1-10 um. - ! ref: https://zenodo.org/records/6344524 - ! MERRA-2 dust emissions indicate 6 % mass for 0.1-1 um (bin1) and 94 % for 1-10 um (bin2-5). - ! dmleung adopts 2.1 % mass for 0.1-1 um and 97.9 % mass for 1-10 um for dust. - ! Distributing more mass to accumulation mode allows a longer lifetime of dust, reducing - ! low dust biases over remote oceans and reducing high dust biases over the Sahara. - ! This change impacts both Zender_2003 dust and Leung_2023 dust. - if ( ntot_amode == 3 ) then - dust_dmt_grd(:) = (/ 0.1e-6_r8, 1.0e-6_r8, 10.0e-6_r8/) - dust_emis_sclfctr(:) = (/ 0.021_r8,0.979_r8 /) - elseif ( ntot_amode == 4 .or. ntot_amode == 5 ) then - dust_dmt_grd(:) = (/ 0.01e-6_r8, 0.1e-6_r8, 1.0e-6_r8, 10.0e-6_r8 /) - dust_emis_sclfctr(:) = (/ 1.65E-05_r8, 0.021_r8, 0.979_r8 /) - else if( ntot_amode == 7 ) then - dust_dmt_grd(:) = (/ 0.1e-6_r8, 2.0e-6_r8, 10.0e-6_r8/) - dust_emis_sclfctr(:) = (/ 0.12_r8, 0.88_r8 /) - endif - ! dmleung -- ! Find modal properties object from factory aero_props_modal => null() @@ -176,17 +154,23 @@ subroutine dust_init() call soil_erod_init( dust_emis_fact, soil_erod_file ) end if - call dust_set_params( dust_nbin, dust_dmt_grd, dust_dmt_vwr, dust_stk_crc ) + call modal_dust_emissions_init( ntot_amode=ntot_amode, dust_nbin=dust_nbin, & + pi=pi, rair=rair, gravit=gravit, & + dust_emis_sclfctr=dust_emis_sclfctr, & + dust_dmt_vwr=dust_dmt_vwr, & + errmsg=errmsg, errflg=errflg ) + if (errflg /= 0) then + call endrun('dust_init: '//trim(errmsg)) + end if end subroutine dust_init !=============================================================================== !=============================================================================== subroutine dust_emis( ncol, lchnk, dust_flux_in, cflx, soil_erod ) - use soil_erod_mod, only : soil_erod_fact use soil_erod_mod, only : soil_erodibility - use mo_constants, only : dust_density use physconst, only : pi + use modal_dust_emissions, only: modal_dust_emissions_run ! args integer, intent(in) :: ncol, lchnk @@ -195,43 +179,28 @@ subroutine dust_emis( ncol, lchnk, dust_flux_in, cflx, soil_erod ) real(r8), intent(out) :: soil_erod(:) ! local vars - integer :: i, m, idst, inum - real(r8) :: x_mton - real(r8),parameter :: soil_erod_threshold = 0.1_r8 - - ! set dust emissions - - if (is_zender_soil_erod_from_atm()) then ! Zender_2003 dust emissions - col_loop1: do i = 1,ncol - soil_erod(i) = soil_erodibility( i, lchnk ) - if( soil_erod(i) .lt. soil_erod_threshold ) soil_erod(i) = 0._r8 - - ! rebin and adjust dust emissons. - do m = 1,dust_nbin - idst = dust_indices(m) - cflx(i,idst) = sum( -dust_flux_in(i,:) ) & - * dust_emis_sclfctr(m)*soil_erod(i)/dust_emis_fact*1.15_r8 - x_mton = 6._r8 / (pi * dust_density * (dust_dmt_vwr(m)**3._r8)) - inum = dust_indices(m+dust_nbin) - cflx(i,inum) = cflx(i,idst)*x_mton - enddo - enddo col_loop1 - else ! Leung_2023 dust emissions - - col_loop2: do i = 1,ncol - ! rebin and adjust dust emissons. - do m = 1,dust_nbin - idst = dust_indices(m) - - cflx(i,idst) = sum( -dust_flux_in(i,:) ) & - * dust_emis_sclfctr(m) / dust_emis_fact - x_mton = 6._r8 / (pi * dust_density * (dust_dmt_vwr(m)**3._r8)) - inum = dust_indices(m+dust_nbin) - cflx(i,inum) = cflx(i,idst)*x_mton - enddo - enddo col_loop2 + logical :: zender_soil_erod_from_atm + real(r8) :: soil_erod_in(ncol) + + zender_soil_erod_from_atm = is_zender_soil_erod_from_atm() + + ! soil_erod_mod storage exists only when Zender soil erosion is in atm + if (zender_soil_erod_from_atm) then + soil_erod_in(:ncol) = soil_erodibility(:ncol,lchnk) + else + soil_erod_in(:ncol) = 0._r8 end if + call modal_dust_emissions_run( ncol=ncol, dust_nbin=dust_nbin, & + dust_indices=dust_indices, & + dust_emis_sclfctr=dust_emis_sclfctr, & + dust_dmt_vwr=dust_dmt_vwr, & + dust_emis_fact=dust_emis_fact, & + zender_soil_erod_from_atm=zender_soil_erod_from_atm, & + soil_erodibility=soil_erod_in, & + dust_flux_in=dust_flux_in, & + pi=pi, cflx=cflx, soil_erod=soil_erod ) + end subroutine dust_emis end module dust_model diff --git a/src/chemistry/modal_aero/modal_aero_coag.F90 b/src/chemistry/modal_aero/modal_aero_coag.F90 index 5c6806ff94..3a2386a647 100644 --- a/src/chemistry/modal_aero/modal_aero_coag.F90 +++ b/src/chemistry/modal_aero/modal_aero_coag.F90 @@ -11,45 +11,55 @@ module modal_aero_coag ! !USES: use shr_kind_mod, only: r8 => shr_kind_r8 - use chem_mods, only: gas_pcnst - use modal_aero_data, only: nspec_max implicit none private save ! !PUBLIC MEMBER FUNCTIONS: - public modal_aero_coag_sub, modal_aero_coag_init + public modal_aero_coag_run, modal_aero_coag_init ! !PUBLIC DATA MEMBERS: - integer, parameter :: pcnstxx = gas_pcnst - -#if ( defined MODAL_AERO_7MODE || defined MODAL_AERO_4MODE || defined MODAL_AERO_5MODE) - integer, parameter, public :: pair_option_acoag = 3 -#elif ( defined MODAL_AERO_3MODE ) - integer, parameter, public :: pair_option_acoag = 1 -#endif + integer, protected, public :: pair_option_acoag = 0 ! specifies pairs of modes for which coagulation is calculated -! 1 -- [aitken-->accum] +! (set by modal_aero_coag_init from the host; default 0 = do no coag) +! 1 -- [aitken-->accum] ! 2 -- [aitken-->accum], and [pcarbon-->accum] -! 3 -- [aitken-->accum], [pcarbon-->accum], -! and [aitken-->pcarbon--(aging)-->accum] +! 3 -- [aitken-->accum], [pcarbon-->accum], +! and [aitken-->pcarbon--(aging)-->accum] ! other -- do no coag integer, parameter, public :: maxpair_acoag = 10 integer, protected, public :: maxspec_acoag != nspec_max - integer, protected, public :: npair_acoag +! coagulation-pair tables (host constituent-index space), handed to +! modal_aero_coag_init by the host wrapper (see modal_aero_coag_cam) + integer, protected, public :: npair_acoag = 0 integer, protected, public :: modefrm_acoag(maxpair_acoag) integer, protected, public :: modetoo_acoag(maxpair_acoag) integer, protected, public :: modetooeff_acoag(maxpair_acoag) integer, protected, public :: nspecfrm_acoag(maxpair_acoag) integer, allocatable, protected, public :: lspecfrm_acoag(:,:) integer, allocatable, protected, public :: lspectoo_acoag(:,:) - + integer :: ip_aitacc, ip_aitpca, ip_pcaacc real(r8), allocatable :: fac_m2v_aitage(:), fac_m2v_pcarbon(:) +! mode metadata from the host (set by modal_aero_coag_init); names match +! the modal_aero_data originals so the science bodies are unchanged + integer :: ntot_amode + integer :: modeptr_accum, modeptr_aitken, modeptr_pcarbon + integer, allocatable :: numptr_amode(:), mprognum_amode(:), nspec_amode(:) + integer, allocatable :: lmassptr_amode(:,:) + real(r8), allocatable :: alnsg_amode(:), sigmag_amode(:) + +! host physical constants (set by modal_aero_coag_init; passed from the host +! rather than hardcoded so the values stay bit-identical with the host's) + real(r8) :: r_universal ! universal gas constant (J/K/kmol) + real(r8) :: p0 ! standard pressure (Pa) + real(r8) :: tmelt ! freezing point of water (K) + real(r8) :: boltz ! Boltzmann constant (J/K) + ! !DESCRIPTION: This module implements ... ! ! !REVISION HISTORY: @@ -67,16 +77,19 @@ module modal_aero_coag contains !---------------------------------------------------------------------- !BOP -! !ROUTINE: modal_aero_coag_sub --- ... +! !ROUTINE: modal_aero_coag_run --- ... ! ! !INTERFACE: - subroutine modal_aero_coag_sub( & - lchnk, ncol, nstep, & - loffset, deltat_main, & + subroutine modal_aero_coag_run( & + ncol, pver, top_lev, & + num_q, loffset, nstep, & + deltat_main, & t, pmid, pdel, & q, & dgncur_a, dgncur_awet, & - wetdens_a ) + wetdens_a, & + dqdt, dotend, & + errmsg, errflg ) !---------------------------------------------------------------------- @@ -84,43 +97,45 @@ subroutine modal_aero_coag_sub( & !---------------------------------------------------------------------- ! !USES: - use mo_constants, only: pi - use modal_aero_data use modal_aero_gasaerexch, only: n_so4_monolayers_pcage - 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 ref_pres, only: top_lev => clim_modal_aero_top_lev - implicit none ! !PARAMETERS: - integer, intent(in) :: lchnk ! chunk identifier integer, intent(in) :: ncol ! number of columns in chunk - integer, intent(in) :: nstep ! model step + integer, intent(in) :: pver ! number of vertical levels + integer, intent(in) :: top_lev ! top level for modal aerosol calculations + integer, intent(in) :: num_q ! number of species in q/dqdt (= gas_pcnst) integer, intent(in) :: loffset ! offset applied to modal aero "pointers" + integer, intent(in) :: nstep ! model step (for coagulation sub-cycling) real(r8), intent(in) :: deltat_main ! model timestep (s) - real(r8), intent(in) :: t(pcols,pver) ! temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) ! pressure at model levels (Pa) - real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness of levels (Pa) + real(r8), intent(in) :: t(:,:) ! (ncol,pver) temperature (K) + real(r8), intent(in) :: pmid(:,:) ! (ncol,pver) pressure at model levels (Pa) + real(r8), intent(in) :: pdel(:,:) ! (ncol,pver) pressure thickness of levels (Pa) - real(r8), intent(inout) :: q(ncol,pver,pcnstxx) + real(r8), intent(inout) :: q(:,:,:) ! (ncol,pver,num_q) ! tracer mixing ratio (TMR) array ! *** MUST BE mol/mol-air or #/mol-air - ! *** NOTE ncol & pcnstxx dimensions - real(r8), intent(in) :: dgncur_a(pcols,pver,ntot_amode) + ! *** updated in place: number changes are + ! direct assignments, and dqdt*deltat_main + ! is NOT bit-identical to the stored change + ! (deltatinv_main carries a 1+1e-15 guard), + ! so this scheme cannot be tendency-return + real(r8), intent(in) :: dgncur_a(:,:,:) ! (ncol,pver,ntot_amode) ! dry geo. mean dia. (m) of number distrib. - real(r8), intent(in) :: dgncur_awet(pcols,pver,ntot_amode) + real(r8), intent(in) :: dgncur_awet(:,:,:) + ! (ncol,pver,ntot_amode) ! wet geo. mean dia. (m) of number distrib. - real(r8), intent(in) :: wetdens_a(pcols,pver,ntot_amode) + real(r8), intent(in) :: wetdens_a(:,:,:) ! (ncol,pver,ntot_amode) ! density of wet aerosol (kg/m3) + real(r8), intent(out) :: dqdt(:,:,:) ! (ncol,pver,num_q) TMR "dq/dt" array + ! (diagnostic only; q is updated in place) + logical, intent(out) :: dotend(:) ! (num_q) identifies the species that + ! tendencies are computed for + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! !DESCRIPTION: ! computes changes due to coagulation involving @@ -143,7 +158,7 @@ subroutine modal_aero_coag_sub( & integer :: idomode(ntot_amode), iselfcoagdone(ntot_amode) integer :: jfreqcoag, jsoa integer :: k - integer :: l, l2, lmz, lsfrm, lstoo, lunout + integer :: l, l2, lsfrm, lstoo, lunout integer :: modefrm, modetoo, mait, macc, mpca integer :: n, nfreqcoag @@ -176,14 +191,15 @@ subroutine modal_aero_coag_sub( & real(r8) :: ybetaij0(maxpair_acoag), ybetaij3(maxpair_acoag) real(r8) :: ybetaii0(maxpair_acoag), ybetajj0(maxpair_acoag) - real(r8) :: dqdt(ncol,pver,pcnstxx) ! TMR "dq/dt" array - NOTE dims - logical :: dotend(pcnst) ! identifies the species that - ! tendencies are computed for - real(r8) :: qsrflx(pcols) +! begin + errmsg = ' ' + errflg = 0 - character(len=fieldname_len+3) :: fieldname +! zero the tendency outputs up front: they are intent(out) and the caller +! uses them unconditionally, including on the bypass paths below + dotend(:) = .false. + dqdt(1:ncol,:,:) = 0.0_r8 -! begin ! check if any coagulation pairs exist if (npair_acoag <= 0) return @@ -204,9 +220,6 @@ subroutine modal_aero_coag_sub( & !!$ end if ! (ldiag1 > 0) !-------------------------------------------------------------------------------- - dotend(:) = .false. - dqdt(1:ncol,:,:) = 0.0_r8 - lunout = 6 @@ -583,7 +596,9 @@ subroutine modal_aero_coag_sub( & write(lunout,*) '*** modal_aero_coag_sub error' write(lunout,*) ' cannot do _coag_sub error pair_option_acoag =', & pair_option_acoag - call endrun( 'modal_aero_coag_sub error' ) + errmsg = 'modal_aero_coag_sub error' + errflg = 1 + return end if ! (pair_option_acoag == ...) @@ -682,345 +697,120 @@ subroutine modal_aero_coag_sub( & end do -! do history file column-tendency fields - do l = loffset+1, pcnst - lmz = l - loffset - if ( .not. dotend(lmz) ) cycle - - qsrflx(:) = 0.0_r8 - do k = top_lev, pver - do i = 1, ncol - qsrflx(i) = qsrflx(i) + dqdt(i,k,lmz)*pdel(i,k) - end do - end do - qsrflx(:) = qsrflx(:)*(adv_mass(lmz)/(gravit*mwdry)) - fieldname = trim(cnst_name(l)) // '_sfcoag1' - call outfld( fieldname, qsrflx, pcols, lchnk ) -! if (( masterproc ) .and. (nstep < 1)) & -! write(*,'(2(a,2x),1p,e11.3)') & -! 'modal_aero_coag_sub outfld', fieldname, adv_mass(lmz) - end do ! l = ... +! history file column-tendency fields (column integral of dqdt with +! adv_mass/mwdry scaling + outfld) are done by the caller, which owns +! the host constituent metadata return !EOC - end subroutine modal_aero_coag_sub + end subroutine modal_aero_coag_run !---------------------------------------------------------------------- !---------------------------------------------------------------------- - subroutine modal_aero_coag_init + subroutine modal_aero_coag_init( pair_option_acoag_in, & + npair_acoag_in, modefrm_acoag_in, modetoo_acoag_in, & + modetooeff_acoag_in, nspecfrm_acoag_in, & + lspecfrm_acoag_in, lspectoo_acoag_in, & + ip_aitacc_in, ip_aitpca_in, ip_pcaacc_in, & + fac_m2v_aitage_in, fac_m2v_pcarbon_in, & + nspec_max_in, ntot_amode_in, & + modeptr_accum_in, modeptr_aitken_in, modeptr_pcarbon_in, & + numptr_amode_in, mprognum_amode_in, nspec_amode_in, & + lmassptr_amode_in, alnsg_amode_in, sigmag_amode_in, & + r_universal_in, pstd_in, tmelt_in, boltz_in, & + errmsg, errflg ) ! -! computes pointers for species transfer during coagulation +! store the resolved coagulation-pair tables, mode metadata, and host +! physical constants used by modal_aero_coag_run +! pair/species resolution and history-field registration are host +! responsibilities (see modal_aero_coag_cam) ! - use modal_aero_data - use modal_aero_gasaerexch, only: & - modefrm_pcage, nspecfrm_pcage, lspecfrm_pcage, lspectoo_pcage, & - soa_equivso4_factor - - use cam_abortutils, only: endrun - use cam_history, only: addfld, add_default, fieldname_len, horiz_only - use constituents, only: pcnst, cnst_name - use spmd_utils, only: masterproc - use phys_control, only: phys_getopts - implicit none -! local variables - integer :: ipair, iq, iqfrm, iqfrm_aa, iqtoo, iqtoo_aa - integer :: jsoa - integer :: l, l1, l2, lsfrm, lstoo, lunout - integer :: m, mait, mpca, mfrm, mtoo, mtef - integer :: nchfrm, nchfrmskip, nchtoo, nchtooskip, nspec - - character(len=fieldname_len) :: tmpname - character(len=fieldname_len+3) :: fieldname - character(128) :: long_name - character(8) :: unit - - logical :: dotend(pcnst) - logical :: history_aerosol ! Output the MAM aerosol tendencies - - character(len=200) :: msg - - !----------------------------------------------------------------------- - - call phys_getopts( history_aerosol_out = history_aerosol ) - - lunout = 6 - - maxspec_acoag = nspec_max - allocate( lspecfrm_acoag(maxspec_acoag,maxpair_acoag) ) - allocate( lspectoo_acoag(maxspec_acoag,maxpair_acoag) ) - allocate( fac_m2v_aitage(nspec_max), fac_m2v_pcarbon(nspec_max) ) - -! -! define "from mode" and "to mode" for each coagulation pairing -! currently just a2-->a1 coagulation -! - if (pair_option_acoag == 1) then - npair_acoag = 1 - modefrm_acoag(1) = modeptr_aitken - modetoo_acoag(1) = modeptr_accum - modetooeff_acoag(1) = modeptr_accum - else if (pair_option_acoag == 2) then - npair_acoag = 2 - modefrm_acoag(1) = modeptr_aitken - modetoo_acoag(1) = modeptr_accum - modetooeff_acoag(1) = modeptr_accum - modefrm_acoag(2) = modeptr_pcarbon - modetoo_acoag(2) = modeptr_accum - modetooeff_acoag(2) = modeptr_accum - else if (pair_option_acoag == 3) then - npair_acoag = 3 - modefrm_acoag(1) = modeptr_aitken - modetoo_acoag(1) = modeptr_accum - modetooeff_acoag(1) = modeptr_accum - modefrm_acoag(2) = modeptr_pcarbon - modetoo_acoag(2) = modeptr_accum - modetooeff_acoag(2) = modeptr_accum - modefrm_acoag(3) = modeptr_aitken - 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 =', & - pair_option_acoag, modefrm_pcage - call endrun( 'modal_aero_coag_init error' ) - end if - else - npair_acoag = 0 - return - end if - -! -! define species involved in each coagulation pairing -! (include aerosol water) -! -aa_ipair: do ipair = 1, npair_acoag - - mfrm = modefrm_acoag(ipair) - mtoo = modetoo_acoag(ipair) - mtef = modetooeff_acoag(ipair) - 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 - call endrun( 'modal_aero_coag_init error' ) - end if - - - mtoo = mtef ! effective modetoo - 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) - lsfrm = lmassptr_amode(iqfrm,mfrm) - if ((lsfrm .lt. 1) .or. (lsfrm .gt. pcnst)) cycle aa_iqfrm - nchfrm = len( trim( cnst_name(lsfrm) ) ) - nchfrmskip -! find "too" species having same lspectype_amode as the "frm" species -! AND same cnst_name (except for last 1/2/3 characters which are the mode index) - do iqtoo = 1, nspec_amode(mtoo) - lstoo = lmassptr_amode(iqtoo,mtoo) - nchtoo = len( trim( cnst_name(lstoo) ) ) - nchtooskip - if (cnst_name(lsfrm)(1:nchfrm) == cnst_name(lstoo)(1:nchtoo)) then - exit - else - lstoo = 0 - end if - end do - - if ((lstoo < 1) .or. (lstoo > pcnst)) lstoo = 0 - nspec = nspec + 1 - lspecfrm_acoag(nspec,ipair) = lsfrm - lspectoo_acoag(nspec,ipair) = lstoo - end do aa_iqfrm - -! lsfrm = lwaterptr_amode(mfrm) -! if ((lsfrm .ge. 1) .and. (lsfrm .le. pcnst)) then -! lstoo = lwaterptr_amode(mtoo) -! if ((lstoo .lt. 1) .or. (lstoo .gt. pcnst)) lstoo = 0 -! nspec = nspec + 1 -! lspecfrm_acoag(nspec,ipair) = lsfrm -! lspectoo_acoag(nspec,ipair) = lstoo -! end if - - nspecfrm_acoag(ipair) = nspec - end do aa_ipair - -! -! output results -! - if ( masterproc ) then - - write(lunout,9310) - - do ipair = 1, npair_acoag - mfrm = modefrm_acoag(ipair) - mtoo = modetoo_acoag(ipair) - mtef = modetooeff_acoag(ipair) - write(lunout,9320) ipair, mfrm, mtoo, mtef - - do iq = 1, nspecfrm_acoag(ipair) - lsfrm = lspecfrm_acoag(iq,ipair) - lstoo = lspectoo_acoag(iq,ipair) - if (lstoo .gt. 0) then - write(lunout,9330) lsfrm, cnst_name(lsfrm), & - lstoo, cnst_name(lstoo) - else - write(lunout,9340) lsfrm, cnst_name(lsfrm) - end if - end do - - end do ! ipair = ... - write(lunout,*) - - end if ! ( masterproc ) - -9310 format( / 'subr. modal_aero_coag_init' ) -9320 format( 'pair', i3, 5x, 'mode', i3, & - ' ---> mode', i3, ' eff', i3 ) -9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a ) -9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' ) - -! set following variables that are used in modal_aero_coag_subr -! - fac_m2v_aitage(:) = 0.0_r8 - fac_m2v_pcarbon(:) = 0.0_r8 - if (pair_option_acoag == 3) then -! following ipair definitions MUST BE CONSISTENT with -! the coding in modal_aero_coag_init for pair_option_acoag == 3 - ip_aitacc = 1 - ip_pcaacc = 2 - ip_aitpca = 3 - - mait = modeptr_aitken - mpca = modeptr_pcarbon - - ipair = ip_aitpca - do iq = 1, nspecfrm_acoag(ipair) - lsfrm = lspecfrm_acoag(iq,ipair) - l2 = -1 - do l1 = 1, nspec_amode(mait) - if (lmassptr_amode(l1,mait) == lsfrm) then - l2 = l1 - exit - end if - end do - if (l2 <= 0) then - write( msg, '(a,5(1x,i12))' ) & - 'modal_aero_coag_init error a001 for ipair, iq, lsfrm', & - ipair, iq, lsfrm - call endrun( msg ) - end if - if (lsfrm == lptr_so4_a_amode(mait)) then -! fac_m2v_aitage(iq) = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_aitage(iq) = specmw_amode(l1,mait) / specdens_amode(l1,mait) - else if (lsfrm == lptr_nh4_a_amode(mait)) then -! fac_m2v_aitage(iq) = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_aitage(iq) = specmw_amode(l1,mait) / specdens_amode(l1,mait) - else - do jsoa = 1, nsoa - if (lsfrm == lptr2_soa_a_amode(mait,jsoa)) then - fac_m2v_aitage(iq) = soa_equivso4_factor(jsoa)* & - !(specmw_amode(l2) / specdens_amode(l2)) - (specmw_amode(l1,mait) / specdens_amode(l1,mait)) - end if -! for soa, the soa_equivso4_factor converts the soa volume into an -! so4(+nh4) volume that has same hygroscopicity contribution as soa -! this allows aging calculations to be done in terms of the amount -! of (equivalent) so4(+nh4) in the shell -! (see modal_aero_gasaerexch) - end do - end if - end do - - do l = 1, nspec_amode(mpca) -!B l2 = lspectype_amode(l,mpca) -! fac_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) -! [m3-AP/kmol-AP] = [kg-AP/kmol-AP] / [kg-AP/m3-AP] -! fac_m2v_pcarbon(l) = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_pcarbon(l) = specmw_amode(l,mpca) / specdens_amode(l,mpca) - end do - - else - ip_aitacc = -999888777 - ip_pcaacc = -999888777 - ip_aitpca = -999888777 - end if - -! -! create history file column-tendency fields -! - dotend(:) = .false. - do ipair = 1, npair_acoag - do iq = 1, nspecfrm_acoag(ipair) - l = lspecfrm_acoag(iq,ipair) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - l = lspectoo_acoag(iq,ipair) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end do - - m = modefrm_acoag(ipair) - if ((m > 0) .and. (m <= ntot_amode)) then - l = numptr_amode(m) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end if - m = modetoo_acoag(ipair) - if ((m > 0) .and. (m <= ntot_amode)) then - l = numptr_amode(m) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end if - end do ! ipair = ... - - if (pair_option_acoag == 3) then - do iq = 1, nspecfrm_pcage - lsfrm = lspecfrm_pcage(iq) - lstoo = lspectoo_pcage(iq) - if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then - dotend(lsfrm) = .true. - if ((lstoo > 0) .and. (lstoo <= pcnst)) then - dotend(lstoo) = .true. - end if - end if - end do - end if - - do l = 1, pcnst - if ( .not. dotend(l) ) cycle - tmpname = cnst_name(l) - unit = 'kg/m2/s' - do m = 1, ntot_amode - if (l == numptr_amode(m)) unit = '#/m2/s' - end do - fieldname = trim(tmpname) // '_sfcoag1' - long_name = trim(tmpname) // ' modal_aero coagulation column tendency' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,2x))') & - 'modal_aero_coag_init addfld', fieldname, unit - end do ! l = ... - +! arguments + integer, intent(in) :: pair_option_acoag_in ! pair selection (see module header) + integer, intent(in) :: npair_acoag_in ! number of coagulation pairs + integer, intent(in) :: modefrm_acoag_in(:) ! (maxpair_acoag) "from" mode of each pair + integer, intent(in) :: modetoo_acoag_in(:) ! (maxpair_acoag) "too" mode of each pair + integer, intent(in) :: modetooeff_acoag_in(:) ! (maxpair_acoag) effective "too" mode of each pair + integer, intent(in) :: nspecfrm_acoag_in(:) ! (maxpair_acoag) species count of each pair + integer, intent(in) :: lspecfrm_acoag_in(:,:) ! (nspec_max,maxpair_acoag) "from" species + ! indices (host constituent space) + integer, intent(in) :: lspectoo_acoag_in(:,:) ! (nspec_max,maxpair_acoag) "too" species + ! indices (host constituent space) + integer, intent(in) :: ip_aitacc_in ! pair index of [aitken-->accum] + integer, intent(in) :: ip_aitpca_in ! pair index of [aitken-->pcarbon] + integer, intent(in) :: ip_pcaacc_in ! pair index of [pcarbon-->accum] + real(r8), intent(in) :: fac_m2v_aitage_in(:) ! (nspec_max) mixing-ratio to volume factors + real(r8), intent(in) :: fac_m2v_pcarbon_in(:) ! (nspec_max) for aging shell/core calcs + integer, intent(in) :: nspec_max_in ! max number of species in a mode + integer, intent(in) :: ntot_amode_in ! number of aerosol modes + integer, intent(in) :: modeptr_accum_in ! accumulation mode index + integer, intent(in) :: modeptr_aitken_in ! aitken mode index + integer, intent(in) :: modeptr_pcarbon_in ! primary carbon mode index + integer, intent(in) :: numptr_amode_in(:) ! (ntot_amode) number indices (host constituent space) + integer, intent(in) :: mprognum_amode_in(:) ! (ntot_amode) prognostic-number flags + integer, intent(in) :: nspec_amode_in(:) ! (ntot_amode) species counts + integer, intent(in) :: lmassptr_amode_in(:,:) ! (nspec_max,ntot_amode) mass indices + ! (host constituent space) + real(r8), intent(in) :: alnsg_amode_in(:) ! (ntot_amode) ln(sigmag) + real(r8), intent(in) :: sigmag_amode_in(:) ! (ntot_amode) geometric standard deviation + real(r8), intent(in) :: r_universal_in ! universal gas constant (J/K/kmol) + real(r8), intent(in) :: pstd_in ! standard pressure (Pa) + real(r8), intent(in) :: tmelt_in ! freezing point of water (K) + real(r8), intent(in) :: boltz_in ! Boltzmann constant (J/K) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = ' ' + errflg = 0 + + pair_option_acoag = pair_option_acoag_in + + maxspec_acoag = nspec_max_in + allocate( lspecfrm_acoag(maxspec_acoag,maxpair_acoag) ) + allocate( lspectoo_acoag(maxspec_acoag,maxpair_acoag) ) + allocate( fac_m2v_aitage(nspec_max_in), fac_m2v_pcarbon(nspec_max_in) ) + + npair_acoag = npair_acoag_in + modefrm_acoag(:) = modefrm_acoag_in(:) + modetoo_acoag(:) = modetoo_acoag_in(:) + modetooeff_acoag(:) = modetooeff_acoag_in(:) + nspecfrm_acoag(:) = nspecfrm_acoag_in(:) + lspecfrm_acoag(:,:) = lspecfrm_acoag_in(:,:) + lspectoo_acoag(:,:) = lspectoo_acoag_in(:,:) + + ip_aitacc = ip_aitacc_in + ip_aitpca = ip_aitpca_in + ip_pcaacc = ip_pcaacc_in + + fac_m2v_aitage(:) = fac_m2v_aitage_in(:) + fac_m2v_pcarbon(:) = fac_m2v_pcarbon_in(:) + + ntot_amode = ntot_amode_in + modeptr_accum = modeptr_accum_in + modeptr_aitken = modeptr_aitken_in + modeptr_pcarbon = modeptr_pcarbon_in + + allocate( numptr_amode(ntot_amode_in), mprognum_amode(ntot_amode_in), & + nspec_amode(ntot_amode_in) ) + allocate( lmassptr_amode(nspec_max_in,ntot_amode_in) ) + allocate( alnsg_amode(ntot_amode_in), sigmag_amode(ntot_amode_in) ) + numptr_amode(:) = numptr_amode_in(:) + mprognum_amode(:) = mprognum_amode_in(:) + nspec_amode(:) = nspec_amode_in(:) + lmassptr_amode(:,:) = lmassptr_amode_in(:,:) + alnsg_amode(:) = alnsg_amode_in(:) + sigmag_amode(:) = sigmag_amode_in(:) + + r_universal = r_universal_in + p0 = pstd_in + tmelt = tmelt_in + boltz = boltz_in return end subroutine modal_aero_coag_init @@ -1035,9 +825,8 @@ subroutine getcoags_wrapper_f( & pdensat, pdensac, & betaij0, betaij2i, betaij2j, betaij3, & betaii0, betaii2, betajj0, betajj2 ) - use physconst, only: p0 => pstd, & - tmelt, & - boltz +! (p0, tmelt, boltz are module-level host constants +! set by modal_aero_coag_init) ! ! interface to subr. getcoags ! diff --git a/src/chemistry/modal_aero/modal_aero_coag_cam.F90 b/src/chemistry/modal_aero/modal_aero_coag_cam.F90 new file mode 100644 index 0000000000..ef78f2e702 --- /dev/null +++ b/src/chemistry/modal_aero/modal_aero_coag_cam.F90 @@ -0,0 +1,416 @@ +! CAM wrapper for modal_aero_coag. +! Owns the pair_option_acoag build-time selection, resolves the +! coagulation-pair tables from CAM constituent metadata (with the pcage +! aging tables from modal_aero_gasaerexch), hands them (with the mode +! metadata and host physical constants) to the portable +! modal_aero_coag_init, and registers history fields. +!---------------------------------------------------------------------- + module modal_aero_coag_cam + +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + public :: modal_aero_coag_cam_init + +#if ( defined MODAL_AERO_7MODE || defined MODAL_AERO_4MODE || defined MODAL_AERO_5MODE) + integer, parameter :: pair_option_acoag = 3 +#elif ( defined MODAL_AERO_3MODE ) + integer, parameter :: pair_option_acoag = 1 +#endif +! specifies pairs of modes for which coagulation is calculated +! 1 -- [aitken-->accum] +! 2 -- [aitken-->accum], and [pcarbon-->accum] +! 3 -- [aitken-->accum], [pcarbon-->accum], +! and [aitken-->pcarbon--(aging)-->accum] +! other -- do no coag + +!---------------------------------------------------------------------- +contains + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + subroutine modal_aero_coag_cam_init +! +! computes pointers for species transfer during coagulation +! and hands them to the portable modal_aero_coag_init +! + use modal_aero_coag, only: modal_aero_coag_init, maxpair_acoag + use modal_aero_data + use modal_aero_gasaerexch, only: & + modefrm_pcage, nspecfrm_pcage, lspecfrm_pcage, lspectoo_pcage, & + soa_equivso4_factor + + use cam_abortutils, only: endrun + use cam_history, only: addfld, add_default, fieldname_len, horiz_only + use constituents, only: pcnst, cnst_name + use physconst, only: r_universal, pstd, tmelt, boltz + use spmd_utils, only: masterproc + use phys_control, only: phys_getopts + + implicit none + +! local variables + integer :: ipair, iq, iqfrm, iqfrm_aa, iqtoo, iqtoo_aa + integer :: jsoa + integer :: l, l1, l2, lsfrm, lstoo, lunout + integer :: m, mait, mpca, mfrm, mtoo, mtef + integer :: nchfrm, nchfrmskip, nchtoo, nchtooskip, nspec + +! resolved coagulation-pair tables (host constituent-index space), +! handed to the portable modal_aero_coag_init at the end + integer :: maxspec_acoag + integer :: npair_acoag + integer :: modefrm_acoag(maxpair_acoag) + integer :: modetoo_acoag(maxpair_acoag) + integer :: modetooeff_acoag(maxpair_acoag) + integer :: nspecfrm_acoag(maxpair_acoag) + integer, allocatable :: lspecfrm_acoag(:,:) + integer, allocatable :: lspectoo_acoag(:,:) + integer :: ip_aitacc, ip_aitpca, ip_pcaacc + real(r8), allocatable :: fac_m2v_aitage(:), fac_m2v_pcarbon(:) + + character(len=fieldname_len) :: tmpname + character(len=fieldname_len+3) :: fieldname + character(128) :: long_name + character(8) :: unit + + logical :: dotend(pcnst) + logical :: history_aerosol ! Output the MAM aerosol tendencies + + character(len=200) :: msg + + character(len=512) :: errmsg + integer :: errflg + + !----------------------------------------------------------------------- + call phys_getopts( history_aerosol_out = history_aerosol ) + + lunout = 6 + + maxspec_acoag = nspec_max + allocate( lspecfrm_acoag(maxspec_acoag,maxpair_acoag) ) + allocate( lspectoo_acoag(maxspec_acoag,maxpair_acoag) ) + allocate( fac_m2v_aitage(nspec_max), fac_m2v_pcarbon(nspec_max) ) + +! default-initialize the tables so the unused slots are well-defined when +! the whole arrays are handed to the portable modal_aero_coag_init + modefrm_acoag(:) = 0 + modetoo_acoag(:) = 0 + modetooeff_acoag(:) = 0 + nspecfrm_acoag(:) = 0 + lspecfrm_acoag(:,:) = 0 + lspectoo_acoag(:,:) = 0 + +! +! define "from mode" and "to mode" for each coagulation pairing +! currently just a2-->a1 coagulation +! + if (pair_option_acoag == 1) then + npair_acoag = 1 + modefrm_acoag(1) = modeptr_aitken + modetoo_acoag(1) = modeptr_accum + modetooeff_acoag(1) = modeptr_accum + else if (pair_option_acoag == 2) then + npair_acoag = 2 + modefrm_acoag(1) = modeptr_aitken + modetoo_acoag(1) = modeptr_accum + modetooeff_acoag(1) = modeptr_accum + modefrm_acoag(2) = modeptr_pcarbon + modetoo_acoag(2) = modeptr_accum + modetooeff_acoag(2) = modeptr_accum + else if (pair_option_acoag == 3) then + npair_acoag = 3 + modefrm_acoag(1) = modeptr_aitken + modetoo_acoag(1) = modeptr_accum + modetooeff_acoag(1) = modeptr_accum + modefrm_acoag(2) = modeptr_pcarbon + modetoo_acoag(2) = modeptr_accum + modetooeff_acoag(2) = modeptr_accum + modefrm_acoag(3) = modeptr_aitken + 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 =', & + pair_option_acoag, modefrm_pcage + call endrun( 'modal_aero_coag_init error' ) + end if + else + npair_acoag = 0 + return + end if + +! +! define species involved in each coagulation pairing +! (include aerosol water) +! +aa_ipair: do ipair = 1, npair_acoag + + mfrm = modefrm_acoag(ipair) + mtoo = modetoo_acoag(ipair) + mtef = modetooeff_acoag(ipair) + 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 + call endrun( 'modal_aero_coag_init error' ) + end if + + + mtoo = mtef ! effective modetoo + 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) + lsfrm = lmassptr_amode(iqfrm,mfrm) + if ((lsfrm .lt. 1) .or. (lsfrm .gt. pcnst)) cycle aa_iqfrm + nchfrm = len( trim( cnst_name(lsfrm) ) ) - nchfrmskip +! find "too" species having same lspectype_amode as the "frm" species +! AND same cnst_name (except for last 1/2/3 characters which are the mode index) + do iqtoo = 1, nspec_amode(mtoo) + lstoo = lmassptr_amode(iqtoo,mtoo) + nchtoo = len( trim( cnst_name(lstoo) ) ) - nchtooskip + if (cnst_name(lsfrm)(1:nchfrm) == cnst_name(lstoo)(1:nchtoo)) then + exit + else + lstoo = 0 + end if + end do + + if ((lstoo < 1) .or. (lstoo > pcnst)) lstoo = 0 + nspec = nspec + 1 + lspecfrm_acoag(nspec,ipair) = lsfrm + lspectoo_acoag(nspec,ipair) = lstoo + end do aa_iqfrm + +! lsfrm = lwaterptr_amode(mfrm) +! if ((lsfrm .ge. 1) .and. (lsfrm .le. pcnst)) then +! lstoo = lwaterptr_amode(mtoo) +! if ((lstoo .lt. 1) .or. (lstoo .gt. pcnst)) lstoo = 0 +! nspec = nspec + 1 +! lspecfrm_acoag(nspec,ipair) = lsfrm +! lspectoo_acoag(nspec,ipair) = lstoo +! end if + + nspecfrm_acoag(ipair) = nspec + end do aa_ipair + +! +! output results +! + if ( masterproc ) then + + write(lunout,9310) + + do ipair = 1, npair_acoag + mfrm = modefrm_acoag(ipair) + mtoo = modetoo_acoag(ipair) + mtef = modetooeff_acoag(ipair) + write(lunout,9320) ipair, mfrm, mtoo, mtef + + do iq = 1, nspecfrm_acoag(ipair) + lsfrm = lspecfrm_acoag(iq,ipair) + lstoo = lspectoo_acoag(iq,ipair) + if (lstoo .gt. 0) then + write(lunout,9330) lsfrm, cnst_name(lsfrm), & + lstoo, cnst_name(lstoo) + else + write(lunout,9340) lsfrm, cnst_name(lsfrm) + end if + end do + + end do ! ipair = ... + write(lunout,*) + + end if ! ( masterproc ) + +9310 format( / 'subr. modal_aero_coag_init' ) +9320 format( 'pair', i3, 5x, 'mode', i3, & + ' ---> mode', i3, ' eff', i3 ) +9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a ) +9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' ) + +! set following variables that are used in modal_aero_coag_subr +! + fac_m2v_aitage(:) = 0.0_r8 + fac_m2v_pcarbon(:) = 0.0_r8 + if (pair_option_acoag == 3) then +! following ipair definitions MUST BE CONSISTENT with +! the coding in modal_aero_coag_init for pair_option_acoag == 3 + ip_aitacc = 1 + ip_pcaacc = 2 + ip_aitpca = 3 + + mait = modeptr_aitken + mpca = modeptr_pcarbon + + ipair = ip_aitpca + do iq = 1, nspecfrm_acoag(ipair) + lsfrm = lspecfrm_acoag(iq,ipair) + l2 = -1 + do l1 = 1, nspec_amode(mait) + if (lmassptr_amode(l1,mait) == lsfrm) then + l2 = l1 + exit + end if + end do + if (l2 <= 0) then + write( msg, '(a,5(1x,i12))' ) & + 'modal_aero_coag_init error a001 for ipair, iq, lsfrm', & + ipair, iq, lsfrm + call endrun( msg ) + end if + if (lsfrm == lptr_so4_a_amode(mait)) then +! fac_m2v_aitage(iq) = specmw_amode(l2) / specdens_amode(l2) + fac_m2v_aitage(iq) = specmw_amode(l1,mait) / specdens_amode(l1,mait) + else if (lsfrm == lptr_nh4_a_amode(mait)) then +! fac_m2v_aitage(iq) = specmw_amode(l2) / specdens_amode(l2) + fac_m2v_aitage(iq) = specmw_amode(l1,mait) / specdens_amode(l1,mait) + else + do jsoa = 1, nsoa + if (lsfrm == lptr2_soa_a_amode(mait,jsoa)) then + fac_m2v_aitage(iq) = soa_equivso4_factor(jsoa)* & + !(specmw_amode(l2) / specdens_amode(l2)) + (specmw_amode(l1,mait) / specdens_amode(l1,mait)) + end if +! for soa, the soa_equivso4_factor converts the soa volume into an +! so4(+nh4) volume that has same hygroscopicity contribution as soa +! this allows aging calculations to be done in terms of the amount +! of (equivalent) so4(+nh4) in the shell +! (see modal_aero_gasaerexch) + end do + end if + end do + + do l = 1, nspec_amode(mpca) +!B l2 = lspectype_amode(l,mpca) +! fac_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) +! [m3-AP/kmol-AP] = [kg-AP/kmol-AP] / [kg-AP/m3-AP] +! fac_m2v_pcarbon(l) = specmw_amode(l2) / specdens_amode(l2) + fac_m2v_pcarbon(l) = specmw_amode(l,mpca) / specdens_amode(l,mpca) + end do + + else + ip_aitacc = -999888777 + ip_pcaacc = -999888777 + ip_aitpca = -999888777 + end if + +! hand the resolved tables, mode metadata, and host physical constants +! to the portable scheme + call modal_aero_coag_init( & + pair_option_acoag_in = pair_option_acoag, & + npair_acoag_in = npair_acoag, & + modefrm_acoag_in = modefrm_acoag, & + modetoo_acoag_in = modetoo_acoag, & + modetooeff_acoag_in = modetooeff_acoag, & + nspecfrm_acoag_in = nspecfrm_acoag, & + lspecfrm_acoag_in = lspecfrm_acoag, & + lspectoo_acoag_in = lspectoo_acoag, & + ip_aitacc_in = ip_aitacc, & + ip_aitpca_in = ip_aitpca, & + ip_pcaacc_in = ip_pcaacc, & + fac_m2v_aitage_in = fac_m2v_aitage, & + fac_m2v_pcarbon_in = fac_m2v_pcarbon, & + nspec_max_in = nspec_max, & + ntot_amode_in = ntot_amode, & + modeptr_accum_in = modeptr_accum, & + modeptr_aitken_in = modeptr_aitken, & + modeptr_pcarbon_in = modeptr_pcarbon, & + numptr_amode_in = numptr_amode, & + mprognum_amode_in = mprognum_amode, & + nspec_amode_in = nspec_amode, & + lmassptr_amode_in = lmassptr_amode, & + alnsg_amode_in = alnsg_amode, & + sigmag_amode_in = sigmag_amode, & + r_universal_in = r_universal, & + pstd_in = pstd, & + tmelt_in = tmelt, & + boltz_in = boltz, & + errmsg = errmsg, & + errflg = errflg ) + + if (errflg /= 0) then + call endrun('modal_aero_coag_cam_init: '//trim(errmsg)) + end if + +! +! create history file column-tendency fields +! + dotend(:) = .false. + do ipair = 1, npair_acoag + do iq = 1, nspecfrm_acoag(ipair) + l = lspecfrm_acoag(iq,ipair) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + l = lspectoo_acoag(iq,ipair) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end do + + m = modefrm_acoag(ipair) + if ((m > 0) .and. (m <= ntot_amode)) then + l = numptr_amode(m) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end if + m = modetoo_acoag(ipair) + if ((m > 0) .and. (m <= ntot_amode)) then + l = numptr_amode(m) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end if + end do ! ipair = ... + + if (pair_option_acoag == 3) then + do iq = 1, nspecfrm_pcage + lsfrm = lspecfrm_pcage(iq) + lstoo = lspectoo_pcage(iq) + if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then + dotend(lsfrm) = .true. + if ((lstoo > 0) .and. (lstoo <= pcnst)) then + dotend(lstoo) = .true. + end if + end if + end do + end if + + do l = 1, pcnst + if ( .not. dotend(l) ) cycle + tmpname = cnst_name(l) + unit = 'kg/m2/s' + do m = 1, ntot_amode + if (l == numptr_amode(m)) unit = '#/m2/s' + end do + fieldname = trim(tmpname) // '_sfcoag1' + long_name = trim(tmpname) // ' modal_aero coagulation column tendency' + call addfld( fieldname, horiz_only, 'A', unit, long_name ) + if ( history_aerosol ) then + call add_default( fieldname, 1, ' ' ) + endif + if ( masterproc ) write(*,'(3(a,2x))') & + 'modal_aero_coag_init addfld', fieldname, unit + end do ! l = ... + + + return + end subroutine modal_aero_coag_cam_init + + end module modal_aero_coag_cam diff --git a/src/chemistry/modal_aero/modal_aero_gasaerexch.F90 b/src/chemistry/modal_aero/modal_aero_gasaerexch.F90 index 8b36461075..dcc1b19c5b 100644 --- a/src/chemistry/modal_aero/modal_aero_gasaerexch.F90 +++ b/src/chemistry/modal_aero/modal_aero_gasaerexch.F90 @@ -1,222 +1,502 @@ -! modal_aero_gasaerexch.F90 - - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -!BOP -! -! !MODULE: modal_aero_gasaerexch --- does modal aerosol gas-aerosol exchange -! -! !INTERFACE: - module modal_aero_gasaerexch - -! !USES: - use shr_kind_mod, only: r8 => shr_kind_r8 - use chem_mods, only: gas_pcnst - use modal_aero_data, only: nspec_max, nsoa, npoa, soa_multi_species - use ref_pres, only: top_lev => clim_modal_aero_top_lev - use ppgrid, only: pcols, pver - use modal_aero_data, only: ntot_amode, numptr_amode, sigmag_amode - use modal_aero_data, only: lptr2_soa_g_amode, lptr2_soa_a_amode, lptr2_pom_a_amode +! Portable code for modal aerosol gas-aerosol exchange. +! RCE 07.04.13: Adapted from MIRAGE2 code +module modal_aero_gasaerexch + use shr_kind_mod, only: r8 => shr_kind_r8 implicit none private save -! !PUBLIC MEMBER FUNCTIONS: - public modal_aero_gasaerexch_sub, modal_aero_gasaerexch_init + public :: modal_aero_gasaerexch_init + public :: modal_aero_gasaerexch_run -! !PUBLIC DATA MEMBERS: - integer, parameter :: pcnstxx = gas_pcnst - integer, protected, public :: maxspec_pcage != nspec_max + ! Primary-carbon aging (pcage) configuration: species are transferred from + ! the primary-carbon mode (modefrm) to the accumulation mode (modetoo) when + ! enough sulfate monolayers coat the particle. + integer, protected, public :: maxspec_pcage ! max number of species that can be aged - integer, protected, public :: modefrm_pcage - integer, protected, public :: nspecfrm_pcage - integer :: modetoo_pcage + integer, protected, public :: modefrm_pcage ! source mode index for aging transfer + integer, protected, public :: nspecfrm_pcage ! number of species transferred during aging - integer, protected, allocatable, public :: lspecfrm_pcage(:) - integer, protected, allocatable, public :: lspectoo_pcage(:) + integer, protected, allocatable, public :: lspecfrm_pcage(:) ! pcnst indices of species in source mode + integer, protected, allocatable, public :: lspectoo_pcage(:) ! pcnst indices of corresponding species in dest mode real(r8), parameter, public :: n_so4_monolayers_pcage = 8.0_r8 -! number of so4(+nh4) monolayers needed to "age" a carbon particle - + ! number of so4(+nh4) monolayers needed to "age" a carbon particle + ! 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 real(r8), parameter, public :: & dr_so4_monolayers_pcage = n_so4_monolayers_pcage * 4.76e-10_r8 -! 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 + ! this factor converts an soa volume to a volume of so4(+nh4) + ! having same hygroscopicity as the soa real(r8), protected, allocatable, public :: soa_equivso4_factor(:) -! this factor converts an soa volume to a volume of so4(+nh4) -! having same hygroscopicity as the soa + ! Private module-level storage: + + ! Mode configuration + integer :: ntot_amode_m, nsoa_m, npoa_m, nspec_max_m + integer, allocatable :: nspec_amode_m(:) + + ! Species indices in pcnst-space (set by _init, converted to vmr-space in _run) + integer :: idx_h2so4_m, idx_nh3_m, idx_msa_m + integer, allocatable :: idx_soag_m(:) + integer, allocatable :: idx_so4_a_m(:), idx_nh4_a_m(:) + integer, allocatable :: idx_soa_a_m(:,:), idx_pom_a_m(:,:) + integer, allocatable :: idx_num_m(:), idx_mass_m(:,:) + + ! Mode metadata + real(r8), allocatable :: alnsg_amode_m(:), sigmag_amode_m(:) + real(r8), allocatable :: specmw_amode_m(:,:), specdens_amode_m(:,:) + + ! Flags + logical :: do_nh4g_m, do_msag_m, do_soag_any_m + logical, allocatable :: do_soag_m(:) + + ! Species presence in modes + integer, allocatable :: ido_so4a_m(:), ido_nh4a_m(:), ido_soaa_m(:,:) + integer :: ntot_soamode_m + + ! pcage and pcarbon + integer :: modetoo_pcage + integer :: modeptr_pcarbon_m + + ! Mass-to-volume conversion factors real (r8) :: fac_m2v_nh4, fac_m2v_so4 real (r8), allocatable :: fac_m2v_soa(:) real (r8), allocatable :: fac_m2v_pcarbon(:) -! !DESCRIPTION: This module implements ... -! -! !REVISION HISTORY: -! -! RCE 07.04.13: Adapted from MIRAGE2 code -! -!EOP -!---------------------------------------------------------------------- -!BOC + ! SOA/POA molecular weights from host model + real(r8), allocatable :: mw_soa_host_m(:), mw_poa_host_m(:) + + ! Host-provided physical constants: + real(r8) :: rair_m, mwdry_m + real(r8) :: rgas_m + +contains + +subroutine modal_aero_gasaerexch_init( & + ntot_amode, nsoa, npoa, nspec_max, & + nspec_amode, & + modeptr_pcarbon, modeptr_accum, & + alnsg_amode, sigmag_amode, & + specmw_amode, specdens_amode, spechygro, & + idx_h2so4, idx_nh3, idx_msa, & + idx_soag, & + idx_so4_a, idx_nh4_a, & + idx_soa_a, idx_pom_a, & + idx_num, idx_mass, pcnst_in, & + nspecfrm_pcage_in, & + lspecfrm_pcage_in, lspectoo_pcage_in, & + mw_soa_host, mw_poa_host, & + rair, mwdry, r_universal, & + errmsg, errflg) -! list private module data here + !----------------------------------------------------------------------- + ! + ! Purpose: + ! initialize gas-aerosol exchange module + ! store species indices and mode metadata + ! compute aging/MW conversion factors + ! + ! Author: R. Easter + ! + !----------------------------------------------------------------------- -!EOC -!---------------------------------------------------------------------- + ! arguments + integer, intent(in) :: ntot_amode + integer, intent(in) :: nsoa + integer, intent(in) :: npoa + integer, intent(in) :: nspec_max + integer, intent(in) :: nspec_amode(:) + integer, intent(in) :: modeptr_pcarbon + integer, intent(in) :: modeptr_accum + real(r8), intent(in) :: alnsg_amode(:) + real(r8), intent(in) :: sigmag_amode(:) + real(r8), intent(in) :: specmw_amode(:,:) + real(r8), intent(in) :: specdens_amode(:,:) + real(r8), intent(in) :: spechygro(:,:) + integer, intent(in) :: idx_h2so4 + integer, intent(in) :: idx_nh3 + integer, intent(in) :: idx_msa + integer, intent(in) :: idx_soag(:) + integer, intent(in) :: idx_so4_a(:) + integer, intent(in) :: idx_nh4_a(:) + integer, intent(in) :: idx_soa_a(:,:) + integer, intent(in) :: idx_pom_a(:,:) + integer, intent(in) :: idx_num(:) + integer, intent(in) :: idx_mass(:,:) + integer, intent(in) :: pcnst_in ! total number of constituents (for range checks) + integer, intent(in) :: nspecfrm_pcage_in + integer, intent(in) :: lspecfrm_pcage_in(:) ! pcnst-space + integer, intent(in) :: lspectoo_pcage_in(:) ! pcnst-space + real(r8), intent(in) :: mw_soa_host(:) + real(r8), intent(in) :: mw_poa_host(:) + real(r8), intent(in) :: rair ! dry-air gas constant from host (J/K/kg) + real(r8), intent(in) :: mwdry ! dry-air molecular weight from host (kg/kmol) + real(r8), intent(in) :: r_universal ! universal gas constant from host (J/K/kmol) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local + integer :: jsoa, l, l1, l2, n + real(r8) :: tmp2 +!----------------------------------------------------------------------- - contains + errmsg = '' + errflg = 0 + ! Store configuration + ntot_amode_m = ntot_amode + nsoa_m = nsoa + npoa_m = npoa + nspec_max_m = nspec_max -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -!BOP -! !ROUTINE: modal_aero_gasaerexch_sub --- ... -! -! !INTERFACE: -subroutine modal_aero_gasaerexch_sub( & - lchnk, ncol, nstep, & - loffset, deltat, & - t, pmid, pdel, & - qh2o, troplev, & - q, qqcw, & - dqdt_other, dqqcwdt_other, & + ! Allocate and store mode configuration arrays + allocate(nspec_amode_m(ntot_amode)) + nspec_amode_m(:) = nspec_amode(1:ntot_amode) + + allocate(alnsg_amode_m(ntot_amode)) + alnsg_amode_m(:) = alnsg_amode(1:ntot_amode) + + allocate(sigmag_amode_m(ntot_amode)) + sigmag_amode_m(:) = sigmag_amode(1:ntot_amode) + + allocate(specmw_amode_m(nspec_max, ntot_amode)) + specmw_amode_m(:,:) = specmw_amode(1:nspec_max, 1:ntot_amode) + + allocate(specdens_amode_m(nspec_max, ntot_amode)) + specdens_amode_m(:,:) = specdens_amode(1:nspec_max, 1:ntot_amode) + + ! Store species indices + idx_h2so4_m = idx_h2so4 + idx_nh3_m = idx_nh3 + idx_msa_m = idx_msa + + allocate(idx_soag_m(nsoa)) + idx_soag_m(:) = idx_soag(1:nsoa) + + allocate(idx_so4_a_m(ntot_amode)) + idx_so4_a_m(:) = idx_so4_a(1:ntot_amode) + + allocate(idx_nh4_a_m(ntot_amode)) + idx_nh4_a_m(:) = idx_nh4_a(1:ntot_amode) + + allocate(idx_soa_a_m(ntot_amode, nsoa)) + idx_soa_a_m(:,:) = idx_soa_a(1:ntot_amode, 1:nsoa) + + allocate(idx_pom_a_m(ntot_amode, npoa)) + idx_pom_a_m(:,:) = idx_pom_a(1:ntot_amode, 1:npoa) + + allocate(idx_num_m(ntot_amode)) + idx_num_m(:) = idx_num(1:ntot_amode) + + allocate(idx_mass_m(nspec_max, ntot_amode)) + idx_mass_m(:,:) = idx_mass(1:nspec_max, 1:ntot_amode) + + ! Store pcarbon mode pointer + modeptr_pcarbon_m = modeptr_pcarbon + + ! Store molecular weights + allocate(mw_soa_host_m(nsoa)) + mw_soa_host_m(:) = mw_soa_host(1:nsoa) + + allocate(mw_poa_host_m(npoa)) + mw_poa_host_m(:) = mw_poa_host(1:npoa) + + ! Store host physical constants + rair_m = rair + mwdry_m = mwdry + rgas_m = r_universal * 1.0e-3_r8 ! J/K/kmol -> J/K/mol + + ! Validate H2SO4 index (required species) + if ((idx_h2so4 <= 0) .or. (idx_h2so4 > pcnst_in)) then + write(errmsg, '(a,i7)') & + 'modal_aero_gasaerexch_init -- cannot find H2SO4 species, idx=', idx_h2so4 + errflg = 1 + return + end if + + ! Compute species presence flags + do_nh4g_m = .false. + if ((idx_nh3 > 0) .and. (idx_nh3 <= pcnst_in)) do_nh4g_m = .true. + + do_msag_m = .false. + if ((idx_msa > 0) .and. (idx_msa <= pcnst_in)) do_msag_m = .true. + + allocate(do_soag_m(nsoa)) + do_soag_any_m = .false. + do_soag_m(:) = .false. + do jsoa = 1, nsoa + if ((idx_soag(jsoa) > 0) .and. (idx_soag(jsoa) <= pcnst_in)) then + do_soag_any_m = .true. + do_soag_m(jsoa) = .true. + end if + end do + + ! Compute ido arrays (species presence in modes) + allocate(ido_so4a_m(ntot_amode)) + allocate(ido_nh4a_m(ntot_amode)) + allocate(ido_soaa_m(ntot_amode, nsoa)) + ido_so4a_m(:) = 0 + ido_nh4a_m(:) = 0 + ido_soaa_m(:,:) = 0 + + ntot_soamode_m = 0 + do n = 1, ntot_amode + l = idx_so4_a(n) + if ((l > 0) .and. (l <= pcnst_in)) then + ido_so4a_m(n) = 1 + if ( do_nh4g_m ) then + l = idx_nh4_a(n) + if ((l > 0) .and. (l <= pcnst_in)) then + ido_nh4a_m(n) = 1 + end if + end if + end if + + do jsoa = 1, nsoa + if ( do_soag_m(jsoa) ) then + l = idx_soa_a(n,jsoa) + if ((l > 0) .and. (l <= pcnst_in)) then + ido_soaa_m(n,jsoa) = 1 + ntot_soamode_m = n + end if + end if + end do ! jsoa + end do ! n + + ! + ! define "from mode" and "to mode" for primary carbon aging + ! + ! skip (turn off) aging if either is absent, + ! or if accum mode so4 is absent + ! + maxspec_pcage = nspec_max + allocate(lspecfrm_pcage(maxspec_pcage)) + allocate(lspectoo_pcage(maxspec_pcage)) + allocate(soa_equivso4_factor(nsoa)) + allocate(fac_m2v_soa(nsoa)) + allocate(fac_m2v_pcarbon(nspec_max)) + + lspecfrm_pcage(:) = 0 + lspectoo_pcage(:) = 0 + + modefrm_pcage = -999888777 + modetoo_pcage = -999888777 + nspecfrm_pcage = 0 + + if ((modeptr_pcarbon > 0) .and. (modeptr_accum > 0)) then + l = idx_so4_a(modeptr_accum) + if ((l > 0) .and. (l <= pcnst_in)) then + modefrm_pcage = modeptr_pcarbon + modetoo_pcage = modeptr_accum + + nspecfrm_pcage = nspecfrm_pcage_in + lspecfrm_pcage(1:nspecfrm_pcage) = lspecfrm_pcage_in(1:nspecfrm_pcage) + lspectoo_pcage(1:nspecfrm_pcage) = lspectoo_pcage_in(1:nspecfrm_pcage) + end if + end if + + if ( do_soag_any_m ) ntot_soamode_m = max( ntot_soamode_m, modefrm_pcage ) + + ! Modify ido arrays for pcage mode + if (modefrm_pcage > 0) then + ido_so4a_m(modefrm_pcage) = 2 + if (ido_nh4a_m(modetoo_pcage) == 1) ido_nh4a_m(modefrm_pcage) = 2 + do jsoa = 1, nsoa + if (ido_soaa_m(modetoo_pcage,jsoa) == 1) ido_soaa_m(modefrm_pcage,jsoa) = 2 + end do + end if + + ! set for used in aging calcs: + ! fac_m2v_so4, fac_m2v_nh4, fac_m2v_soa(:) + ! soa_equivso4_factor(:) + soa_equivso4_factor = 0.0_r8 + if (modefrm_pcage > 0) then + n = modeptr_accum + l2 = -1 + do l1 = 1, nspec_amode(n) + if (idx_mass(l1,n) == idx_so4_a(n)) then +! l2 = lspectype_amode(l1,n) + l2 = l1 +! fac_m2v_so4 = specmw_amode(l2) / specdens_amode(l2) + fac_m2v_so4 = specmw_amode(l1,n) / specdens_amode(l1,n) +! tmp2 = spechygro(l2) + tmp2 = spechygro(l1,n) + + end if + end do + if (l2 <= 0) then + errmsg = 'modal_aero_gasaerexch_init error a002 finding accum. so4' + errflg = 1 + return + end if + + l2 = -1 + if (idx_nh4_a(n) > 0) then + do l1 = 1, nspec_amode(n) + if (idx_mass(l1,n) == idx_nh4_a(n)) then +! l2 = lspectype_amode(l1,n) + l2 = l1 +! fac_m2v_nh4 = specmw_amode(l2) / specdens_amode(l2) + fac_m2v_nh4 = specmw_amode(l1,n) / specdens_amode(l1,n) + + end if + end do + if (l2 <= 0) then + errmsg = 'modal_aero_gasaerexch_init error a002 finding accum. nh4' + errflg = 1 + return + end if + else + fac_m2v_nh4 = fac_m2v_so4 + end if + + do jsoa = 1, nsoa + l2 = -1 + if (idx_soa_a(n,jsoa) <= 0) then + write( errmsg, '(a,i4)') 'modal_aero_gasaerexch_init error a001 finding accum. jsoa =', jsoa + errflg = 1 + return + end if + do l1 = 1, nspec_amode(n) + if (idx_mass(l1,n) == idx_soa_a(n,jsoa)) then +! l2 = lspectype_amode(l1,n) + l2 = l1 +! fac_m2v_soa(jsoa) = specmw_amode(l2) / specdens_amode(l2) + fac_m2v_soa(jsoa) = specmw_amode(l1,n) / specdens_amode(l1,n) +! soa_equivso4_factor(jsoa) = spechygro(l2)/tmp2 + soa_equivso4_factor(jsoa) = spechygro(l1,n)/tmp2 + end if + end do + if (l2 <= 0) then + write( errmsg, '(a,i4)') 'modal_aero_gasaerexch_init error a002 finding accum. jsoa =', jsoa + errflg = 1 + return + end if + end do + + fac_m2v_pcarbon(:) = 0.0_r8 + n = modeptr_pcarbon + do l = 1, nspec_amode(n) +! l2 = lspectype_amode(l,n) +! fac_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) +! [m3-AP/kmol-AP] = [kg-AP/kmol-AP] / [kg-AP/m3-AP] +! fac_m2v_pcarbon(l) = specmw_amode(l2) / specdens_amode(l2) + fac_m2v_pcarbon(l) = specmw_amode(l,n) / specdens_amode(l,n) + end do + end if + +end subroutine modal_aero_gasaerexch_init + +subroutine modal_aero_gasaerexch_run( & + ncol, pver, deltat, top_lev, & + loffset, & + t, pmid, pdel, gravit, & + troplev, & dgncur_a, dgncur_awet, & - sulfeq ) - -! !USES: -use modal_aero_data, only: alnsg_amode,lmassptr_amode,cnst_name_cw -use modal_aero_data, only: lptr_so4_a_amode,lptr_nh4_a_amode -use modal_aero_data, only: modeptr_pcarbon,nspec_amode,specmw_amode,specdens_amode -use modal_aero_rename, only: modal_aero_rename_sub -use radiative_aerosol, only: rad_aer_get_info -use constituents, only: pcnst, cnst_mw - -use cam_history, only: outfld, fieldname_len -use chem_mods, only: adv_mass -use constituents, only: pcnst, cnst_name, cnst_get_ind -use mo_tracname, only: solsym -use physconst, only: gravit, mwdry, rair -use cam_abortutils, only: endrun -use spmd_utils, only: iam, masterproc -use phys_control, only: cam_chempkg_is - -implicit none - -! !PARAMETERS: - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric column - integer, intent(in) :: nstep ! model time-step number - integer, intent(in) :: loffset ! offset applied to modal aero "ptrs" - integer, intent(in) :: troplev(pcols) ! tropopause vertical index - real(r8), intent(in) :: deltat ! time step (s) - - real(r8), intent(inout) :: q(ncol,pver,pcnstxx) ! tracer mixing ratio (TMR) array + use_sulfeq, sulfeq, & + num_q, & + q, & + dqdt, dotend, qsrflx_gaexch, & + errmsg, errflg) + integer, intent(in) :: ncol ! # of atmospheric columns + integer, intent(in) :: pver ! # of vertical levels + real(r8), intent(in) :: deltat ! time step [s] + integer, intent(in) :: top_lev ! top level for aerosol processes + integer, intent(in) :: loffset ! offset to convert pcnst-space to vmr-space [index] + integer, intent(in) :: troplev(:) ! (ncol) tropopause vertical index [index] + real(r8), intent(in) :: t(:,:) ! (ncol,pver) temperature [K] + real(r8), intent(in) :: pmid(:,:) ! (ncol,pver) pressure [Pa] + real(r8), intent(in) :: pdel(:,:) ! (ncol,pver) pressure thickness [Pa] + real(r8), intent(in) :: gravit ! gravitational acceleration [m s-2] + real(r8), intent(in) :: dgncur_a(:,:,:) ! (ncol,pver,ntot_amode) dry diameter + real(r8), intent(in) :: dgncur_awet(:,:,:) ! (ncol,pver,ntot_amode) wet diameter + logical, intent(in) :: use_sulfeq ! whether to use strat equilibrium + real(r8), intent(in) :: sulfeq(:,:,:) ! (ncol,pver,ntot_amode) sulfeq values + integer, intent(in) :: num_q ! # of species in vmr array (= gas_pcnst) + real(r8), intent(in) :: q(:,:,:) ! (ncol,pver,num_q) tracer VMR ! *** 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 - real(r8), intent(in) :: dqdt_other(ncol,pver,pcnstxx) - ! TMR tendency from other continuous - ! growth processes (aqchem, soa??) - ! *** NOTE ncol dimension - real(r8), intent(in) :: dqqcwdt_other(ncol,pver,pcnstxx) - ! like dqdt_other but for cloud-borner tracers - real(r8), intent(in) :: t(pcols,pver) ! temperature at model levels (K) - real(r8), intent(in) :: pmid(pcols,pver) ! pressure at model levels (Pa) - real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: qh2o(pcols,pver) ! water vapor mixing ratio (kg/kg) - real(r8), intent(in) :: dgncur_a(pcols,pver,ntot_amode) - real(r8), intent(in) :: dgncur_awet(pcols,pver,ntot_amode) - real(r8), pointer :: sulfeq(:,:,:) - - ! dry & wet geo. mean dia. (m) of number distrib. - -! !DESCRIPTION: -! computes TMR (tracer mixing ratio) tendencies for gas condensation -! onto aerosol particles -! -! this version does condensation of H2SO4, NH3, and MSA, both treated as -! completely non-volatile (gas --> aerosol, but no aerosol --> gas) -! gas H2SO4 goes to aerosol SO4 -! gas MSA (if present) goes to aerosol SO4 -! aerosol MSA is not distinguished from aerosol SO4 -! gas NH3 (if present) goes to aerosol NH4 -! if gas NH3 is not present, then ???? -! -! -! !REVISION HISTORY: -! RCE 07.04.13: Adapted from MIRAGE2 code -! -!EOP -!---------------------------------------------------------------------- -!BOC - -! local variables - integer, parameter :: jsrflx_gaexch = 1 - integer, parameter :: jsrflx_rename = 2 - integer, parameter :: ldiag1=-1, ldiag2=-1, ldiag3=-1, ldiag4=-1 + real(r8), intent(out) :: dqdt(:,:,:) ! (ncol,pver,num_q) tendencies + logical, intent(out) :: dotend(:) ! (num_q) which species have tendencies + real(r8), intent(out) :: qsrflx_gaexch(:,:) ! (ncol,num_q) column-integrated gas-aerosol + ! exchange source/sink (kg/m2/s, pre adv_mass/mwdry + ! scaling) for the _sfgaex1 diagnostic. + ! Accumulated per-term here because the per-mode + ! and primary-carbon-aging contributions must be + ! summed separately to stay bfb with CAM. + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! computes TMR (tracer mixing ratio) tendencies for gas condensation + ! onto aerosol particles + ! + ! this version does condensation of H2SO4, NH3, and MSA, both treated as + ! completely non-volatile (gas --> aerosol, but no aerosol --> gas) + ! gas H2SO4 goes to aerosol SO4 + ! gas MSA (if present) goes to aerosol SO4 + ! aerosol MSA is not distinguished from aerosol SO4 + ! gas NH3 (if present) goes to aerosol NH4 + ! if gas NH3 is not present, then ???? + + ! local variables 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 + ! 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, iq, itmpa - integer :: idiagss - integer :: ido_so4a(ntot_amode), ido_nh4a(ntot_amode) - integer :: ido_soaa(ntot_amode,nsoa) - integer :: j, jac, jsrf, jsoa - integer :: k,p - integer :: l, l2, lb, lsfrm, lstoo + integer :: ido_so4a(ntot_amode_m), ido_nh4a(ntot_amode_m) + integer :: ido_soaa(ntot_amode_m,nsoa_m) + integer :: j, jsoa + integer :: k + integer :: l, lsfrm, lstoo integer :: l_so4g, l_nh4g, l_msag - integer :: l_soag(nsoa) - integer :: n, nn, niter, niter_max, ntot_soamode - - logical :: is_dorename_atik, dorename_atik(ncol,pver) + integer :: l_soag(nsoa_m) + integer :: n, niter, niter_max, ntot_soamode - character(len=fieldname_len+3) :: fieldname - character(len=100) :: msg ! string for endrun calls - character(len=32) :: spec_type + ! Local offset-adjusted index arrays (pcnst-space - loffset = vmr space) + integer :: idx_so4_a_q(ntot_amode_m), idx_nh4_a_q(ntot_amode_m) + integer :: idx_soa_a_q(ntot_amode_m,nsoa_m), idx_pom_a_q(ntot_amode_m,npoa_m) + integer :: idx_num_q(ntot_amode_m), idx_mass_q(nspec_max_m,ntot_amode_m) + integer :: lspecfrm_q(maxspec_pcage), lspectoo_q(maxspec_pcage) - real (r8) :: avg_uprt_nh4, avg_uprt_so4, avg_uprt_soa(nsoa) + real (r8) :: avg_uprt_nh4, avg_uprt_so4, avg_uprt_soa(nsoa_m) real (r8) :: deltatxx - real (r8) :: dqdt_nh4(ntot_amode), dqdt_so4(ntot_amode) - real (r8) :: dqdt_soa(ntot_amode,nsoa) - real (r8) :: dqdt_soag(nsoa) + real (r8) :: dqdt_nh4(ntot_amode_m), dqdt_so4(ntot_amode_m) + real (r8) :: dqdt_soa(ntot_amode_m,nsoa_m) + real (r8) :: dqdt_soag(nsoa_m) real (r8) :: fac_volsfc_pcarbon - real (r8) :: fgain_nh4(ntot_amode), fgain_so4(ntot_amode) - real (r8) :: fgain_soa(ntot_amode,nsoa) - real (r8) :: g0_soa(nsoa) - real(r8) :: mw_poa_host(npoa) ! molec wght of poa used in host code - real(r8) :: mw_soa_host(nsoa) ! molec wght of poa used in host code - real (r8) :: pdel_fac + real (r8) :: fgain_nh4(ntot_amode_m), fgain_so4(ntot_amode_m) + real (r8) :: fgain_soa(ntot_amode_m,nsoa_m) + real(r8) :: mw_poa_host(npoa_m) ! molec wght of poa used in host code + real(r8) :: mw_soa_host(nsoa_m) ! molec wght of poa used in host code real (r8) :: qmax_nh4, qnew_nh4, qnew_so4 - real (r8) :: qold_nh4(ntot_amode), qold_so4(ntot_amode) - real (r8) :: qold_poa(ntot_amode,npoa) - real (r8) :: qold_soa(ntot_amode,nsoa) - real (r8) :: qold_soag(nsoa) + real (r8) :: qold_nh4(ntot_amode_m), qold_so4(ntot_amode_m) + real (r8) :: qold_poa(ntot_amode_m,npoa_m) + real (r8) :: qold_soa(ntot_amode_m,nsoa_m) + real (r8) :: qold_soag(nsoa_m) real (r8) :: sum_dqdt_msa, sum_dqdt_so4 - real (r8) :: sum_dqdt_soa(nsoa) + real (r8) :: sum_dqdt_soa(nsoa_m) real (r8) :: sum_dqdt_nh4, sum_dqdt_nh4_b - real (r8) :: sum_uprt_msa, sum_uprt_nh4, sum_uprt_so4 - real (r8) :: sum_uprt_soa(nsoa) + real (r8) :: sum_uprt_nh4, sum_uprt_so4 + real (r8) :: sum_uprt_soa(nsoa_m) + real (r8) :: pdel_fac ! pdel/gravit (kg/m2 per Pa), for column-integrated diagnostics real (r8) :: tmp1, tmp2, tmpa real (r8) :: tmp_kxt, tmp_pxt real (r8) :: tmp_so4a_bgn, tmp_so4a_end real (r8) :: tmp_so4g_avg, tmp_so4g_bgn, tmp_so4g_equ - real (r8) :: uptkrate(ntot_amode,pcols,pver) - real (r8) :: uptkratebb(ntot_amode) - real (r8) :: uptkrate_soa(ntot_amode,nsoa) + real (r8) :: uptkrate(ntot_amode_m,ncol,pver) + real (r8) :: uptkratebb(ntot_amode_m) + real (r8) :: uptkrate_soa(ntot_amode_m,nsoa_m) ! gas-to-aerosol mass transfer rates (1/s) real (r8) :: vol_core, vol_shell real (r8) :: xferfrac_pcage, xferfrac_max @@ -225,165 +505,109 @@ subroutine modal_aero_gasaerexch_sub( & logical :: do_msag ! true if msa gas is a species logical :: do_nh4g ! true if nh3 gas is a species logical :: do_soag_any ! true if soa gas is a species - logical :: do_soag(nsoa) ! true if soa gas is a species - - logical :: dotend(pcnstxx) ! identifies species directly involved in - ! gas-aerosol exchange (gas condensation) - logical :: dotendqqcw(pcnstxx) ! like dotend but for cloud-borner tracers - logical :: dotendrn(pcnstxx), dotendqqcwrn(pcnstxx) - ! identifies species involved in renaming - ! after "continuous growth" - ! (gas-aerosol exchange and aqchem) - - integer, parameter :: nsrflx = 2 ! last dimension of qsrflx - real(r8) :: dqdt(ncol,pver,pcnstxx) ! TMR "delta q" array - NOTE dims - real(r8) :: dqqcwdt(ncol,pver,pcnstxx) ! like dqdt but for cloud-borner tracers - real(r8) :: qsrflx(pcols,pcnstxx,nsrflx) - ! process-specific column tracer tendencies - ! (1=renaming, 2=gas condensation) - real(r8) :: qconff(pcols,pver),qevapff(pcols,pver) - real(r8) :: qconbb(pcols,pver),qevapbb(pcols,pver) - real(r8) :: qconbg(pcols,pver),qevapbg(pcols,pver) - real(r8) :: qcon(pcols,pver),qevap(pcols,pver) - - real(r8) :: qqcwsrflx(pcols,pcnstxx,nsrflx) - -! following only needed for diagnostics - real(r8) :: qold(ncol,pver,pcnstxx) ! NOTE dims - real(r8) :: qnew(ncol,pver,pcnstxx) ! NOTE dims - real(r8) :: qdel(ncol,pver,pcnstxx) ! NOTE dims - real(r8) :: dumavec(1000), dumbvec(1000), dumcvec(1000) - real(r8) :: qqcwold(ncol,pver,pcnstxx) - real(r8) :: dqdtsv1(ncol,pver,pcnstxx) - real(r8) :: dqqcwdtsv1(ncol,pver,pcnstxx) + logical :: do_soag(nsoa_m) ! true if soa gas is a species !---------------------------------------------------------------------- -! set gas species indices - call cnst_get_ind( 'H2SO4', l_so4g, .false. ) - call cnst_get_ind( 'NH3', l_nh4g, .false. ) - if ( .not. cam_chempkg_is('geoschem_mam4') ) then - call cnst_get_ind( 'MSA', l_msag, .false. ) - else - l_msag = 0 - endif - l_so4g = l_so4g - loffset - l_nh4g = l_nh4g - loffset - l_msag = l_msag - loffset - if ((l_so4g <= 0) .or. (l_so4g > pcnstxx)) then - write( *, '(/a/a,2i7)' ) & - '*** modal_aero_gasaerexch_sub -- cannot find H2SO4 species', & - ' l_so4g, loffset =', l_so4g, loffset - call endrun( 'modal_aero_gasaerexch_sub error' ) - end if - do_nh4g = .false. - do_msag = .false. - if ((l_nh4g > 0) .and. (l_nh4g <= pcnstxx)) do_nh4g = .true. - if ((l_msag > 0) .and. (l_msag <= pcnstxx)) do_msag = .true. + errmsg = '' + errflg = 0 + +! set gas species indices from module-level storage, applying -loffset +! to convert pcnst-space to vmr (gas_pcnst) space + l_so4g = idx_h2so4_m - loffset + l_nh4g = idx_nh3_m - loffset + l_msag = idx_msa_m - loffset + do_nh4g = do_nh4g_m + do_msag = do_msag_m + do_soag_any = do_soag_any_m + do_soag(:) = do_soag_m(:) + do jsoa = 1, nsoa_m + l_soag(jsoa) = idx_soag_m(jsoa) - loffset + end do - do_soag_any = .false. - do_soag(:) = .false. - do jsoa = 1, nsoa - l_soag(jsoa) = lptr2_soa_g_amode(jsoa) - loffset - if ((method_soa == 1) .or. (method_soa == 2)) then - if ((l_soag(jsoa) > 0) .and. (l_soag(jsoa) <= pcnstxx)) then - do_soag_any = .true. - do_soag(jsoa) = .true. - end if - else if (method_soa /= 0) then - write(*,'(/a,1x,i10)') '*** modal_aero_gasaerexch_sub - bad method_soa =', method_soa - call endrun( 'modal_aero_gasaerexch_sub error' ) - end if - end do ! jsoa +! compute offset-adjusted per-mode index arrays + idx_so4_a_q(:) = idx_so4_a_m(:) - loffset + idx_nh4_a_q(:) = idx_nh4_a_m(:) - loffset + idx_soa_a_q(:,:) = idx_soa_a_m(:,:) - loffset + idx_pom_a_q(:,:) = idx_pom_a_m(:,:) - loffset + idx_num_q(:) = idx_num_m(:) - loffset + idx_mass_q(:,:) = idx_mass_m(:,:) - loffset + do iq = 1, nspecfrm_pcage + lspecfrm_q(iq) = lspecfrm_pcage(iq) - loffset + lspectoo_q(iq) = lspectoo_pcage(iq) + if (lspectoo_q(iq) > 0) lspectoo_q(iq) = lspectoo_q(iq) - loffset + end do + +! copy ido arrays from module-level storage + ido_so4a(:) = ido_so4a_m(:) + ido_nh4a(:) = ido_nh4a_m(:) + ido_soaa(:,:) = ido_soaa_m(:,:) + ntot_soamode = ntot_soamode_m + +! set molecular weights from module-level storage + mw_soa_host(:) = mw_soa_host_m(:) + mw_poa_host(:) = mw_poa_host_m(:) ! set tendency flags dotend(:) = .false. - dotendqqcw(:) = .false. - ido_so4a(:) = 0 - ido_nh4a(:) = 0 - ido_soaa(:,:) = 0 dotend(l_so4g) = .true. if ( do_nh4g ) dotend(l_nh4g) = .true. if ( do_msag ) dotend(l_msag) = .true. - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m if ( do_soag(jsoa) ) dotend(l_soag(jsoa)) = .true. end do - ntot_soamode = 0 - do n = 1, ntot_amode - l = lptr_so4_a_amode(n)-loffset - if ((l > 0) .and. (l <= pcnstxx)) then + do n = 1, ntot_amode_m + if (ido_so4a(n) == 1) then + l = idx_so4_a_q(n) dotend(l) = .true. - ido_so4a(n) = 1 if ( do_nh4g ) then - l = lptr_nh4_a_amode(n)-loffset - if ((l > 0) .and. (l <= pcnstxx)) then + if (ido_nh4a(n) == 1) then + l = idx_nh4_a_q(n) dotend(l) = .true. - ido_nh4a(n) = 1 end if end if end if - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m if ( do_soag(jsoa) ) then - l = lptr2_soa_a_amode(n,jsoa)-loffset - if ((l > 0) .and. (l <= pcnstxx)) then + if (ido_soaa(n,jsoa) == 1) then + l = idx_soa_a_q(n,jsoa) dotend(l) = .true. - ido_soaa(n,jsoa) = 1 - ntot_soamode = n end if end if end do ! jsoa end do ! n - if ( do_soag_any ) ntot_soamode = max( ntot_soamode, modefrm_pcage ) - if (modefrm_pcage > 0) then - ido_so4a(modefrm_pcage) = 2 - if (ido_nh4a(modetoo_pcage) == 1) ido_nh4a(modefrm_pcage) = 2 - do jsoa = 1, nsoa - if (ido_soaa(modetoo_pcage,jsoa) == 1) ido_soaa(modefrm_pcage,jsoa) = 2 - end do do iq = 1, nspecfrm_pcage - lsfrm = lspecfrm_pcage(iq)-loffset - lstoo = lspectoo_pcage(iq)-loffset - if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then + lsfrm = lspecfrm_q(iq) + lstoo = lspectoo_q(iq) + if ((lsfrm > 0) .and. (lsfrm <= num_q)) then dotend(lsfrm) = .true. - if ((lstoo > 0) .and. (lstoo <= pcnst)) then + if ((lstoo > 0) .and. (lstoo <= num_q)) then dotend(lstoo) = .true. end if end if end do - n = modeptr_pcarbon - fac_volsfc_pcarbon = exp( 2.5_r8*(alnsg_amode(n)**2) ) + n = modeptr_pcarbon_m + fac_volsfc_pcarbon = exp( 2.5_r8*(alnsg_amode_m(n)**2) ) xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps end if -! zero out tendencies and other +! zero out tendencies dqdt(:,:,:) = 0.0_r8 - dqqcwdt(:,:,:) = 0.0_r8 - qsrflx(:,:,:) = 0.0_r8 - qqcwsrflx(:,:,:) = 0.0_r8 - -!-------Initialize evap/cond diagnostics (ncols x pver)----------- - qconff(:,:) = 0.0_r8 - qevapff(:,:) = 0.0_r8 - qconbb(:,:) = 0.0_r8 - qevapbb(:,:) = 0.0_r8 - qconbg(:,:) = 0.0_r8 - qevapbg(:,:) = 0.0_r8 - qcon(:,:) = 0.0_r8 - qevap(:,:) = 0.0_r8 -!--------------------------------------------------- + qsrflx_gaexch(:,:) = 0.0_r8 ! compute gas-to-aerosol mass transfer rates - call gas_aer_uptkrates( ncol, loffset, & + call gas_aer_uptkrates( ncol, pver, top_lev, & + loffset, & q, t, pmid, & dgncur_awet, uptkrate ) @@ -392,7 +616,6 @@ subroutine modal_aero_gasaerexch_sub( & deltatxx = deltat * (1.0_r8 + 1.0e-15_r8) - jsrf = jsrflx_gaexch do k=top_lev,pver do i=1,ncol @@ -401,13 +624,13 @@ subroutine modal_aero_gasaerexch_sub( & sum_uprt_so4 = 0.0_r8 sum_uprt_nh4 = 0.0_r8 sum_uprt_soa = 0.0_r8 - do n = 1, ntot_amode + do n = 1, ntot_amode_m uptkratebb(n) = uptkrate(n,i,k) if (ido_so4a(n) > 0) then fgain_so4(n) = uptkratebb(n) sum_uprt_so4 = sum_uprt_so4 + fgain_so4(n) if (ido_so4a(n) == 1) then - qold_so4(n) = q(i,k,lptr_so4_a_amode(n)-loffset) + qold_so4(n) = q(i,k,idx_so4_a_q(n)) else qold_so4(n) = 0.0_r8 end if @@ -422,7 +645,7 @@ subroutine modal_aero_gasaerexch_sub( & fgain_nh4(n) = uptkratebb(n)*2.08_r8 sum_uprt_nh4 = sum_uprt_nh4 + fgain_nh4(n) if (ido_nh4a(n) == 1) then - qold_nh4(n) = q(i,k,lptr_nh4_a_amode(n)-loffset) + qold_nh4(n) = q(i,k,idx_nh4_a_q(n)) else qold_nh4(n) = 0.0_r8 end if @@ -431,8 +654,8 @@ subroutine modal_aero_gasaerexch_sub( & qold_nh4(n) = 0.0_r8 end if - do j = 1, npoa - l = lptr2_pom_a_amode(n,j)-loffset + do j = 1, npoa_m + l = idx_pom_a_q(n,j) if (l > 0) then qold_poa(n,j) = q(i,k,l) else @@ -441,14 +664,14 @@ subroutine modal_aero_gasaerexch_sub( & end do itmpa = 0 - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m if (ido_soaa(n,jsoa) > 0) then ! 0.81 factor is for gas diffusivity (soa/h2so4) ! (differences in fuch-sutugin and accom coef ignored) fgain_soa(n,jsoa) = uptkratebb(n)*0.81_r8 sum_uprt_soa(jsoa) = sum_uprt_soa(jsoa) + fgain_soa(n,jsoa) if (ido_soaa(n,jsoa) == 1) then - l = lptr2_soa_a_amode(n,jsoa)-loffset + l = idx_soa_a_q(n,jsoa) qold_soa(n,jsoa) = q(i,k,l) itmpa = itmpa + 1 else @@ -469,20 +692,20 @@ subroutine modal_aero_gasaerexch_sub( & end do ! n if (sum_uprt_so4 > 0.0_r8) then - do n = 1, ntot_amode + do n = 1, ntot_amode_m fgain_so4(n) = fgain_so4(n) / sum_uprt_so4 end do end if ! at this point (sum_uprt_so4 <= 0.0) only when all the fgain_so4 are zero if (sum_uprt_nh4 > 0.0_r8) then - do n = 1, ntot_amode + do n = 1, ntot_amode_m fgain_nh4(n) = fgain_nh4(n) / sum_uprt_nh4 end do end if - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m if (sum_uprt_soa(jsoa) > 0.0_r8) then - do n = 1, ntot_amode + do n = 1, ntot_amode_m fgain_soa(n,jsoa) = fgain_soa(n,jsoa) / sum_uprt_soa(jsoa) end do end if @@ -492,7 +715,7 @@ subroutine modal_aero_gasaerexch_sub( & avg_uprt_so4 = (1.0_r8 - exp(-deltatxx*sum_uprt_so4))/deltatxx avg_uprt_nh4 = (1.0_r8 - exp(-deltatxx*sum_uprt_nh4))/deltatxx - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m avg_uprt_soa(jsoa) = (1.0_r8 - exp(-deltatxx*sum_uprt_soa(jsoa)))/deltatxx end do @@ -512,7 +735,7 @@ subroutine modal_aero_gasaerexch_sub( & sum_dqdt_nh4 = 0.0_r8 end if - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m if ( do_soag(jsoa) ) then sum_dqdt_soa(jsoa) = q(i,k,l_soag(jsoa)) * avg_uprt_soa(jsoa) else @@ -520,13 +743,13 @@ subroutine modal_aero_gasaerexch_sub( & end if end do - if ( associated(sulfeq) .and. (k <= troplev(i)) ) then + if ( use_sulfeq .and. (k <= troplev(i)) ) then ! compute TMR tendencies for so4 interstial aerosol due to reversible gas uptake ! only above the tropopause tmp_kxt = deltatxx*sum_uprt_so4 ! sum over modes of uptake_rate*deltat tmp_pxt = 0.0_r8 - do n = 1, ntot_amode + do n = 1, ntot_amode_m if (ido_so4a(n) <= 0) cycle tmp_pxt = tmp_pxt + uptkratebb(n)*sulfeq(i,k,n) end do @@ -542,11 +765,11 @@ subroutine modal_aero_gasaerexch_sub( & tmp_so4g_avg = tmp_so4g_bgn*(1.0_r8-0.5_r8*tmp_kxt) + 0.5_r8*tmp_pxt end if sum_dqdt_so4 = 0.0_r8 - do n = 1, ntot_amode + do n = 1, ntot_amode_m if (ido_so4a(n) <= 0) cycle ! calc change to so4(a) in mode n if (ido_so4a(n) == 1) then - l = lptr_so4_a_amode(n)-loffset + l = idx_so4_a_q(n) tmp_so4a_bgn = q(i,k,l) else tmp_so4a_bgn = 0.0_r8 @@ -564,7 +787,7 @@ subroutine modal_aero_gasaerexch_sub( & else ! compute TMR tendencies for so4 interstial aerosol due to simple gas uptake - do n = 1, ntot_amode + do n = 1, ntot_amode_m dqdt_so4(n) = fgain_so4(n)*(sum_dqdt_so4 + sum_dqdt_msa) end do end if @@ -574,7 +797,7 @@ subroutine modal_aero_gasaerexch_sub( & sum_dqdt_nh4_b = 0.0_r8 dqdt_nh4(:) = 0._r8 if ( do_nh4g ) then - do n = 1, ntot_amode + do n = 1, ntot_amode_m dqdt_nh4(n) = fgain_nh4(n)*sum_dqdt_nh4 qnew_nh4 = qold_nh4(n) + dqdt_nh4(n)*deltat qnew_so4 = qold_so4(n) + dqdt_so4(n)*deltat @@ -592,25 +815,12 @@ subroutine modal_aero_gasaerexch_sub( & niter_max = 1000 dqdt_soa(:,:) = 0.0_r8 dqdt_soag(:) = 0.0_r8 - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m qold_soag(jsoa) = q(i,k,l_soag(jsoa)) end do - ! get molecular weight from the host model - do n = 1, ntot_amode - do l = 1, nspec_amode(n) - call rad_aer_get_info(0, n, l, spec_type=spec_type ) - select case( spec_type ) - case('s-organic') - mw_soa_host(:) = specmw_amode(l,n) - case('p-organic') - mw_poa_host(:) = specmw_amode(l,n) - end select - end do - end do - call modal_aero_soaexch( deltat, t(i,k), pmid(i,k), & - niter, niter_max, ntot_amode, ntot_soamode, npoa, nsoa, & + niter, niter_max, ntot_amode_m, ntot_soamode, npoa_m, nsoa_m, & mw_poa_host, mw_soa_host, & qold_soag, qold_soa, qold_poa, uptkrate_soa, & dqdt_soag, dqdt_soa ) @@ -620,8 +830,8 @@ subroutine modal_aero_gasaerexch_sub( & ! compute TMR tendencies for soa interstial aerosol ! due to simple gas uptake - do jsoa = 1, nsoa - do n = 1, ntot_amode + do jsoa = 1, nsoa_m + do n = 1, ntot_amode_m dqdt_soa(n,jsoa) = fgain_soa(n,jsoa)*sum_dqdt_soa(jsoa) end do end do @@ -630,60 +840,27 @@ subroutine modal_aero_gasaerexch_sub( & end if pdel_fac = pdel(i,k)/gravit - do n = 1, ntot_amode + do n = 1, ntot_amode_m if (ido_so4a(n) == 1) then - l = lptr_so4_a_amode(n)-loffset + l = idx_so4_a_q(n) dqdt(i,k,l) = dqdt_so4(n) - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf) + dqdt_so4(n)*pdel_fac + qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_so4(n)*pdel_fac end if if ( do_nh4g ) then if (ido_nh4a(n) == 1) then - l = lptr_nh4_a_amode(n)-loffset + l = idx_nh4_a_q(n) dqdt(i,k,l) = dqdt_nh4(n) - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf) + dqdt_nh4(n)*pdel_fac + qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_nh4(n)*pdel_fac end if end if - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m if ( do_soag(jsoa) ) then if (ido_soaa(n,jsoa) == 1) then - l = lptr2_soa_a_amode(n,jsoa)-loffset + l = idx_soa_a_q(n,jsoa) dqdt(i,k,l) = dqdt_soa(n,jsoa) !calculated by modal_aero_soaexch for method_soa=2 - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf) + dqdt_soa(n,jsoa)*pdel_fac -!------- Add code for condensation/evaporation diagnostics--- - if (nsoa.eq.15) then !check for current SOA package - if(jsoa.ge.1.and.jsoa.le.5) then ! Fossil SOA species - if (dqdt_soa(n,jsoa).ge.0.0_r8) then - qconff(i,k)=qconff(i,k)+dqdt_soa(n,jsoa)*(adv_mass(l)/mwdry) - elseif(dqdt_soa(n,jsoa).lt.0.0_r8) then - qevapff(i,k)=qevapff(i,k)+dqdt_soa(n,jsoa)*(adv_mass(l)/mwdry) - endif - - elseif(jsoa.ge.6.and.jsoa.le.10) then ! Biomass SOA species - if (dqdt_soa(n,jsoa).ge.0.0_r8) then - qconbb(i,k)=qconbb(i,k)+dqdt_soa(n,jsoa)*(adv_mass(l)/mwdry) - elseif(dqdt_soa(n,jsoa).lt.0.0_r8) then - qevapbb(i,k)=qevapbb(i,k)+dqdt_soa(n,jsoa)*(adv_mass(l)/mwdry) - endif - - elseif(jsoa.ge.11.and.jsoa.le.15) then ! Biomass SOA species - if (dqdt_soa(n,jsoa).ge.0.0_r8) then - qconbg(i,k)=qconbg(i,k)+dqdt_soa(n,jsoa)*(adv_mass(l)/mwdry) - elseif(dqdt_soa(n,jsoa).lt.0.0_r8) then - qevapbg(i,k)=qevapbg(i,k)+dqdt_soa(n,jsoa)*(adv_mass(l)/mwdry) - endif - - endif ! jsoa - endif !nsoa - if (nsoa.eq.5) then !check for current SOA package - if (dqdt_soa(n,jsoa).ge.0.0_r8) then - qcon(i,k)=qcon(i,k)+dqdt_soa(n,jsoa)*(adv_mass(l)/mwdry) - elseif(dqdt_soa(n,jsoa).lt.0.0_r8) then - qevap(i,k)=qevap(i,k)+dqdt_soa(n,jsoa)*(adv_mass(l)/mwdry) - endif - endif !nsoa -!--------------------------------------------------------------------------------------------------------------------- + qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_soa(n,jsoa)*pdel_fac end if end if end do @@ -693,42 +870,42 @@ subroutine modal_aero_gasaerexch_sub( & ! due to simple gas uptake l = l_so4g dqdt(i,k,l) = -sum_dqdt_so4 - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf) + dqdt(i,k,l)*pdel_fac + qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt(i,k,l)*pdel_fac if ( do_msag ) then l = l_msag dqdt(i,k,l) = -sum_dqdt_msa - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf) + dqdt(i,k,l)*pdel_fac + qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt(i,k,l)*pdel_fac end if if ( do_nh4g ) then l = l_nh4g dqdt(i,k,l) = -sum_dqdt_nh4_b - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf) + dqdt(i,k,l)*pdel_fac + qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt(i,k,l)*pdel_fac end if - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m if ( do_soag(jsoa) ) then l = l_soag(jsoa) dqdt(i,k,l) = -sum_dqdt_soa(jsoa) ! dqdt for gas is negative of the sum of dqdt for aerosol soa species in each mode: Manish - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf) + dqdt(i,k,l)*pdel_fac + qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt(i,k,l)*pdel_fac end if end do ! compute TMR tendencies associated with primary carbon aging if (modefrm_pcage > 0) then - n = modeptr_pcarbon + n = modeptr_pcarbon_m tmpa = 0.0_r8 - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m tmpa = tmpa + dqdt_soa(n,jsoa)*fac_m2v_soa(jsoa)*soa_equivso4_factor(jsoa) end do vol_shell = deltat * & ( dqdt_so4(n)*fac_m2v_so4 + dqdt_nh4(n)*fac_m2v_nh4 + tmpa ) vol_core = 0.0_r8 - do l = 1, nspec_amode(n) + do l = 1, nspec_amode_m(n) vol_core = vol_core + & - q(i,k,lmassptr_amode(l,n)-loffset)*fac_m2v_pcarbon(l) + q(i,k,idx_mass_q(l,n))*fac_m2v_pcarbon(l) end do ! ratio1 = vol_shell/vol_core = ! actual hygroscopic-shell-volume/carbon-core-volume after gas uptake @@ -751,34 +928,34 @@ subroutine modal_aero_gasaerexch_sub( & if (xferfrac_pcage > 0.0_r8) then do iq = 1, nspecfrm_pcage - lsfrm = lspecfrm_pcage(iq)-loffset - lstoo = lspectoo_pcage(iq)-loffset + lsfrm = lspecfrm_q(iq) + lstoo = lspectoo_q(iq) xferrate = (xferfrac_pcage/deltat)*q(i,k,lsfrm) dqdt(i,k,lsfrm) = dqdt(i,k,lsfrm) - xferrate - qsrflx(i,lsfrm,jsrf) = qsrflx(i,lsfrm,jsrf) - xferrate*pdel_fac - if ((lstoo > 0) .and. (lstoo <= pcnst)) then + qsrflx_gaexch(i,lsfrm) = qsrflx_gaexch(i,lsfrm) - xferrate*pdel_fac + if ((lstoo > 0) .and. (lstoo <= num_q)) then dqdt(i,k,lstoo) = dqdt(i,k,lstoo) + xferrate - qsrflx(i,lstoo,jsrf) = qsrflx(i,lstoo,jsrf) + xferrate*pdel_fac + qsrflx_gaexch(i,lstoo) = qsrflx_gaexch(i,lstoo) + xferrate*pdel_fac end if end do if (ido_so4a(modetoo_pcage) > 0) then - l = lptr_so4_a_amode(modetoo_pcage)-loffset + l = idx_so4_a_q(modetoo_pcage) dqdt(i,k,l) = dqdt(i,k,l) + dqdt_so4(modefrm_pcage) - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf) + dqdt_so4(modefrm_pcage)*pdel_fac + qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_so4(modefrm_pcage)*pdel_fac end if if (ido_nh4a(modetoo_pcage) > 0) then - l = lptr_nh4_a_amode(modetoo_pcage)-loffset + l = idx_nh4_a_q(modetoo_pcage) dqdt(i,k,l) = dqdt(i,k,l) + dqdt_nh4(modefrm_pcage) - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf) + dqdt_nh4(modefrm_pcage)*pdel_fac + qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_nh4(modefrm_pcage)*pdel_fac end if - do jsoa = 1, nsoa + do jsoa = 1, nsoa_m if (ido_soaa(modetoo_pcage,jsoa) > 0) then - l = lptr2_soa_a_amode(modetoo_pcage,jsoa)-loffset + l = idx_soa_a_q(modetoo_pcage,jsoa) dqdt(i,k,l) = dqdt(i,k,l) + dqdt_soa(modefrm_pcage,jsoa) - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf) + dqdt_soa(modefrm_pcage,jsoa)*pdel_fac + qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_soa(modefrm_pcage,jsoa)*pdel_fac end if end do @@ -789,205 +966,44 @@ subroutine modal_aero_gasaerexch_sub( & end do ! "i = 1, ncol" end do ! "k = top_lev, pver" -! set "temporary testing arrays" - qold(:,:,:) = q(:,:,:) - qqcwold(:,:,:) = qqcw(:,:,:) - dqdtsv1(:,:,:) = dqdt(:,:,:) - dqqcwdtsv1(:,:,:) = dqqcwdt(:,:,:) - - -! -! do renaming calcs -! - dotendrn(:) = .false. - dotendqqcwrn(:) = .false. - dorename_atik(1:ncol,:) = .true. - is_dorename_atik = .true. - call modal_aero_rename_sub( & - 'modal_aero_gasaerexch_sub', & - lchnk, ncol, nstep, & - loffset, deltat, & - pdel, troplev, & - dotendrn, q, & - dqdt, dqdt_other, & - dotendqqcwrn, qqcw, & - dqqcwdt, dqqcwdt_other, & - is_dorename_atik, dorename_atik, & - jsrflx_rename, nsrflx, & - qsrflx, qqcwsrflx ) - - -! This applies dqdt tendencies for all species -! apply the dqdt to update q (and same for qqcw) -! - do l = 1, pcnstxx - if ( dotend(l) .or. dotendrn(l) ) then - do k = top_lev, pver - do i = 1, ncol - q(i,k,l) = q(i,k,l) + dqdt(i,k,l)*deltat - end do - end do - end if - if ( dotendqqcw(l) .or. dotendqqcwrn(l) ) then - do k = top_lev, pver - do i = 1, ncol - qqcw(i,k,l) = qqcw(i,k,l) + dqqcwdt(i,k,l)*deltat - end do - end do - end if - end do - -! diagnostics start ------------------------------------------------------- -!!$ if (ldiag3 > 0) then -!!$ if (icol_diag > 0) then -!!$ i = icol_diag -!!$ write(*,'(a,3i5)') 'gasaerexch ppp nstep,lat,lon', nstep, latndx(i), lonndx(i) -!!$ write(*,'(2i5,3(2x,a))') 0, 0, 'ppp', 'pdel for all k' -!!$ write(*,'(1p,7e12.4)') (pdel(i,k), k=top_lev,pver) -!!$ -!!$ write(*,'(a,3i5)') 'gasaerexch ddd nstep,lat,lon', nstep, latndx(i), lonndx(i) -!!$ do l = 1, pcnstxx -!!$ lb = l + loffset -!!$ -!!$ if ( dotend(l) .or. dotendrn(l) ) then -!!$ write(*,'(2i5,3(2x,a))') 1, l, 'ddd1', cnst_name(lb), 'qold for all k' -!!$ write(*,'(1p,7e12.4)') (qold(i,k,l), k=top_lev,pver) -!!$ write(*,'(2i5,3(2x,a))') 1, l, 'ddd2', cnst_name(lb), 'qnew for all k' -!!$ write(*,'(1p,7e12.4)') (q(i,k,l), k=top_lev,pver) -!!$ write(*,'(2i5,3(2x,a))') 1, l, 'ddd3', cnst_name(lb), 'dqdt from conden for all k' -!!$ write(*,'(1p,7e12.4)') (dqdtsv1(i,k,l), k=top_lev,pver) -!!$ write(*,'(2i5,3(2x,a))') 1, l, 'ddd4', cnst_name(lb), 'dqdt from rename for all k' -!!$ write(*,'(1p,7e12.4)') ((dqdt(i,k,l)-dqdtsv1(i,k,l)), k=top_lev,pver) -!!$ write(*,'(2i5,3(2x,a))') 1, l, 'ddd5', cnst_name(lb), 'dqdt other for all k' -!!$ write(*,'(1p,7e12.4)') (dqdt_other(i,k,l), k=top_lev,pver) -!!$ end if -!!$ -!!$ if ( dotendqqcw(l) .or. dotendqqcwrn(l) ) then -!!$ write(*,'(2i5,3(2x,a))') 2, l, 'ddd1', cnst_name_cw(lb), 'qold for all k' -!!$ write(*,'(1p,7e12.4)') (qqcwold(i,k,l), k=top_lev,pver) -!!$ write(*,'(2i5,3(2x,a))') 2, l, 'ddd2', cnst_name_cw(lb), 'qnew for all k' -!!$ write(*,'(1p,7e12.4)') (qqcw(i,k,l), k=top_lev,pver) -!!$ write(*,'(2i5,3(2x,a))') 2, l, 'ddd3', cnst_name_cw(lb), 'dqdt from conden for all k' -!!$ write(*,'(1p,7e12.4)') (dqqcwdtsv1(i,k,l), k=top_lev,pver) -!!$ write(*,'(2i5,3(2x,a))') 2, l, 'ddd4', cnst_name_cw(lb), 'dqdt from rename for all k' -!!$ write(*,'(1p,7e12.4)') ((dqqcwdt(i,k,l)-dqqcwdtsv1(i,k,l)), k=top_lev,pver) -!!$ write(*,'(2i5,3(2x,a))') 2, l, 'ddd5', cnst_name_cw(lb), 'dqdt other for all k' -!!$ write(*,'(1p,7e12.4)') (dqqcwdt_other(i,k,l), k=top_lev,pver) -!!$ end if -!!$ -!!$ end do -!!$ -!!$ write(*,'(a,3i5)') 'gasaerexch fff nstep,lat,lon', nstep, latndx(i), lonndx(i) -!!$ do l = 1, pcnstxx -!!$ lb = l + loffset -!!$ if ( dotend(l) .or. dotendrn(l) .or. dotendqqcw(l) .or. dotendqqcwrn(l) ) then -!!$ write(*,'(i5,2(2x,a,2l3))') l, & -!!$ cnst_name(lb), dotend(l), dotendrn(l), & -!!$ cnst_name_cw(lb), dotendqqcw(l), dotendqqcwrn(l) -!!$ end if -!!$ end do -!!$ -!!$ end if -!!$ end if -! diagnostics end --------------------------------------------------------- - -!-----Outfld for condensation/evaporation------------------------------ - if (nsoa.eq.5) then !check for current SOA package - call outfld(trim('qcon_gaex'), qcon(:,:), pcols, lchnk ) - call outfld(trim('qevap_gaex'), qevap(:,:), pcols, lchnk ) - endif -!----------------------------------------------------------------------- - if (nsoa.eq.15) then !check for current SOA package - call outfld(trim('qconff_gaex'), qconff(:,:), pcols, lchnk ) - call outfld(trim('qevapff_gaex'), qevapff(:,:), pcols, lchnk ) - call outfld(trim('qconbb_gaex'), qconbb(:,:), pcols, lchnk ) - call outfld(trim('qevapbb_gaex'), qevapbb(:,:), pcols, lchnk ) - call outfld(trim('qconbg_gaex'), qconbg(:,:), pcols, lchnk ) - call outfld(trim('qevapbg_gaex'), qevapbg(:,:), pcols, lchnk ) - endif -!----------------------------------------------------------------------- - -! do history file column-tendency fields - do l = 1, pcnstxx - lb = l + loffset - do jsrf = 1, 2 - do jac = 1, 2 - if (jac == 1) then - if (jsrf == jsrflx_gaexch) then - if ( .not. dotend(l) ) cycle - fieldname = trim(cnst_name(lb)) // '_sfgaex1' - else if (jsrf == jsrflx_rename) then - if ( .not. dotendrn(l) ) cycle - fieldname = trim(cnst_name(lb)) // '_sfgaex2' - else - cycle - end if - do i = 1, ncol - qsrflx(i,l,jsrf) = qsrflx(i,l,jsrf)*(adv_mass(l)/mwdry) - end do - call outfld( fieldname, qsrflx(:,l,jsrf), pcols, lchnk ) - else - if (jsrf == jsrflx_gaexch) then - cycle - else if (jsrf == jsrflx_rename) then - if ( .not. dotendqqcwrn(l) ) cycle - fieldname = trim(cnst_name_cw(lb)) // '_sfgaex2' - else - cycle - end if - do i = 1, ncol - qqcwsrflx(i,l,jsrf) = qqcwsrflx(i,l,jsrf)*(adv_mass(l)/mwdry) - end do - call outfld( fieldname, qqcwsrflx(:,l,jsrf), pcols, lchnk ) - end if - end do ! jac = ... - end do ! jsrf = ... - end do ! l = ... - - return - end subroutine modal_aero_gasaerexch_sub +end subroutine modal_aero_gasaerexch_run -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -subroutine gas_aer_uptkrates( ncol, loffset, & +subroutine gas_aer_uptkrates( ncol, pver, top_lev, & + loffset, & q, t, pmid, & dgncur_awet, 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 -! - -use physconst, only: mwdry, rair - -implicit none - + ! + ! / + ! 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 + ! integer, intent(in) :: ncol ! number of atmospheric column - integer, intent(in) :: loffset - real(r8), intent(in) :: q(ncol,pver,pcnstxx) ! Tracer array (mol,#/mol-air) - real(r8), intent(in) :: t(pcols,pver) ! Temperature in Kelvin - real(r8), intent(in) :: pmid(pcols,pver) ! Air pressure in Pa - real(r8), intent(in) :: dgncur_awet(pcols,pver,ntot_amode) - - real(r8), intent(out) :: uptkrate(ntot_amode,pcols,pver) + integer, intent(in) :: pver ! number of vertical levels + integer, intent(in) :: top_lev ! top level for aerosol processes + integer, intent(in) :: loffset ! offset to convert pcnst-space to vmr space + real(r8), intent(in) :: q(:,:,:) ! (ncol,pver,num_q) Tracer array (mol,#/mol-air) + real(r8), intent(in) :: t(:,:) ! (ncol,pver) Temperature in Kelvin + real(r8), intent(in) :: pmid(:,:) ! (ncol,pver) Air pressure in Pa + real(r8), intent(in) :: dgncur_awet(:,:,:) ! (ncol,pver,ntot_amode_m) + + real(r8), intent(out) :: uptkrate(:,:,:) ! (ntot_amode_m,ncol,pver) ! gas-to-aerosol mass transfer rates (1/s) ! local integer, parameter :: nghq = 2 - integer :: i, iq, k, l1, l2, la, n + integer :: i, iq, k, n ! Can use sqrt here once Lahey is gone. real(r8), parameter :: tworootpi = 3.5449077_r8 @@ -996,8 +1012,7 @@ subroutine gas_aer_uptkrates( ncol, loffset, & real(r8) :: aircon real(r8) :: const - real(r8) :: dp, dum_m2v - real(r8) :: dryvol_a(pcols,pver) + real(r8) :: dp real(r8) :: gasdiffus, gasspeed real(r8) :: freepathx2, fuchs_sutugin real(r8) :: knudsen @@ -1012,7 +1027,7 @@ subroutine gas_aer_uptkrates( ncol, loffset, & ! outermost loop over all modes - do n = 1, ntot_amode + do n = 1, ntot_amode_m ! 22-aug-2007 rc easter - get number from q array rather ! than computing a "bounded" number conc. @@ -1034,7 +1049,7 @@ subroutine gas_aer_uptkrates( ncol, loffset, & do k=top_lev,pver do i=1,ncol - rhoair = pmid(i,k)/(rair*t(i,k)) ! (kg-air/m3) + rhoair = pmid(i,k)/(rair_m*t(i,k)) ! (kg-air/m3) ! aircon = 1.0e3*rhoair/mwdry ! (mol-air/m3) !! "bounded" number conc. (#/m3) @@ -1042,8 +1057,8 @@ subroutine gas_aer_uptkrates( ncol, loffset, & ! number conc. (#/m3) -- note q(i,k,numptr) is (#/kmol-air) ! so need aircon in (kmol-air/m3) - aircon = rhoair/mwdry ! (kmol-air/m3) - num_a = q(i,k,numptr_amode(n)-loffset)*aircon + aircon = rhoair/mwdry_m ! (kmol-air/m3) + num_a = q(i,k,idx_num_m(n)-loffset)*aircon ! gasdiffus = h2so4 gas diffusivity from mosaic code (m^2/s) ! (pmid must be Pa) @@ -1053,7 +1068,7 @@ subroutine gas_aer_uptkrates( ncol, loffset, & ! freepathx2 = 2 * (h2so4 mean free path) (m) freepathx2 = 6.0_r8*gasdiffus/gasspeed - lnsg = log( sigmag_amode(n) ) + lnsg = log( sigmag_amode_m(n) ) lndpgn = log( dgncur_awet(i,k,n) ) ! (m) const = tworootpi * num_a * exp(beta*lndpgn + 0.5_r8*(beta*lnsg)**2) @@ -1081,13 +1096,11 @@ subroutine gas_aer_uptkrates( ncol, loffset, & end do ! "do n = 1, ntot_soamode" - - return - end subroutine gas_aer_uptkrates +end subroutine gas_aer_uptkrates !---------------------------------------------------------------------- - subroutine modal_aero_soaexch( dtfull, temp, pres, & +subroutine modal_aero_soaexch( dtfull, temp, pres, & niter, niter_max, ntot_amode, ntot_soamode, ntot_poaspec, ntot_soaspec, & mw_poa_host, mw_soa_host, & g_soa_in, a_soa_in, a_poa_in, xferrate_in, & @@ -1114,8 +1127,6 @@ subroutine modal_aero_soaexch( dtfull, temp, pres, & ! Additions to run with multiple BC, SOA and POM's: Shrivastava et al., 2015 !----------------------------------------------------------------------- - use mo_constants, only: rgas ! Gas constant (J/K/mol) - implicit none real(r8), intent(in) :: dtfull ! full integration time step (s) @@ -1142,6 +1153,7 @@ subroutine modal_aero_soaexch( dtfull, temp, pres, & logical :: skip_soamode(ntot_amode) ! true if this mode does not have soa + real(r8) :: rgas real(r8), parameter :: a_min1 = 1.0e-20_r8 real(r8), parameter :: g_min1 = 1.0e-20_r8 real(r8), parameter :: alpha = 0.05_r8 ! parameter used in calc of time step @@ -1173,7 +1185,9 @@ subroutine modal_aero_soaexch( dtfull, temp, pres, & real(r8) :: tot_soa(ntot_soaspec) ! g_soa + sum( a_soa(:) ) real(r8) :: xferrate(ntot_amode,ntot_soaspec) ! gas-aerosol mass transfer rate (1/s) -! Changed by Manish Shrivastava + rgas = rgas_m + + ! Changed by Manish Shrivastava opoa_frac(:) = 0.0_r8 !POA does not form solution with SOA for all runs; set opoa_frac=0.0_r8 by Manish Shrivastava mw_poa(:) = 250.0_r8 mw_soa(:) = 250.0_r8 @@ -1421,469 +1435,6 @@ subroutine modal_aero_soaexch( dtfull, temp, pres, & end do end do - - return - - end subroutine modal_aero_soaexch - -!---------------------------------------------------------------------- - -!---------------------------------------------------------------------- - - subroutine modal_aero_gasaerexch_init - -!----------------------------------------------------------------------- -! -! Purpose: -! set do_adjust and do_aitken flags -! create history fields for column tendencies associated with -! modal_aero_calcsize -! -! Author: R. Easter -! -!----------------------------------------------------------------------- - -use modal_aero_data -use modal_aero_rename - -use cam_abortutils, only: endrun -use cam_history, only: addfld, add_default, fieldname_len, horiz_only -use constituents, only: pcnst, cnst_get_ind, cnst_name -use spmd_utils, only: masterproc -use phys_control, only: phys_getopts - -implicit none - -!----------------------------------------------------------------------- -! arguments - -!----------------------------------------------------------------------- -! local - integer :: ipair, iq, iqfrm, iqfrm_aa, iqtoo, iqtoo_aa - integer :: jac,jsoa,p - integer :: l, l1, l2, lsfrm, lstoo, lunout - integer :: l_so4g, l_nh4g, l_msag - integer :: m, mfrm, mtoo - integer :: n, nacc, nait - integer :: nchfrm, nchfrmskip, nchtoo, nchtooskip, nspec - - logical :: do_msag, do_nh4g - logical :: do_soag_any, do_soag(nsoa) - logical :: dotend(pcnst), dotendqqcw(pcnst) - - 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 - - logical :: history_aerosol ! Output the MAM aerosol tendencies - logical :: history_aerocom ! Output the aerocom history - !----------------------------------------------------------------------- - - call phys_getopts( history_aerosol_out = history_aerosol ) - - maxspec_pcage = nspec_max - allocate(lspecfrm_pcage(maxspec_pcage)) - allocate(lspectoo_pcage(maxspec_pcage)) - allocate(soa_equivso4_factor(nsoa)) - allocate(fac_m2v_soa(nsoa)) - allocate(fac_m2v_pcarbon(nspec_max)) - lunout = 6 -! -! define "from mode" and "to mode" for primary carbon aging -! -! skip (turn off) aging if either is absent, -! or if accum mode so4 is absent -! - modefrm_pcage = -999888777 - modetoo_pcage = -999888777 - if ((modeptr_pcarbon <= 0) .or. (modeptr_accum <= 0)) goto 15000 - l = lptr_so4_a_amode(modeptr_accum) - if ((l < 1) .or. (l > pcnst)) goto 15000 - - modefrm_pcage = modeptr_pcarbon - modetoo_pcage = modeptr_accum - -! -! define species involved in each primary carbon aging pairing -! (include aerosol water) -! -! - mfrm = modefrm_pcage - mtoo = modetoo_pcage - - 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 - lsfrm = numptr_amode(mfrm) - lstoo = numptr_amode(mtoo) - else if (iqfrm == 0) then -! bypass transfer of aerosol water due to primary-carbon aging - cycle aa_iqfrm -! lsfrm = lwaterptr_amode(mfrm) -! lstoo = lwaterptr_amode(mtoo) - else - lsfrm = lmassptr_amode(iqfrm,mfrm) - lstoo = 0 - end if - if ((lsfrm < 1) .or. (lsfrm > pcnst)) cycle aa_iqfrm - - if (lsfrm>0 .and. iqfrm>0 ) then - nchfrm = len( trim( cnst_name(lsfrm) ) ) - nchfrmskip - -! find "too" species having same lspectype_amode as the "frm" species -! AND same cnst_name (except for last 1/2/3 characters which are the mode index) - do iqtoo = 1, nspec_amode(mtoo) -! if ( lspectype_amode(iqtoo,mtoo) .eq. & -! lspectype_amode(iqfrm,mfrm) ) then - lstoo = lmassptr_amode(iqtoo,mtoo) - nchtoo = len( trim( cnst_name(lstoo) ) ) - nchtooskip - if (cnst_name(lsfrm)(1:nchfrm) == cnst_name(lstoo)(1:nchtoo)) then - exit - else - lstoo = 0 - end if -! end if - end do - end if - - if ((lstoo < 1) .or. (lstoo > pcnst)) lstoo = 0 - nspec = nspec + 1 - lspecfrm_pcage(nspec) = lsfrm - lspectoo_pcage(nspec) = lstoo - end do aa_iqfrm - - nspecfrm_pcage = nspec - -! -! output results -! - if ( masterproc ) then - - write(lunout,9310) - - mfrm = modefrm_pcage - mtoo = modetoo_pcage - write(lunout,9320) 1, mfrm, mtoo - - do iq = 1, nspecfrm_pcage - lsfrm = lspecfrm_pcage(iq) - lstoo = lspectoo_pcage(iq) - if (lstoo .gt. 0) then - write(lunout,9330) lsfrm, cnst_name(lsfrm), & - lstoo, cnst_name(lstoo) - else - write(lunout,9340) lsfrm, cnst_name(lsfrm) - end if - end do - - write(lunout,*) - - end if ! ( masterproc ) - -9310 format( / 'subr. modal_aero_gasaerexch_init - primary carbon aging pointers' ) -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' ) - - -15000 continue - -! set tendency flags and gas species indices and flags - dotend(:) = .false. - - call cnst_get_ind( 'H2SO4', l_so4g, .false. ) - if ((l_so4g <= 0) .or. (l_so4g > pcnst)) then - write( *, '(/a/a,2i7)' ) & - '*** modal_aero_gasaerexch_init -- cannot find H2SO4 species', & - ' l_so4g=', l_so4g - call endrun( 'modal_aero_gasaerexch_init error' ) - end if - dotend(l_so4g) = .true. - - call cnst_get_ind( 'NH3', l_nh4g, .false. ) - do_nh4g = .false. - if ((l_nh4g > 0) .and. (l_nh4g <= pcnst)) then - do_nh4g = .true. - dotend(l_nh4g) = .true. - end if - - call cnst_get_ind( 'MSA', l_msag, .false. ) - do_msag = .false. - if ((l_msag > 0) .and. (l_msag <= pcnst)) then - do_msag = .true. - dotend(l_msag) = .true. - end if - - do_soag_any = .false. - do_soag(:) = .false. - do jsoa = 1, nsoa - l = lptr2_soa_g_amode(jsoa) - if ((l > 0) .and. (l <= pcnst)) then - do_soag_any = .true. - do_soag(jsoa) = .true. - dotend(l) = .true. - end if - end do - - - do n = 1, ntot_amode - l = lptr_so4_a_amode(n) - if ((l > 0) .and. (l <= pcnst)) then - dotend(l) = .true. - if ( do_nh4g ) then - l = lptr_nh4_a_amode(n) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end if - end if - do jsoa = 1, nsoa - if ( do_soag(jsoa) ) then - l = lptr2_soa_a_amode(n,jsoa) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end if - end do - end do - - if (modefrm_pcage > 0) then - do iq = 1, nspecfrm_pcage - lsfrm = lspecfrm_pcage(iq) - lstoo = lspectoo_pcage(iq) - if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then - dotend(lsfrm) = .true. - if ((lstoo > 0) .and. (lstoo <= pcnst)) then - dotend(lstoo) = .true. - end if - end if - end do - end if - -!---------define history fields for new cond/evap diagnostics---------------------------------------- - fieldname=trim('qconff_gaex') - long_name = trim('3D fields for Fossil SOA condensation') - unit = 'kg/kg/s' - call addfld(fieldname, (/'lev'/), 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,3x))') 'qconff addfld', fieldname, unit - - fieldname=trim('qevapff_gaex') - long_name = trim('3D fields for Fossil SOA evaporation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,3x))') 'qevapff addfld', fieldname, unit - - fieldname=trim('qconbb_gaex') - long_name = trim('3D fields for Biomass SOA condensation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,3x))') 'qconbb addfld', fieldname, unit - - fieldname=trim('qevapbb_gaex') - long_name = trim('3D fields for Biomass SOA evaporation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,3x))') 'qevapbb addfld', fieldname, unit - - fieldname=trim('qconbg_gaex') - long_name = trim('3D fields for Biogenic SOA condensation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,3x))') 'qconbg addfld', fieldname, unit - - fieldname=trim('qevapbg_gaex') - long_name = trim('3D fields for Biogenic SOA evaporation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,3x))') 'qevapbg addfld', fieldname, unit - - fieldname=trim('qcon_gaex') - long_name = trim('3D fields for SOA condensation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,3x))') 'qcon addfld', fieldname, unit - - fieldname=trim('qevap_gaex') - long_name = trim('3D fields for Biogenic SOA evaporation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,3x))') 'qevap addfld', fieldname, unit -!------------------------------------------------------------------------------ - -! define history fields for basic gas-aer exchange -! and primary carbon aging from that - do l = 1, pcnst - if ( .not. dotend(l) ) cycle - - tmpnamea = cnst_name(l) - fieldname = trim(tmpnamea) // '_sfgaex1' - long_name = trim(tmpnamea) // ' gas-aerosol-exchange primary column tendency' - unit = 'kg/m2/s' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,3x))') 'gasaerexch addfld', fieldname, unit - - end do ! l = ... -! define history fields for aitken-->accum renaming - dotend(:) = .false. - dotendqqcw(:) = .false. - do ipair = 1, npair_renamexf - do iq = 1, nspecfrm_renamexf(ipair) - lsfrm = lspecfrma_renamexf(iq,ipair) - lstoo = lspectooa_renamexf(iq,ipair) - if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then - dotend(lsfrm) = .true. - if ((lstoo > 0) .and. (lstoo <= pcnst)) then - dotend(lstoo) = .true. - end if - end if - - lsfrm = lspecfrmc_renamexf(iq,ipair) - lstoo = lspectooc_renamexf(iq,ipair) - if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then - dotendqqcw(lsfrm) = .true. - if ((lstoo > 0) .and. (lstoo <= pcnst)) then - dotendqqcw(lstoo) = .true. - end if - end if - end do ! iq = ... - end do ! ipair = ... - - do l = 1, pcnst - do jac = 1, 2 - if (jac == 1) then - if ( .not. dotend(l) ) cycle - tmpnamea = cnst_name(l) - else - if ( .not. dotendqqcw(l) ) cycle - tmpnamea = cnst_name_cw(l) - end if - - fieldname = trim(tmpnamea) // '_sfgaex2' - long_name = trim(tmpnamea) // ' gas-aerosol-exchange renaming column tendency' - unit = 'kg/m2/s' - if ((tmpnamea(1:3) == 'num') .or. & - (tmpnamea(1:3) == 'NUM')) unit = '#/m2/s' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,3x))') 'gasaerexch addfld', fieldname, unit - end do ! jac = ... - end do ! l = ... - - -! set for used in aging calcs: -! fac_m2v_so4, fac_m2v_nh4, fac_m2v_soa(:) -! soa_equivso4_factor(:) - soa_equivso4_factor = 0.0_r8 - if (modefrm_pcage > 0) then - n = modeptr_accum - l = lptr_so4_a_amode(n) ; l2 = -1 - if (l <= 0) call endrun( 'modal_aero_gasaerexch_init error a001 finding accum. so4' ) - do l1 = 1, nspec_amode(n) - if (lmassptr_amode(l1,n) == l) then -! l2 = lspectype_amode(l1,n) - l2 = l1 -! fac_m2v_so4 = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_so4 = specmw_amode(l1,n) / specdens_amode(l1,n) -! tmp2 = spechygro(l2) - tmp2 = spechygro(l1,n) - - end if - end do - if (l2 <= 0) call endrun( 'modal_aero_gasaerexch_init error a002 finding accum. so4' ) - - l = lptr_nh4_a_amode(n) ; l2 = -1 - if (l > 0) then - do l1 = 1, nspec_amode(n) - if (lmassptr_amode(l1,n) == l) then -! l2 = lspectype_amode(l1,n) - l2 = l1 -! fac_m2v_nh4 = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_nh4 = specmw_amode(l1,n) / specdens_amode(l1,n) - - end if - end do - if (l2 <= 0) call endrun( 'modal_aero_gasaerexch_init error a002 finding accum. nh4' ) - else - fac_m2v_nh4 = fac_m2v_so4 - end if - - do jsoa = 1, nsoa - l = lptr2_soa_a_amode(n,jsoa) ; l2 = -1 - if (l <= 0) then - write( msg, '(a,i4)') 'modal_aero_gasaerexch_init error a001 finding accum. jsoa =', jsoa - call endrun( msg ) - end if - do l1 = 1, nspec_amode(n) - if (lmassptr_amode(l1,n) == l) then -! l2 = lspectype_amode(l1,n) - l2 = l1 -! fac_m2v_soa(jsoa) = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_soa(jsoa) = specmw_amode(l1,n) / specdens_amode(l1,n) -! soa_equivso4_factor(jsoa) = spechygro(l2)/tmp2 - soa_equivso4_factor(jsoa) = spechygro(l1,n)/tmp2 - end if - end do - if (l2 <= 0) then - write( msg, '(a,i4)') 'modal_aero_gasaerexch_init error a002 finding accum. jsoa =', jsoa - call endrun( msg ) - end if - end do - - fac_m2v_pcarbon(:) = 0.0_r8 - n = modeptr_pcarbon - do l = 1, nspec_amode(n) -! l2 = lspectype_amode(l,n) -! fac_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) -! [m3-AP/kmol-AP] = [kg-AP/kmol-AP] / [kg-AP/m3-AP] -! fac_m2v_pcarbon(l) = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_pcarbon(l) = specmw_amode(l,n) / specdens_amode(l,n) - end do - end if - - - return - - end subroutine modal_aero_gasaerexch_init - - -!---------------------------------------------------------------------- +end subroutine modal_aero_soaexch end module modal_aero_gasaerexch diff --git a/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 b/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 new file mode 100644 index 0000000000..3ecc2b4383 --- /dev/null +++ b/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 @@ -0,0 +1,497 @@ +! CAM wrapper for modal_aero_gasaerexch. +! Resolves CAM-specific species indices (applying loffset) and mode metadata, +! calls the portable modal_aero_gasaerexch_init, and registers history fields. +module modal_aero_gasaerexch_cam + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + private + + public :: modal_aero_gasaerexch_cam_init +contains + + ! Resolve species indices from CAM constituent arrays, + ! call portable modal_aero_gasaerexch_init, + ! and register history fields (addfld) for gas-aerosol exchange diagnostics. + subroutine modal_aero_gasaerexch_cam_init() + use modal_aero_gasaerexch, only: modal_aero_gasaerexch_init + use modal_aero_data, only: ntot_amode, nsoa, npoa, nspec_max, & + nspec_amode, modeptr_pcarbon, modeptr_accum, & + alnsg_amode, sigmag_amode, specmw_amode, specdens_amode, spechygro, & + lptr_so4_a_amode, lptr_nh4_a_amode, & + lptr2_soa_a_amode, lptr2_soa_g_amode, lptr2_pom_a_amode, & + numptr_amode, lmassptr_amode, cnst_name_cw + use modal_aero_rename_cam, only: npair_renamexf, nspecfrm_renamexf, & + lspecfrma_renamexf, lspectooa_renamexf, & + lspecfrmc_renamexf, lspectooc_renamexf + use radiative_aerosol, only: rad_aer_get_info + use constituents, only: pcnst, cnst_name, cnst_get_ind + use physconst, only: rair, mwdry, r_universal + use cam_history, only: addfld, add_default, fieldname_len, horiz_only + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc + use phys_control, only: phys_getopts, cam_chempkg_is + + ! indices are in pcnst (q) space + ! run phase receives loffset for gas_pcnst (vmr) space + + ! local + integer :: ipair, iq, iqfrm, iqtoo + integer :: jac, jsoa, j + integer :: l, lsfrm, lstoo, lunout + integer :: mfrm, mtoo + integer :: n, nspec + integer :: nchfrm, nchfrmskip, nchtoo, nchtooskip + + logical :: dotend(pcnst), dotendqqcw(pcnst) + + character(len=fieldname_len) :: tmpnamea + character(len=fieldname_len + 3) :: fieldname + character(128) :: long_name + character(8) :: unit + + logical :: history_aerosol + + ! Resolved species indices (pcnst-space, for portable _init) + integer :: idx_h2so4, idx_nh3, idx_msa + integer :: idx_soag(nsoa) + integer :: idx_so4_a(ntot_amode), idx_nh4_a(ntot_amode) + integer :: idx_soa_a(ntot_amode, nsoa) + integer :: idx_pom_a(ntot_amode, npoa) + integer :: idx_num(ntot_amode) + integer :: idx_mass(nspec_max, ntot_amode) + + ! pcage resolved arrays (pcnst-space) + integer :: nspecfrm_pcage_resolved + integer :: lspecfrm_pcage_resolved(nspec_max) + integer :: lspectoo_pcage_resolved(nspec_max) + + ! SOA/POA molecular weights from host + real(r8) :: mw_soa_host_resolved(nsoa) + real(r8) :: mw_poa_host_resolved(npoa) + + character(len=32) :: spec_type + character(len=256) :: errmsg + integer :: errflg + + call phys_getopts(history_aerosol_out=history_aerosol) + lunout = 6 + + !----------------------------------------------------------------------- + ! Part A: Resolve arguments and call portable _init + !----------------------------------------------------------------------- + + ! --- Gas-phase species indices (pcnst-space) --- + call cnst_get_ind('H2SO4', idx_h2so4, .false.) + if ((idx_h2so4 <= 0) .or. (idx_h2so4 > pcnst)) then + write (*, '(/a/a,i7)') & + '*** modal_aero_gasaerexch_cam_init -- cannot find H2SO4 species', & + ' idx_h2so4=', idx_h2so4 + call endrun('modal_aero_gasaerexch_cam_init error: H2SO4 not found') + end if + + call cnst_get_ind('NH3', idx_nh3, .false.) + if (.not. ((idx_nh3 > 0) .and. (idx_nh3 <= pcnst))) idx_nh3 = 0 + + if (.not. cam_chempkg_is('geoschem_mam4')) then + call cnst_get_ind('MSA', idx_msa, .false.) + else + idx_msa = 0 + end if + if (.not. ((idx_msa > 0) .and. (idx_msa <= pcnst))) idx_msa = 0 + + ! --- SOA gas-phase species indices (pcnst-space) --- + do jsoa = 1, nsoa + l = lptr2_soa_g_amode(jsoa) + if ((l > 0) .and. (l <= pcnst)) then + idx_soag(jsoa) = l + else + idx_soag(jsoa) = 0 + end if + end do + + ! --- Aerosol species indices (per mode, pcnst-space) --- + do n = 1, ntot_amode + l = lptr_so4_a_amode(n) + if ((l > 0) .and. (l <= pcnst)) then + idx_so4_a(n) = l + else + idx_so4_a(n) = 0 + end if + + l = lptr_nh4_a_amode(n) + if ((l > 0) .and. (l <= pcnst)) then + idx_nh4_a(n) = l + else + idx_nh4_a(n) = 0 + end if + + do jsoa = 1, nsoa + l = lptr2_soa_a_amode(n, jsoa) + if ((l > 0) .and. (l <= pcnst)) then + idx_soa_a(n, jsoa) = l + else + idx_soa_a(n, jsoa) = 0 + end if + end do + + do j = 1, npoa + l = lptr2_pom_a_amode(n, j) + if ((l > 0) .and. (l <= pcnst)) then + idx_pom_a(n, j) = l + else + idx_pom_a(n, j) = 0 + end if + end do + + l = numptr_amode(n) + if ((l > 0) .and. (l <= pcnst)) then + idx_num(n) = l + else + idx_num(n) = 0 + end if + + do l = 1, nspec_amode(n) + idx_mass(l, n) = lmassptr_amode(l, n) + end do + end do + + ! --- Resolve pcage species matching --- + ! Copied from original modal_aero_gasaerexch_init + ! Indices stored in pcnst-space. + nspecfrm_pcage_resolved = 0 + lspecfrm_pcage_resolved(:) = 0 + lspectoo_pcage_resolved(:) = 0 + + if ((modeptr_pcarbon > 0) .and. (modeptr_accum > 0)) then + l = lptr_so4_a_amode(modeptr_accum) + if ((l >= 1) .and. (l <= pcnst)) then + + mfrm = modeptr_pcarbon + mtoo = modeptr_accum + + 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 + lsfrm = numptr_amode(mfrm) + lstoo = numptr_amode(mtoo) + else if (iqfrm == 0) then + ! bypass transfer of aerosol water due to primary-carbon aging + cycle aa_iqfrm + else + lsfrm = lmassptr_amode(iqfrm, mfrm) + lstoo = 0 + end if + if ((lsfrm < 1) .or. (lsfrm > pcnst)) cycle aa_iqfrm + + if (lsfrm > 0 .and. iqfrm > 0) then + nchfrm = len(trim(cnst_name(lsfrm))) - nchfrmskip + + ! find "too" species having same cnst_name (except for last 1/2/3 characters which are the mode index) + do iqtoo = 1, nspec_amode(mtoo) + lstoo = lmassptr_amode(iqtoo, mtoo) + nchtoo = len(trim(cnst_name(lstoo))) - nchtooskip + if (cnst_name(lsfrm) (1:nchfrm) == cnst_name(lstoo) (1:nchtoo)) then + exit + else + lstoo = 0 + end if + end do + end if + + if ((lstoo < 1) .or. (lstoo > pcnst)) lstoo = 0 + nspec = nspec + 1 + lspecfrm_pcage_resolved(nspec) = lsfrm + lspectoo_pcage_resolved(nspec) = lstoo + end do aa_iqfrm + + nspecfrm_pcage_resolved = nspec + + ! output results + if (masterproc) then + write (lunout, 9310) + write (lunout, 9320) 1, mfrm, mtoo + + do iq = 1, nspecfrm_pcage_resolved + lsfrm = lspecfrm_pcage_resolved(iq) + lstoo = lspectoo_pcage_resolved(iq) + if (lstoo > 0) then + write (lunout, 9330) lsfrm, cnst_name(lsfrm), & + lstoo, cnst_name(lstoo) + else + write (lunout, 9340) lsfrm, cnst_name(lsfrm) + end if + end do + + write (lunout, *) + end if ! ( masterproc ) + +9310 format(/'subr. modal_aero_gasaerexch_cam_init - primary carbon aging pointers') +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') + + end if ! lptr_so4_a_amode(modeptr_accum) valid + end if ! modeptr_pcarbon > 0 .and. modeptr_accum > 0 + + ! --- Resolve SOA/POA molecular weights using rad_aer_get_info --- + mw_soa_host_resolved(:) = 0.0_r8 + mw_poa_host_resolved(:) = 0.0_r8 + + do n = 1, ntot_amode + do l = 1, nspec_amode(n) + call rad_aer_get_info(0, n, l, spec_type=spec_type) + select case (spec_type) + case ('s-organic') + mw_soa_host_resolved(:) = specmw_amode(l, n) + case ('p-organic') + mw_poa_host_resolved(:) = specmw_amode(l, n) + end select + end do + end do + + ! --- Call portable init --- + call modal_aero_gasaerexch_init( & + ntot_amode = ntot_amode, & + nsoa = nsoa, & + npoa = npoa, & + nspec_max = nspec_max, & + nspec_amode = nspec_amode, & + modeptr_pcarbon = modeptr_pcarbon, & + modeptr_accum = modeptr_accum, & + alnsg_amode = alnsg_amode, & + sigmag_amode = sigmag_amode, & + specmw_amode = specmw_amode, & + specdens_amode = specdens_amode, & + spechygro = spechygro, & + idx_h2so4 = idx_h2so4, & + idx_nh3 = idx_nh3, & + idx_msa = idx_msa, & + idx_soag = idx_soag, & + idx_so4_a = idx_so4_a, & + idx_nh4_a = idx_nh4_a, & + idx_soa_a = idx_soa_a, & + idx_pom_a = idx_pom_a, & + idx_num = idx_num, & + idx_mass = idx_mass, & + pcnst_in = pcnst, & + nspecfrm_pcage_in = nspecfrm_pcage_resolved, & + lspecfrm_pcage_in = lspecfrm_pcage_resolved, & + lspectoo_pcage_in = lspectoo_pcage_resolved, & + mw_soa_host = mw_soa_host_resolved, & + mw_poa_host = mw_poa_host_resolved, & + rair = rair, & + mwdry = mwdry, & + r_universal = r_universal, & + errmsg = errmsg, & + errflg = errflg) + + if (errflg /= 0) then + call endrun('modal_aero_gasaerexch_cam_init: '//trim(errmsg)) + end if + + !----------------------------------------------------------------------- + ! Part B: History field registration (addfld calls) + !----------------------------------------------------------------------- + + ! --- Tendency flags for _sfgaex1 fields --- + ! Determine which constituents get gas-aerosol exchange tendency output + dotend(:) = .false. + + ! H2SO4 (required). below indices are in pcnst indexing: + dotend(idx_h2so4) = .true. + + ! NH3 (optional) + if ((idx_nh3 > 0) .and. (idx_nh3 <= pcnst)) dotend(idx_nh3) = .true. + + ! MSA (optional) + if ((idx_msa > 0) .and. (idx_msa <= pcnst)) dotend(idx_msa) = .true. + + ! SOA gases + do jsoa = 1, nsoa + l = lptr2_soa_g_amode(jsoa) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end do + + ! Aerosol species in modes + do n = 1, ntot_amode + l = lptr_so4_a_amode(n) + if ((l > 0) .and. (l <= pcnst)) then + dotend(l) = .true. + if (idx_nh3 > 0) then + l = lptr_nh4_a_amode(n) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end if + end if + do jsoa = 1, nsoa + if (idx_soag(jsoa) > 0) then + l = lptr2_soa_a_amode(n, jsoa) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end if + end do + end do + + ! pcage species + if (nspecfrm_pcage_resolved > 0) then + do iq = 1, nspecfrm_pcage_resolved + ! lspec*_pcage_resolved are already pcnst-space (resolved above), so + ! they index dotend directly -- matching the original gasaerexch_init. + lsfrm = lspecfrm_pcage_resolved(iq) + lstoo = lspectoo_pcage_resolved(iq) + if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then + dotend(lsfrm) = .true. + if ((lstoo > 0) .and. (lstoo <= pcnst)) then + dotend(lstoo) = .true. + end if + end if + end do + end if + + ! --- SOA condensation/evaporation diagnostics --- + fieldname = trim('qconff_gaex') + long_name = trim('3D fields for Fossil SOA condensation') + unit = 'kg/kg/s' + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qconff addfld', fieldname, unit + + fieldname = trim('qevapff_gaex') + long_name = trim('3D fields for Fossil SOA evaporation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qevapff addfld', fieldname, unit + + fieldname = trim('qconbb_gaex') + long_name = trim('3D fields for Biomass SOA condensation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qconbb addfld', fieldname, unit + + fieldname = trim('qevapbb_gaex') + long_name = trim('3D fields for Biomass SOA evaporation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qevapbb addfld', fieldname, unit + + fieldname = trim('qconbg_gaex') + long_name = trim('3D fields for Biogenic SOA condensation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qconbg addfld', fieldname, unit + + fieldname = trim('qevapbg_gaex') + long_name = trim('3D fields for Biogenic SOA evaporation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qevapbg addfld', fieldname, unit + + fieldname = trim('qcon_gaex') + long_name = trim('3D fields for SOA condensation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qcon addfld', fieldname, unit + + fieldname = trim('qevap_gaex') + long_name = trim('3D fields for Biogenic SOA evaporation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qevap addfld', fieldname, unit + + ! --- Per-species _sfgaex1 fields (gas-aerosol exchange primary tendency) --- + do l = 1, pcnst + if (.not. dotend(l)) cycle + + tmpnamea = cnst_name(l) + fieldname = trim(tmpnamea)//'_sfgaex1' + long_name = trim(tmpnamea)//' gas-aerosol-exchange primary column tendency' + unit = 'kg/m2/s' + call addfld(fieldname, horiz_only, 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'gasaerexch addfld', fieldname, unit + + end do ! l = ... + + ! --- Per-species _sfgaex2 fields (renaming tendency) --- + dotend(:) = .false. + dotendqqcw(:) = .false. + do ipair = 1, npair_renamexf + do iq = 1, nspecfrm_renamexf(ipair) + lsfrm = lspecfrma_renamexf(iq, ipair) + lstoo = lspectooa_renamexf(iq, ipair) + if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then + dotend(lsfrm) = .true. + if ((lstoo > 0) .and. (lstoo <= pcnst)) then + dotend(lstoo) = .true. + end if + end if + + lsfrm = lspecfrmc_renamexf(iq, ipair) + lstoo = lspectooc_renamexf(iq, ipair) + if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then + dotendqqcw(lsfrm) = .true. + if ((lstoo > 0) .and. (lstoo <= pcnst)) then + dotendqqcw(lstoo) = .true. + end if + end if + end do ! iq = ... + end do ! ipair = ... + + do l = 1, pcnst + do jac = 1, 2 + if (jac == 1) then + if (.not. dotend(l)) cycle + tmpnamea = cnst_name(l) + else + if (.not. dotendqqcw(l)) cycle + tmpnamea = cnst_name_cw(l) + end if + + fieldname = trim(tmpnamea)//'_sfgaex2' + long_name = trim(tmpnamea)//' gas-aerosol-exchange renaming column tendency' + unit = 'kg/m2/s' + if ((tmpnamea(1:3) == 'num') .or. & + (tmpnamea(1:3) == 'NUM')) unit = '#/m2/s' + call addfld(fieldname, horiz_only, 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'gasaerexch addfld', fieldname, unit + end do ! jac = ... + end do ! l = ... + + end subroutine modal_aero_gasaerexch_cam_init +end module modal_aero_gasaerexch_cam diff --git a/src/chemistry/modal_aero/modal_aero_newnuc.F90 b/src/chemistry/modal_aero/modal_aero_newnuc.F90 index 5bb93be655..d4007f476d 100644 --- a/src/chemistry/modal_aero/modal_aero_newnuc.F90 +++ b/src/chemistry/modal_aero/modal_aero_newnuc.F90 @@ -11,27 +11,37 @@ module modal_aero_newnuc ! !USES: use shr_kind_mod, only: r8 => shr_kind_r8 - use shr_kind_mod, only: r4 => shr_kind_r4 - use mo_constants, only: pi - use chem_mods, only: gas_pcnst implicit none private save ! !PUBLIC MEMBER FUNCTIONS: - public modal_aero_newnuc_sub, modal_aero_newnuc_init + public modal_aero_newnuc_run, modal_aero_newnuc_init ! !PUBLIC DATA MEMBERS: - integer, parameter :: pcnstxx = gas_pcnst - integer :: l_h2so4_sv, l_nh3_sv, lnumait_sv, lnh4ait_sv, lso4ait_sv +! species indices in the host constituent space, set by modal_aero_newnuc_init; +! default 0 = bypass (host found no h2so4 or no aitken so4/num species) + integer :: l_h2so4_sv = 0, l_nh3_sv = 0, lnumait_sv = 0, lnh4ait_sv = 0, lso4ait_sv = 0 -! min h2so4 vapor for nuc calcs = 4.0e-16 mol/mol-air ~= 1.0e4 molecules/cm3, +! 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 real(r8) :: dens_so4a_host real(r8) :: mw_nh4a_host, mw_so4a_host +! aitken-mode geometry (nominal size + dry-diameter limits) from host mode metadata + real(r8) :: dgnum_aitken, dgnumhi_aitken, dgnumlo_aitken + +! host physical constants, set by modal_aero_newnuc_init (passed from the host +! rather than hardcoded so the values stay bit-identical with the host's) + real(r8) :: pi + real(r8) :: rgas ! gas constant (J/K/mol) + real(r8) :: avogad ! Avogadro's number (1/mol) + real(r8) :: mw_so4a ! molecular weight of sulfate (g/mol) + real(r8) :: mw_nh4a ! molecular weight of ammonium (g/mol) + real(r8) :: r_universal ! universal gas constant (J/K/kmol) + ! !DESCRIPTION: This module implements ... ! ! !REVISION HISTORY: @@ -53,58 +63,58 @@ module modal_aero_newnuc !---------------------------------------------------------------------- !---------------------------------------------------------------------- !BOP -! !ROUTINE: modal_aero_newnuc_sub --- ... +! !ROUTINE: modal_aero_newnuc_run --- ... ! ! !INTERFACE: - subroutine modal_aero_newnuc_sub( & - lchnk, ncol, nstep, & - loffset, deltat, & + subroutine modal_aero_newnuc_run( & + ncol, pver, top_lev, & + num_q, loffset, deltat, & t, pmid, pdel, & zm, pblh, & qv, cld, & - q, & - del_h2so4_gasprod, del_h2so4_aeruptk ) + q, gravit, & + del_h2so4_gasprod, del_h2so4_aeruptk, & + dqdt, dotend, qsrflx, & + errmsg, errflg ) ! !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 implicit none ! !PARAMETERS: - integer, intent(in) :: lchnk ! chunk identifier integer, intent(in) :: ncol ! number of columns in chunk - integer, intent(in) :: nstep ! model step + integer, intent(in) :: pver ! number of vertical levels + integer, intent(in) :: top_lev ! top level for modal aerosol calculations + integer, intent(in) :: num_q ! number of species in q/dqdt (= gas_pcnst) integer, intent(in) :: loffset ! offset applied to modal aero "pointers" real(r8), intent(in) :: deltat ! model timestep (s) - real(r8), intent(in) :: t(pcols,pver) ! temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) ! pressure at model levels (Pa) - real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: zm(pcols,pver) ! midpoint height above surface (m) - real(r8), intent(in) :: pblh(pcols) ! pbl height (m) - real(r8), intent(in) :: qv(pcols,pver) ! specific humidity (kg/kg) - real(r8), intent(in) :: cld(ncol,pver) ! stratiform cloud fraction - ! *** NOTE ncol dimension - real(r8), intent(inout) :: q(ncol,pver,pcnstxx) + real(r8), intent(in) :: t(:,:) ! (ncol,pver) temperature (K) + real(r8), intent(in) :: pmid(:,:) ! (ncol,pver) pressure at model levels (Pa) + real(r8), intent(in) :: pdel(:,:) ! (ncol,pver) pressure thickness of levels (Pa) + real(r8), intent(in) :: zm(:,:) ! (ncol,pver) midpoint height above surface (m) + real(r8), intent(in) :: pblh(:) ! (ncol) pbl height (m) + real(r8), intent(in) :: qv(:,:) ! (ncol,pver) specific humidity (kg/kg) + real(r8), intent(in) :: cld(:,:) ! (ncol,pver) stratiform cloud fraction + real(r8), intent(in) :: q(:,:,:) ! (ncol,pver,num_q) ! tracer mixing ratio (TMR) array ! *** MUST BE mol/mol-air or #/mol-air - ! *** NOTE ncol & pcnstxx dimensions - real(r8), intent(in) :: del_h2so4_gasprod(ncol,pver) - ! h2so4 gas-phase production + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + real(r8), intent(in) :: del_h2so4_gasprod(:,:) + ! (ncol,pver) h2so4 gas-phase production ! change over deltat (mol/mol) - real(r8), intent(in) :: del_h2so4_aeruptk(ncol,pver) - ! h2so4 gas-phase loss to + real(r8), intent(in) :: del_h2so4_aeruptk(:,:) + ! (ncol,pver) h2so4 gas-phase loss to ! aerosol over deltat (mol/mol) + real(r8), intent(out) :: dqdt(:,:,:) ! (ncol,pver,num_q) TMR tendency array + logical, intent(out) :: dotend(:) ! (num_q) flag for doing tendency + real(r8), intent(out) :: qsrflx(:,:,:) ! (ncol,num_q,1) + ! process-specific column tracer tendencies + ! 1 = nucleation (for aerocom) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! !DESCRIPTION: ! computes changes due to aerosol nucleation (new particle formation) @@ -124,7 +134,7 @@ subroutine modal_aero_newnuc_sub( & !BOC ! local variables - integer :: i, itmp, k, l, lmz, lun, m, mait + integer :: i, itmp, k, lun integer :: lnumait, lso4ait, lnh4ait integer :: l_h2so4, l_nh3 integer :: ldiagveh02 @@ -141,11 +151,11 @@ subroutine modal_aero_newnuc_sub( & 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) :: dndt(pcols,pver) ! nucleation rate (#/m3/s) + real(r8) :: dndt(ncol,pver) ! nucleation rate (#/m3/s) real(r8) :: dnh4dt_ait, dso4dt_ait real(r8) :: dpnuc real(r8) :: dplom_mode(1), dphim_mode(1) - real(r8) :: ev_sat(pcols,pver) + real(r8) :: ev_sat(ncol,pver) real(r8) :: mass1p real(r8) :: mass1p_aithi, mass1p_aitlo real(r8) :: pdel_fac @@ -153,27 +163,23 @@ subroutine modal_aero_newnuc_sub( & real(r8) :: qnh3_cur, qnh3_del, qnh4a_del real(r8) :: qnuma_del real(r8) :: qso4a_del - real(r8) :: qv_sat(pcols,pver) + real(r8) :: qv_sat(ncol,pver) real(r8) :: qvswtr real(r8) :: relhum, relhumav, relhumnn real(r8) :: tmpa, tmpb, tmpc real(r8) :: tmp_q1, tmp_q2, tmp_q3 real(r8) :: tmp_frso4, tmp_uptkrate - integer, parameter :: nsrflx = 1 ! last dimension of qsrflx - real(r8) :: qsrflx(pcols,pcnst,nsrflx) - ! process-specific column tracer tendencies - ! 1 = nucleation (for aerocom) - real(r8) :: dqdt(ncol,pver,pcnstxx) ! TMR tendency array -- NOTE dims - logical :: dotend(pcnst) ! flag for doing tendency logical :: do_nh3 ! flag for doing nh3/nh4 character(len=1) :: tmpch1, tmpch2, tmpch3 - character(len=fieldname_len+3) :: fieldname ! begin + errmsg = ' ' + errflg = 0 + lun = 6 !-------------------------------------------------------------------------------- @@ -192,6 +198,13 @@ subroutine modal_aero_newnuc_sub( & !-------------------------------------------------------------------------------- !----------------------------------------------------------------------- +! zero the tendency outputs up front: they are intent(out) and the caller +! applies/outputs them unconditionally, including on the bypass path below + dotend(:) = .false. + dqdt(1:ncol,:,:) = 0.0_r8 + qsrflx(1:ncol,:,:) = 0.0_r8 + dndt(1:ncol,:) = 0.0_r8 + l_h2so4 = l_h2so4_sv - loffset l_nh3 = l_nh3_sv - loffset lnumait = lnumait_sv - loffset @@ -201,20 +214,13 @@ subroutine modal_aero_newnuc_sub( & ! skip if no aitken mode OR if no h2so4 species if ((l_h2so4 <= 0) .or. (lso4ait <= 0) .or. (lnumait <= 0)) return - dotend(:) = .false. - dqdt(1:ncol,:,:) = 0.0_r8 - qsrflx(1:ncol,:,:) = 0.0_r8 - dndt(1:ncol,:) = 0.0_r8 - ! set dotend - mait = modeptr_aitken dotend(lnumait) = .true. dotend(lso4ait) = .true. dotend(l_h2so4) = .true. - lnh4ait = lptr_nh4_a_amode(mait) - loffset - if ((l_nh3 > 0) .and. (l_nh3 <= pcnst) .and. & - (lnh4ait > 0) .and. (lnh4ait <= pcnst)) then + if ((l_nh3 > 0) .and. (l_nh3 <= num_q) .and. & + (lnh4ait > 0) .and. (lnh4ait <= num_q)) then do_nh3 = .true. dotend(lnh4ait) = .true. dotend(l_nh3) = .true. @@ -224,9 +230,9 @@ subroutine modal_aero_newnuc_sub( & ! dry-diameter limits for "grown" new particles - dplom_mode(1) = exp( 0.67_r8*log(dgnumlo_amode(mait)) & - + 0.33_r8*log(dgnum_amode(mait)) ) - dphim_mode(1) = dgnumhi_amode(mait) + dplom_mode(1) = exp( 0.67_r8*log(dgnumlo_aitken) & + + 0.33_r8*log(dgnum_aitken) ) + dphim_mode(1) = dgnumhi_aitken ! mass1p_... = mass (kg) of so4 & nh4 in a single particle of diameter ... ! (assuming same dry density for so4 & nh4) @@ -443,30 +449,26 @@ subroutine modal_aero_newnuc_sub( & dso4dt_ait = dmdt_ait*tmp_frso4/mw_so4a_host dnh4dt_ait = dmdt_ait*(1.0_r8 - tmp_frso4)/mw_nh4a_host +! dqdt tendencies are returned to the caller, which applies q = q + dqdt*deltat dqdt(i,k,l_h2so4) = -dso4dt_ait*(1.0_r8-cldx) qsrflx(i,l_h2so4,1) = qsrflx(i,l_h2so4,1) + dqdt(i,k,l_h2so4)*pdel_fac - q(i,k,l_h2so4) = q(i,k,l_h2so4) + dqdt(i,k,l_h2so4)*deltat dqdt(i,k,lso4ait) = dso4dt_ait*(1.0_r8-cldx) qsrflx(i,lso4ait,1) = qsrflx(i,lso4ait,1) + dqdt(i,k,lso4ait)*pdel_fac - q(i,k,lso4ait) = q(i,k,lso4ait) + dqdt(i,k,lso4ait)*deltat if (lnumait > 0) then dqdt(i,k,lnumait) = dndt_ait*(1.0_r8-cldx) ! dndt is (#/m3/s), dqdt(:,:,lnumait) is (#/kmol-air/s), aircon is (mol-air/m3) dndt(i,k) = dqdt(i,k,lnumait)*aircon*1.0e-3_r8 qsrflx(i,lnumait,1) = qsrflx(i,lnumait,1) & + dqdt(i,k,lnumait)*pdel_fac - q(i,k,lnumait) = q(i,k,lnumait) + dqdt(i,k,lnumait)*deltat end if if (( do_nh3 ) .and. (dnh4dt_ait > 0.0_r8)) then dqdt(i,k,l_nh3) = -dnh4dt_ait*(1.0_r8-cldx) qsrflx(i,l_nh3,1) = qsrflx(i,l_nh3,1) + dqdt(i,k,l_nh3)*pdel_fac - q(i,k,l_nh3) = q(i,k,l_nh3) + dqdt(i,k,l_nh3)*deltat dqdt(i,k,lnh4ait) = dnh4dt_ait*(1.0_r8-cldx) qsrflx(i,lnh4ait,1) = qsrflx(i,lnh4ait,1) + dqdt(i,k,lnh4ait)*pdel_fac - q(i,k,lnh4ait) = q(i,k,lnh4ait) + dqdt(i,k,lnh4ait)*deltat end if !! temporary diagnostic @@ -540,26 +542,13 @@ subroutine modal_aero_newnuc_sub( & end do main_k -! do history file column-tendency fields - do l = loffset+1, pcnst - lmz = l - loffset - if ( .not. dotend(lmz) ) cycle - - do i = 1, ncol - qsrflx(i,lmz,1) = qsrflx(i,lmz,1)*(adv_mass(lmz)/mwdry) - end do - fieldname = trim(cnst_name(l)) // '_sfnnuc1' - call outfld( fieldname, qsrflx(:,lmz,1), pcols, lchnk ) - -! if (( masterproc ) .and. (nstep < 1)) & -! write(lun,'(2(a,2x),1p,e11.3)') & -! 'modal_aero_newnuc_sub outfld', fieldname, adv_mass(lmz) - end do ! l = ... +! history file column-tendency fields (adv_mass/mwdry scaling + outfld of +! qsrflx) are done by the caller, which owns the host constituent metadata return !EOC - end subroutine modal_aero_newnuc_sub + end subroutine modal_aero_newnuc_run @@ -574,10 +563,8 @@ subroutine mer07_veh02_nuc_mosaic_1box( & isize_nuc, qnuma_del, qso4a_del, qnh4a_del, & qh2so4_del, qnh3_del, dens_nh4so4a, ldiagaa ) ! qh2so4_del, qnh3_del, dens_nh4so4a ) - 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 - mw_nh4a => mwnh4 ! Molecular weight of ammonium +! (rgas, avogad, mw_so4a, mw_nh4a are module-level host constants +! set by modal_aero_newnuc_init) !....................................................................... ! ! calculates new particle production from homogeneous nucleation @@ -1412,154 +1399,72 @@ end subroutine binary_nuc_vehk2002 !---------------------------------------------------------------------- !---------------------------------------------------------------------- -subroutine modal_aero_newnuc_init +subroutine modal_aero_newnuc_init( l_h2so4_in, l_nh3_in, & + lnumait_in, lnh4ait_in, lso4ait_in, & + mw_so4a_host_in, mw_nh4a_host_in, dens_so4a_host_in, & + dgnum_aitken_in, dgnumhi_aitken_in, dgnumlo_aitken_in, & + pi_in, rgas_in, avogad_in, mw_so4a_in, mw_nh4a_in, & + r_universal_in, errmsg, errflg ) !----------------------------------------------------------------------- ! ! Purpose: -! set do_adjust and do_aitken flags -! create history fields for column tendencies associated with -! modal_aero_calcsize -! -! Author: R. Easter +! store the resolved species indices, aitken-mode so4/nh4 properties, +! and host physical constants used by modal_aero_newnuc_run +! index resolution and history-field registration are host +! responsibilities (see modal_aero_newnuc_cam) ! !----------------------------------------------------------------------- -use modal_aero_data -use modal_aero_rename - -use cam_abortutils, only: endrun -use cam_history, only: addfld, add_default, fieldname_len, horiz_only -use constituents, only: pcnst, cnst_get_ind, cnst_name -use spmd_utils, only: masterproc -use phys_control, only: phys_getopts - - implicit none !----------------------------------------------------------------------- ! arguments - -!----------------------------------------------------------------------- -! local - integer :: l_h2so4, l_nh3 - integer :: lnumait, lnh4ait, lso4ait - integer :: l, l1, l2 - integer :: m, mait - - character(len=fieldname_len) :: tmpname - character(len=fieldname_len+3) :: fieldname - character(128) :: long_name - character(8) :: unit - - logical :: dotend(pcnst) - logical :: history_aerosol ! Output the MAM aerosol tendencies - - !----------------------------------------------------------------------- - - call phys_getopts( history_aerosol_out = history_aerosol ) - - -! set these indices -! skip if no h2so4 species -! skip if no aitken mode so4 or num species - l_h2so4_sv = 0 - l_nh3_sv = 0 - lnumait_sv = 0 - lnh4ait_sv = 0 - lso4ait_sv = 0 - - call cnst_get_ind( 'H2SO4', l_h2so4, .false. ) - call cnst_get_ind( 'NH3', l_nh3, .false. ) - - mait = modeptr_aitken - if (mait > 0) then - lnumait = numptr_amode(mait) - lso4ait = lptr_so4_a_amode(mait) - lnh4ait = lptr_nh4_a_amode(mait) - end if - if ((l_h2so4 <= 0) .or. (l_h2so4 > pcnst)) then - write(*,'(/a/)') & - '*** modal_aero_newnuc bypass -- l_h2so4 <= 0' - return - else if ((lso4ait <= 0) .or. (lso4ait > pcnst)) then - write(*,'(/a/)') & - '*** modal_aero_newnuc bypass -- lso4ait <= 0' - return - else if ((lnumait <= 0) .or. (lnumait > pcnst)) then - write(*,'(/a/)') & - '*** modal_aero_newnuc bypass -- lnumait <= 0' - return - else if ((mait <= 0) .or. (mait > ntot_amode)) then - write(*,'(/a/)') & - '*** modal_aero_newnuc bypass -- modeptr_aitken <= 0' - return - end if - - l_h2so4_sv = l_h2so4 - l_nh3_sv = l_nh3 - lnumait_sv = lnumait - lnh4ait_sv = lnh4ait - lso4ait_sv = lso4ait - -! set these constants -! mw_so4a_host is molec-wght of sulfate aerosol in host code -! 96 when nh3/nh4 are simulated -! something else when nh3/nh4 are not simulated - l = lptr_so4_a_amode(mait) ; l2 = -1 - if (l <= 0) call endrun( 'modal_aero_newnuch_init error a001 finding aitken so4' ) - do l1 = 1, nspec_amode(mait) - if (lmassptr_amode(l1,mait) == l) then - l2 = l1 - mw_so4a_host = specmw_amode(l1,mait) - dens_so4a_host = specdens_amode(l1,mait) - end if - end do - if (l2 <= 0) call endrun( 'modal_aero_newnuch_init error a002 finding aitken so4' ) - - l = lptr_nh4_a_amode(mait) ; l2 = -1 - if (l > 0) then - do l1 = 1, nspec_amode(mait) - if (lmassptr_amode(l1,mait) == l) then - l2 = l1 - mw_nh4a_host = specmw_amode(l1,mait) - end if - end do - if (l2 <= 0) call endrun( 'modal_aero_newnuch_init error a002 finding aitken nh4' ) - else - mw_nh4a_host = mw_so4a_host - end if - -! -! create history file column-tendency fields -! - dotend(:) = .false. - dotend(lnumait) = .true. - dotend(lso4ait) = .true. - dotend(l_h2so4) = .true. - if ((l_nh3 > 0) .and. (l_nh3 <= pcnst) .and. & - (lnh4ait > 0) .and. (lnh4ait <= pcnst)) then - dotend(lnh4ait) = .true. - dotend(l_nh3) = .true. - end if - - do l = 1, pcnst - if ( .not. dotend(l) ) cycle - tmpname = cnst_name(l) - unit = 'kg/m2/s' - do m = 1, ntot_amode - if (l == numptr_amode(m)) unit = '#/m2/s' - end do - fieldname = trim(tmpname) // '_sfnnuc1' - long_name = trim(tmpname) // ' modal_aero new particle nucleation column tendency' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,2x))') & - 'modal_aero_newnuc_init addfld', fieldname, unit - end do ! l = ... - + integer, intent(in) :: l_h2so4_in ! h2so4 gas index (host constituent space) + integer, intent(in) :: l_nh3_in ! nh3 gas index (host constituent space) + integer, intent(in) :: lnumait_in ! aitken number index (host constituent space) + integer, intent(in) :: lnh4ait_in ! aitken nh4 index (host constituent space) + integer, intent(in) :: lso4ait_in ! aitken so4 index (host constituent space) + real(r8), intent(in) :: mw_so4a_host_in ! mw of so4 aerosol in host code (g/mol) + real(r8), intent(in) :: mw_nh4a_host_in ! mw of nh4 aerosol in host code (g/mol) + real(r8), intent(in) :: dens_so4a_host_in ! dry density of so4 aerosol in host code (kg/m3) + real(r8), intent(in) :: dgnum_aitken_in ! aitken mode nominal dry diameter (m) + real(r8), intent(in) :: dgnumhi_aitken_in ! aitken mode upper dry-diameter limit (m) + real(r8), intent(in) :: dgnumlo_aitken_in ! aitken mode lower dry-diameter limit (m) + real(r8), intent(in) :: pi_in + real(r8), intent(in) :: rgas_in ! gas constant (J/K/mol) + real(r8), intent(in) :: avogad_in ! Avogadro's number (1/mol) + real(r8), intent(in) :: mw_so4a_in ! molecular weight of sulfate (g/mol) + real(r8), intent(in) :: mw_nh4a_in ! molecular weight of ammonium (g/mol) + real(r8), intent(in) :: r_universal_in ! universal gas constant (J/K/kmol) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + !----------------------------------------------------------------------- + + errmsg = ' ' + errflg = 0 + + l_h2so4_sv = l_h2so4_in + l_nh3_sv = l_nh3_in + lnumait_sv = lnumait_in + lnh4ait_sv = lnh4ait_in + lso4ait_sv = lso4ait_in + + mw_so4a_host = mw_so4a_host_in + mw_nh4a_host = mw_nh4a_host_in + dens_so4a_host = dens_so4a_host_in + + dgnum_aitken = dgnum_aitken_in + dgnumhi_aitken = dgnumhi_aitken_in + dgnumlo_aitken = dgnumlo_aitken_in + + pi = pi_in + rgas = rgas_in + avogad = avogad_in + mw_so4a = mw_so4a_in + mw_nh4a = mw_nh4a_in + r_universal = r_universal_in return end subroutine modal_aero_newnuc_init diff --git a/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 b/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 new file mode 100644 index 0000000000..ba8ea08964 --- /dev/null +++ b/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 @@ -0,0 +1,200 @@ +! CAM wrapper for modal_aero_newnuc. +! Resolves CAM-specific species indices and aitken-mode so4/nh4 properties, +! hands them (with the host physical constants) to the portable +! modal_aero_newnuc_init, and registers history fields. +!---------------------------------------------------------------------- +module modal_aero_newnuc_cam + +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + private + +! !PUBLIC MEMBER FUNCTIONS: + public :: modal_aero_newnuc_cam_init + +!---------------------------------------------------------------------- +contains + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +subroutine modal_aero_newnuc_cam_init + +!----------------------------------------------------------------------- +! +! Purpose: +! resolve the species indices and aitken-mode so4/nh4 properties +! needed by modal_aero_newnuc and hand them to the portable +! modal_aero_newnuc_init +! create history fields for column tendencies associated with +! modal_aero_newnuc +! +! Author: R. Easter +! +!----------------------------------------------------------------------- + +use modal_aero_data +use modal_aero_newnuc, only: modal_aero_newnuc_init + +use cam_abortutils, only: endrun +use cam_history, only: addfld, add_default, fieldname_len, horiz_only +use constituents, only: pcnst, cnst_get_ind, cnst_name +use mo_constants, only: pi, rgas, avogadro +use physconst, only: mwso4, mwnh4, r_universal +use spmd_utils, only: masterproc +use phys_control, only: phys_getopts + + +implicit none + +!----------------------------------------------------------------------- +! arguments + +!----------------------------------------------------------------------- +! local + integer :: l_h2so4, l_nh3 + integer :: lnumait, lnh4ait, lso4ait + integer :: l, l1, l2 + integer :: m, mait + + real(r8) :: mw_so4a_host, mw_nh4a_host + real(r8) :: dens_so4a_host + + character(len=fieldname_len) :: tmpname + character(len=fieldname_len+3) :: fieldname + character(128) :: long_name + character(8) :: unit + + logical :: dotend(pcnst) + logical :: history_aerosol ! Output the MAM aerosol tendencies + + character(len=512) :: errmsg + integer :: errflg + + !----------------------------------------------------------------------- + + call phys_getopts( history_aerosol_out = history_aerosol ) + + +! set these indices +! skip if no h2so4 species (the portable module keeps its bypass +! defaults when modal_aero_newnuc_init is not called) +! skip if no aitken mode so4 or num species + call cnst_get_ind( 'H2SO4', l_h2so4, .false. ) + call cnst_get_ind( 'NH3', l_nh3, .false. ) + + mait = modeptr_aitken + if (mait > 0) then + lnumait = numptr_amode(mait) + lso4ait = lptr_so4_a_amode(mait) + lnh4ait = lptr_nh4_a_amode(mait) + end if + if ((l_h2so4 <= 0) .or. (l_h2so4 > pcnst)) then + write(*,'(/a/)') & + '*** modal_aero_newnuc bypass -- l_h2so4 <= 0' + return + else if ((lso4ait <= 0) .or. (lso4ait > pcnst)) then + write(*,'(/a/)') & + '*** modal_aero_newnuc bypass -- lso4ait <= 0' + return + else if ((lnumait <= 0) .or. (lnumait > pcnst)) then + write(*,'(/a/)') & + '*** modal_aero_newnuc bypass -- lnumait <= 0' + return + else if ((mait <= 0) .or. (mait > ntot_amode)) then + write(*,'(/a/)') & + '*** modal_aero_newnuc bypass -- modeptr_aitken <= 0' + return + end if + +! set these constants +! mw_so4a_host is molec-wght of sulfate aerosol in host code +! 96 when nh3/nh4 are simulated +! something else when nh3/nh4 are not simulated + l = lptr_so4_a_amode(mait) ; l2 = -1 + if (l <= 0) call endrun( 'modal_aero_newnuch_init error a001 finding aitken so4' ) + do l1 = 1, nspec_amode(mait) + if (lmassptr_amode(l1,mait) == l) then + l2 = l1 + mw_so4a_host = specmw_amode(l1,mait) + dens_so4a_host = specdens_amode(l1,mait) + end if + end do + if (l2 <= 0) call endrun( 'modal_aero_newnuch_init error a002 finding aitken so4' ) + + l = lptr_nh4_a_amode(mait) ; l2 = -1 + if (l > 0) then + do l1 = 1, nspec_amode(mait) + if (lmassptr_amode(l1,mait) == l) then + l2 = l1 + mw_nh4a_host = specmw_amode(l1,mait) + end if + end do + if (l2 <= 0) call endrun( 'modal_aero_newnuch_init error a002 finding aitken nh4' ) + else + mw_nh4a_host = mw_so4a_host + end if + +! hand the resolved indices, aitken-mode properties, and host physical +! constants to the portable scheme + call modal_aero_newnuc_init( & + l_h2so4_in = l_h2so4, & + l_nh3_in = l_nh3, & + lnumait_in = lnumait, & + lnh4ait_in = lnh4ait, & + lso4ait_in = lso4ait, & + mw_so4a_host_in = mw_so4a_host, & + mw_nh4a_host_in = mw_nh4a_host, & + dens_so4a_host_in = dens_so4a_host, & + dgnum_aitken_in = dgnum_amode(mait), & + dgnumhi_aitken_in = dgnumhi_amode(mait), & + dgnumlo_aitken_in = dgnumlo_amode(mait), & + pi_in = pi, & + rgas_in = rgas, & + avogad_in = avogadro, & + mw_so4a_in = mwso4, & + mw_nh4a_in = mwnh4, & + r_universal_in = r_universal, & + errmsg = errmsg, & + errflg = errflg ) + + if (errflg /= 0) then + call endrun('modal_aero_newnuc_cam_init: '//trim(errmsg)) + end if + +! +! create history file column-tendency fields +! + dotend(:) = .false. + dotend(lnumait) = .true. + dotend(lso4ait) = .true. + dotend(l_h2so4) = .true. + if ((l_nh3 > 0) .and. (l_nh3 <= pcnst) .and. & + (lnh4ait > 0) .and. (lnh4ait <= pcnst)) then + dotend(lnh4ait) = .true. + dotend(l_nh3) = .true. + end if + + do l = 1, pcnst + if ( .not. dotend(l) ) cycle + tmpname = cnst_name(l) + unit = 'kg/m2/s' + do m = 1, ntot_amode + if (l == numptr_amode(m)) unit = '#/m2/s' + end do + fieldname = trim(tmpname) // '_sfnnuc1' + long_name = trim(tmpname) // ' modal_aero new particle nucleation column tendency' + call addfld( fieldname, horiz_only, 'A', unit, long_name ) + if ( history_aerosol ) then + call add_default( fieldname, 1, ' ' ) + endif + if ( masterproc ) write(*,'(3(a,2x))') & + 'modal_aero_newnuc_init addfld', fieldname, unit + end do ! l = ... + + + return + end subroutine modal_aero_newnuc_cam_init + + end module modal_aero_newnuc_cam diff --git a/src/chemistry/modal_aero/modal_aero_rename.F90 b/src/chemistry/modal_aero/modal_aero_rename.F90 index 4482cf6def..2517eeef73 100644 --- a/src/chemistry/modal_aero/modal_aero_rename.F90 +++ b/src/chemistry/modal_aero/modal_aero_rename.F90 @@ -1,73 +1,24 @@ -! modal_aero_rename.F90 -!---------------------------------------------------------------------- -!BOP -! -! !MODULE: modal_aero_rename --- modal aerosol mode merging (renaming) -! -! !INTERFACE: - module modal_aero_rename - -! !USES: +! Portable code for modal aerosol mode merging (renaming) +module modal_aero_rename use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use mo_constants, only: pi - use chem_mods, only: gas_pcnst - use ppgrid, only: pcols, pver - use constituents, only: pcnst, cnst_name - use spmd_utils, only: masterproc - use modal_aero_data, only: maxspec_renamexf=>nspec_max, ntot_amode - use modal_aero_data, only: alnsg_amode, voltonumblo_amode, voltonumbhi_amode, dgnum_amode, nspec_amode - use modal_aero_data, only: specmw_amode, specdens_amode, lmassptr_amode, lmassptrcw_amode - use modal_aero_data, only: numptr_amode, numptrcw_amode, modeptr_coarse, modeptr_accum - use modal_aero_data, only: modeptr_stracoar - use modal_aero_data, only: specmw_amode, specdens_amode, lmassptr_amode, lmassptrcw_amode, numptr_amode, numptrcw_amode - use modal_aero_data, only: dgnumhi_amode, dgnumlo_amode, cnst_name_cw, modeptr_aitken - use radiative_aerosol,only: rad_aer_get_mode_idx implicit none private save -! !PUBLIC MEMBER FUNCTIONS: - public modal_aero_rename_sub, modal_aero_rename_init - -! !PUBLIC DATA MEMBERS: - integer, parameter :: pcnstxx = gas_pcnst + public :: modal_aero_rename_init + public :: modal_aero_rename_run integer, parameter, public :: maxpair_renamexf = 3 - - integer, protected, public :: ipair_select_renamexf(maxpair_renamexf) -! ipair_select_renamexf defines the mode_from and mode_too for each renaming pair -! 2001 = aitken --> accum -! 1003 = accum --> coarse -! 3001 = coarse --> accum -! 1005 = accum --> stracoar -! 5001 = stracoar --> accum - integer, parameter, public :: method_optbb_renamexf = 2 - integer, public :: npair_renamexf = -123456789 - integer, protected, public :: modefrm_renamexf(maxpair_renamexf) - integer, protected, public :: modetoo_renamexf(maxpair_renamexf) - integer, protected, public :: nspecfrm_renamexf(maxpair_renamexf) - - integer, allocatable, protected, public :: lspecfrma_renamexf(:,:) - integer, allocatable, protected, public :: lspecfrmc_renamexf(:,:) - integer, allocatable, protected, public :: lspectooa_renamexf(:,:) - integer, allocatable, protected, public :: lspectooc_renamexf(:,:) - - integer, protected, public :: igrow_shrink_renamexf(maxpair_renamexf) - integer, protected, public :: ixferable_all_renamexf(maxpair_renamexf) - integer, protected, public :: ixferable_all_needed_renamexf(maxpair_renamexf) - integer, allocatable, protected, public :: ixferable_a_renamexf(:,:) - integer, allocatable, protected, public :: ixferable_c_renamexf(:,:) + ! rename's OWN precomputed physics coefficients (accum-coarse-exchange path) are + ! set by modal_aero_rename_init and read by modal_aero_rename_run. - logical, public :: strat_only_renamexf(maxpair_renamexf) -! strat_only_renamexf - when true for a particular renaming pair, renaming is only -! done in stratosphere (when k < troplev(icol) ) + integer :: iulog + character(len=32), allocatable :: cnst_name(:), cnst_name_cw(:) -! !PRIVATE DATA MEMBERS: + ! precomputed physics coefficients (accum-coarse-exchange path) integer, allocatable :: ido_mode_calcaa(:) real (r8) :: dp_belowcut(maxpair_renamexf) real (r8) :: dp_cut(maxpair_renamexf) @@ -79,74 +30,208 @@ module modal_aero_rename real (r8) :: lndp_cut(maxpair_renamexf) real (r8) :: factor_3alnsg2(maxpair_renamexf) real (r8), allocatable :: v2nhirlx(:), v2nlorlx(:) +contains - logical :: modal_accum_coarse_exch = .false. + !------------------------------------------------------------------ + ! Precompute rename's own accum-coarse-exchange physics coefficients from the + ! host-provided mode metadata + resolved pair tables (passed as arguments), + ! and store cnst_name/iulog for diagnostics. The shared tables/metadata are + ! NOT retained; modal_aero_rename_run receives them as arguments each call. + !------------------------------------------------------------------ + subroutine modal_aero_rename_init( & + modal_accum_coarse_exch, & + ntot_amode, & + alnsg_amode, dgnum_amode, & + dgnumhi_amode, dgnumlo_amode, & + voltonumblo_amode, voltonumbhi_amode, & + modeptr_accum, modeptr_coarse, modeptr_stracoar, & + npair_renamexf, modefrm_renamexf, modetoo_renamexf, & + nspecfrm_renamexf, & + lspecfrma_renamexf, lspecfrmc_renamexf, & + lspectooa_renamexf, lspectooc_renamexf, & + igrow_shrink_renamexf, ixferable_all_renamexf, & + cnst_name_in, cnst_name_cw_in, & + pi, amRoot, iulog_in, & + errmsg, errflg ) + + ! arguments + logical, intent(in) :: modal_accum_coarse_exch + integer, intent(in) :: ntot_amode + real(r8), intent(in) :: alnsg_amode(:) + real(r8), intent(in) :: dgnum_amode(:) + real(r8), intent(in) :: dgnumhi_amode(:) + real(r8), intent(in) :: dgnumlo_amode(:) + real(r8), intent(in) :: voltonumblo_amode(:) + real(r8), intent(in) :: voltonumbhi_amode(:) + integer, intent(in) :: modeptr_accum + integer, intent(in) :: modeptr_coarse + integer, intent(in) :: modeptr_stracoar + integer, intent(in) :: npair_renamexf + integer, intent(in) :: modefrm_renamexf(:) + integer, intent(in) :: modetoo_renamexf(:) + integer, intent(in) :: nspecfrm_renamexf(:) + integer, intent(in) :: lspecfrma_renamexf(:,:) + integer, intent(in) :: lspecfrmc_renamexf(:,:) + integer, intent(in) :: lspectooa_renamexf(:,:) + integer, intent(in) :: lspectooc_renamexf(:,:) + integer, intent(in) :: igrow_shrink_renamexf(:) + integer, intent(in) :: ixferable_all_renamexf(:) + character(len=*), intent(in) :: cnst_name_in(:) + character(len=*), intent(in) :: cnst_name_cw_in(:) + real(r8), intent(in) :: pi + logical, intent(in) :: amRoot + integer, intent(in) :: iulog_in + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local (used by the precompute + one-time log below) + integer :: ipair, iq, lsfrma, lsfrmc, lstooa, lstooc, lunout + integer :: mfrm, mtoo + real(r8) :: frelax + logical :: masterproc + + errmsg = '' + errflg = 0 + + iulog = iulog_in + ! stored only for the (disabled) per-column diagnostic + one-time log + allocate(cnst_name(size(cnst_name_in))); cnst_name(:) = cnst_name_in(:) + allocate(cnst_name_cw(size(cnst_name_cw_in))); cnst_name_cw(:) = cnst_name_cw_in(:) + + allocate(ido_mode_calcaa(ntot_amode)) + allocate(dryvol_smallest(ntot_amode)) + allocate(factoraa(ntot_amode)) + allocate(factoryy(ntot_amode)) + allocate(v2nhirlx(ntot_amode), v2nlorlx(ntot_amode)) + + ! nothing to precompute unless there are renaming pairs + if (npair_renamexf .le. 0) return + + lunout = iulog + masterproc = amRoot + + if (modal_accum_coarse_exch) then -! !DESCRIPTION: This module implements ... ! -! !REVISION HISTORY: ! -! RCE 07.04.13: Adapted from MIRAGE2 code +! initialize some working variables ! -!EOP -!---------------------------------------------------------------------- -!BOC - -! list private module data here - -!EOC -!---------------------------------------------------------------------- -contains +! + ido_mode_calcaa(:) = 0 + frelax = 27.0_r8 - !------------------------------------------------------------------ - !------------------------------------------------------------------ - subroutine modal_aero_rename_init(modal_accum_coarse_exch_in) - logical, optional, intent(in) :: modal_accum_coarse_exch_in - - ! ipair_select_renamexf defines the mode_from and mode_too for each renaming pair - ! 2001 = aitken --> accum - ! 1003 = accum --> coarse - ! 3001 = coarse --> accum - ! 1005 = accum --> stracoar - ! 5001 = stracoar --> accum - if( rad_aer_get_mode_idx(0,'coarse_strat') > 0 ) then - ipair_select_renamexf(1:maxpair_renamexf) = (/ 2001, 1005, 5001 /) - else - ipair_select_renamexf(1:maxpair_renamexf) = (/ 2001, 1003, 3001 /) - endif + do ipair = 1, npair_renamexf + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(ipair) + ido_mode_calcaa(mfrm) = 1 - allocate( lspecfrma_renamexf(maxspec_renamexf,maxpair_renamexf) ) - allocate( lspecfrmc_renamexf(maxspec_renamexf,maxpair_renamexf) ) - allocate( lspectooa_renamexf(maxspec_renamexf,maxpair_renamexf) ) - allocate( lspectooc_renamexf(maxspec_renamexf,maxpair_renamexf) ) + factoraa(mfrm) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mfrm)**2)) + factoraa(mtoo) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mtoo)**2)) + factoryy(mfrm) = sqrt( 0.5_r8 )/alnsg_amode(mfrm) - allocate( ixferable_a_renamexf(maxspec_renamexf,maxpair_renamexf) ) - allocate( ixferable_c_renamexf(maxspec_renamexf,maxpair_renamexf) ) - allocate( ido_mode_calcaa(ntot_amode) ) +! 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_r8 + v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax + v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax - allocate( dryvol_smallest(ntot_amode) ) - allocate( factoraa(ntot_amode) ) - allocate( factoryy(ntot_amode) ) + factor_3alnsg2(ipair) = 3.0_r8 * (alnsg_amode(mfrm)**2) - allocate( v2nhirlx(ntot_amode), v2nlorlx(ntot_amode) ) + dp_cut(ipair) = sqrt( & + dgnum_amode(mfrm)*exp(1.5_r8*(alnsg_amode(mfrm)**2)) * & + dgnum_amode(mtoo)*exp(1.5_r8*(alnsg_amode(mtoo)**2)) ) + dp_xferall_thresh(ipair) = dgnum_amode(mtoo) + dp_xfernone_threshaa(ipair) = dgnum_amode(mfrm) + if (((mfrm == modeptr_accum) .and. (mtoo == modeptr_coarse)).or.& + ((mfrm == modeptr_accum) .and. (mtoo == modeptr_stracoar))) then + dp_cut(ipair) = 4.4e-7_r8 + dp_xfernone_threshaa(ipair) = 1.6e-7_r8 + dp_xferall_thresh(ipair) = 4.7e-7_r8 + else if (((mfrm == modeptr_coarse) .and. (mtoo == modeptr_accum)).or.& + ((mfrm == modeptr_stracoar) .and. (mtoo == modeptr_accum))) then + dp_cut(ipair) = 4.4e-7_r8 + dp_xfernone_threshaa(ipair) = 4.4e-7_r8 + dp_xferall_thresh(ipair) = 4.1e-7_r8 + end if - if (present(modal_accum_coarse_exch_in)) then - modal_accum_coarse_exch = modal_accum_coarse_exch_in - endif + lndp_cut(ipair) = log( dp_cut(ipair) ) + dp_belowcut(ipair) = 0.99_r8*dp_cut(ipair) + end do - if (modal_accum_coarse_exch) then - call modal_aero_rename_acc_crs_init() - else - call modal_aero_rename_no_acc_crs_init() - endif +! +! output results +! + if ( masterproc ) then + + write(lunout,9310) + write(lunout,'(a,1x,i12)') 'method_optbb_renamexf', method_optbb_renamexf + + do 2900 ipair = 1, npair_renamexf + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(ipair) + write(lunout,9320) ipair, mfrm, mtoo, & + igrow_shrink_renamexf(ipair), ixferable_all_renamexf(ipair) + + do iq = 1, nspecfrm_renamexf(ipair) + lsfrma = lspecfrma_renamexf(iq,ipair) + lstooa = lspectooa_renamexf(iq,ipair) + lsfrmc = lspecfrmc_renamexf(iq,ipair) + lstooc = lspectooc_renamexf(iq,ipair) + if (lstooa .gt. 0) then + write(lunout,9330) lsfrma, cnst_name(lsfrma), & + lstooa, cnst_name(lstooa) + else + write(lunout,9340) lsfrma, cnst_name(lsfrma) + end if + if (lstooc .gt. 0) then + write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc), & + lstooc, cnst_name_cw(lstooc) + else if (lsfrmc .gt. 0) then + write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc) + else + write(lunout,9350) + end if + end do + + if (igrow_shrink_renamexf(ipair) > 0) then + write(lunout,'(5x,a,1p,2e12.3)') 'mfrm dgnum, dgnumhi ', & + dgnum_amode(mfrm), dgnumhi_amode(mfrm) + write(lunout,'(5x,a,1p,2e12.3)') 'mtoo dgnum, dgnumlo ', & + dgnum_amode(mtoo), dgnumlo_amode(mtoo) + else + write(lunout,'(5x,a,1p,2e12.3)') 'mfrm dgnum, dgnumlo ', & + dgnum_amode(mfrm), dgnumlo_amode(mfrm) + write(lunout,'(5x,a,1p,2e12.3)') 'mtoo dgnum, dgnumhi ', & + dgnum_amode(mtoo), dgnumhi_amode(mtoo) + end if + + write(lunout,'(5x,a,1p,2e12.3)') 'dp_cut ', & + dp_cut(ipair) + write(lunout,'(5x,a,1p,2e12.3)') 'dp_xfernone_threshaa', & + dp_xfernone_threshaa(ipair) + write(lunout,'(5x,a,1p,2e12.3)') 'dp_xferall_thresh ', & + dp_xferall_thresh(ipair) + +2900 continue + write(lunout,*) + + end if ! ( masterproc ) + end if + + return + +9310 format( / 'subr. modal_aero_rename_acc_crs_init' ) +9320 format( / 'pair', i3, 5x, 'mode', i3, ' ---> mode', i3, & + 5x, 'igrow_shrink', i3, 5x, 'ixferable_all', i3 ) +9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a ) +9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' ) +9350 format( 5x, 'no corresponding activated species' ) end subroutine modal_aero_rename_init - !------------------------------------------------------------------ - !------------------------------------------------------------------ - subroutine modal_aero_rename_sub( & - fromwhere, lchnk, & - ncol, nstep, & + subroutine modal_aero_rename_run( & + ncol, & loffset, deltat, & pdel, troplev, & dotendrn, q, & @@ -156,56 +241,90 @@ subroutine modal_aero_rename_sub( & is_dorename_atik, dorename_atik, & jsrflx_rename, nsrflx, & qsrflx, qqcwsrflx, & - dqdt_rnpos ) - - - ! !PARAMETERS: - character(len=*), intent(in) :: fromwhere ! identifies which module - ! is making the call - integer, intent(in) :: lchnk ! chunk identifier + dqdt_rnpos, & + ntot_amode, npair_renamexf, & + modefrm_renamexf, modetoo_renamexf, & + nspecfrm_renamexf, & + lspecfrma_renamexf, lspecfrmc_renamexf, & + lspectooa_renamexf, lspectooc_renamexf, & + alnsg_amode, voltonumblo_amode, & + voltonumbhi_amode, dgnum_amode, & + nspec_amode, specmw_amode, & + specdens_amode, lmassptr_amode, & + lmassptrcw_amode, numptr_amode, & + numptrcw_amode, pi, & + modeptr_accum, modeptr_coarse, & + modeptr_stracoar, & + igrow_shrink_renamexf, & + ixferable_all_renamexf, & + ixferable_a_renamexf, ixferable_c_renamexf, & + strat_only_renamexf, & + modal_accum_coarse_exch, & + pver, gravit, & + errmsg, errflg ) integer, intent(in) :: ncol ! number of atmospheric column - integer, intent(in) :: nstep ! model time-step number integer, intent(in) :: loffset ! offset applied to modal aero "ptrs" real(r8), intent(in) :: deltat ! time step (s) - integer, intent(in) :: troplev(pcols) - - real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: q(ncol,pver,pcnstxx) ! tracer mixing ratio array - ! *** MUST BE mol/mol-air or #/mol-air - ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(in) :: qqcw(ncol,pver,pcnstxx) ! like q but for cloud-borne species - - real(r8), intent(inout) :: dqdt(ncol,pver,pcnstxx) ! TMR tendency array; - ! incoming dqdt = tendencies for the - ! "fromwhere" continuous growth process - ! the renaming tendencies are added on - ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(inout) :: dqqcwdt(ncol,pver,pcnstxx) - real(r8), intent(in) :: dqdt_other(ncol,pver,pcnstxx) - ! tendencies for "other" continuous growth process - ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(in) :: dqqcwdt_other(ncol,pver,pcnstxx) - logical, intent(inout) :: dotendrn(pcnstxx) ! identifies the species for which - ! renaming dqdt is computed - logical, intent(inout) :: dotendqqcwrn(pcnstxx) - - logical, intent(in) :: is_dorename_atik ! true if dorename_atik is provided - logical, intent(in) :: dorename_atik(ncol,pver) ! true if renaming should - ! be done at i,k + integer, intent(in) :: troplev(:) + real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) + real(r8), intent(in) :: q(:,:,:) ! tracer mixing ratio array (mol/mol-air or #/mol-air) + real(r8), intent(in) :: qqcw(:,:,:) ! like q but for cloud-borne species + real(r8), intent(inout) :: dqdt(:,:,:) ! TMR tendency array (renaming tendencies added on) + real(r8), intent(inout) :: dqqcwdt(:,:,:) + real(r8), intent(in) :: dqdt_other(:,:,:) ! tendencies for "other" continuous growth process + real(r8), intent(in) :: dqqcwdt_other(:,:,:) + logical, intent(inout) :: dotendrn(:) ! species with renaming dqdt computed + logical, intent(inout) :: dotendqqcwrn(:) + logical, intent(in) :: is_dorename_atik ! true if dorename_atik is provided + logical, intent(in) :: dorename_atik(:,:) ! true if renaming should be done at i,k integer, intent(in) :: jsrflx_rename ! qsrflx index for renaming integer, intent(in) :: nsrflx ! last dimension of qsrflx - - real(r8), intent(inout) :: qsrflx(pcols,pcnstxx,nsrflx) - ! process-specific column tracer tendencies - real(r8), intent(inout) :: qqcwsrflx(pcols,pcnstxx,nsrflx) - real(r8), optional, intent(out) & - :: dqdt_rnpos(ncol,pver,pcnstxx) - ! the positive (production) part of the renaming tendency + real(r8), intent(out) :: qsrflx(:,:,:) ! process-specific column tracer tendencies + real(r8), intent(out) :: qqcwsrflx(:,:,:) + real(r8), intent(out) :: dqdt_rnpos(:,:,:) ! positive (production) part of renaming tendency + ! shared mode metadata + resolved renaming-pair tables (host-owned; passed in) + integer, intent(in) :: ntot_amode + integer, intent(in) :: npair_renamexf + integer, intent(in) :: modefrm_renamexf(:) + integer, intent(in) :: modetoo_renamexf(:) + integer, intent(in) :: nspecfrm_renamexf(:) + integer, intent(in) :: lspecfrma_renamexf(:,:) + integer, intent(in) :: lspecfrmc_renamexf(:,:) + integer, intent(in) :: lspectooa_renamexf(:,:) + integer, intent(in) :: lspectooc_renamexf(:,:) + real(r8), intent(in) :: alnsg_amode(:) + real(r8), intent(in) :: voltonumblo_amode(:) + real(r8), intent(in) :: voltonumbhi_amode(:) + real(r8), intent(in) :: dgnum_amode(:) + integer, intent(in) :: nspec_amode(:) + real(r8), intent(in) :: specmw_amode(:,:) + real(r8), intent(in) :: specdens_amode(:,:) + integer, intent(in) :: lmassptr_amode(:,:) + integer, intent(in) :: lmassptrcw_amode(:,:) + integer, intent(in) :: numptr_amode(:) + integer, intent(in) :: numptrcw_amode(:) + real(r8), intent(in) :: pi + ! accum-coarse-exchange path flags (host-owned; passed in) + integer, intent(in) :: modeptr_accum + integer, intent(in) :: modeptr_coarse + integer, intent(in) :: modeptr_stracoar + integer, intent(in) :: igrow_shrink_renamexf(:) + integer, intent(in) :: ixferable_all_renamexf(:) + integer, intent(in) :: ixferable_a_renamexf(:,:) + integer, intent(in) :: ixferable_c_renamexf(:,:) + logical, intent(in) :: strat_only_renamexf(:) + logical, intent(in) :: modal_accum_coarse_exch ! select accum-coarse exchange path + integer, intent(in) :: pver ! number of vertical levels + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + character(len=*), intent(out) :: errmsg ! error message + integer, intent(out) :: errflg ! error flag + + errmsg = '' + errflg = 0 if (modal_accum_coarse_exch) then call modal_aero_rename_acc_crs_sub( & - fromwhere, lchnk, & - ncol, nstep, & + ncol, & loffset, deltat, & pdel, troplev, & dotendrn, q, & @@ -215,11 +334,31 @@ subroutine modal_aero_rename_sub( & is_dorename_atik, dorename_atik, & jsrflx_rename, nsrflx, & qsrflx, qqcwsrflx, & - dqdt_rnpos ) + dqdt_rnpos, & + ntot_amode, npair_renamexf, & + modefrm_renamexf, modetoo_renamexf, & + nspecfrm_renamexf, & + lspecfrma_renamexf, lspecfrmc_renamexf, & + lspectooa_renamexf, lspectooc_renamexf, & + alnsg_amode, voltonumblo_amode, & + voltonumbhi_amode, dgnum_amode, & + nspec_amode, specmw_amode, & + specdens_amode, lmassptr_amode, & + lmassptrcw_amode, numptr_amode, & + numptrcw_amode, pi, & + modeptr_accum, modeptr_coarse, & + modeptr_stracoar, & + igrow_shrink_renamexf, & + ixferable_all_renamexf, & + ixferable_a_renamexf, ixferable_c_renamexf, & + strat_only_renamexf, & + pver, gravit, & + errmsg, errflg ) else + ! no_acc path does not produce dqdt_rnpos; define the required output here. + dqdt_rnpos(:,:,:) = 0.0_r8 call modal_aero_rename_no_acc_crs_sub( & - fromwhere, lchnk, & - ncol, nstep, & + ncol, & loffset, deltat, & pdel, & dotendrn, q, & @@ -228,21 +367,28 @@ subroutine modal_aero_rename_sub( & dqqcwdt, dqqcwdt_other, & is_dorename_atik, dorename_atik, & jsrflx_rename, nsrflx, & - qsrflx, qqcwsrflx ) - endif - end subroutine modal_aero_rename_sub - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! private methods -!---------------------------------------------------------------------- -!BOP -! !ROUTINE: modal_aero_rename_no_acc_crs_sub --- ... -! -! !INTERFACE: - subroutine modal_aero_rename_no_acc_crs_sub( & - fromwhere, lchnk, & - ncol, nstep, & + qsrflx, qqcwsrflx, & + ntot_amode, npair_renamexf, & + modefrm_renamexf, modetoo_renamexf, & + nspecfrm_renamexf, & + lspecfrma_renamexf, lspecfrmc_renamexf, & + lspectooa_renamexf, lspectooc_renamexf, & + alnsg_amode, voltonumblo_amode, & + voltonumbhi_amode, dgnum_amode, & + nspec_amode, specmw_amode, & + specdens_amode, lmassptr_amode, & + lmassptrcw_amode, numptr_amode, & + numptrcw_amode, pi, & + pver, gravit, & + errmsg, errflg ) + end if + end subroutine modal_aero_rename_run + + !---------------------------------------------------------------------- + ! private methods + + subroutine modal_aero_rename_no_acc_crs_sub( & + ncol, & loffset, deltat, & pdel, & dotendrn, q, & @@ -251,54 +397,82 @@ subroutine modal_aero_rename_no_acc_crs_sub( & dqqcwdt, dqqcwdt_other, & is_dorename_atik, dorename_atik, & jsrflx_rename, nsrflx, & - qsrflx, qqcwsrflx ) - -! !USES: - use physconst, only: gravit, mwdry + qsrflx, qqcwsrflx, & + ntot_amode, npair_renamexf, & + modefrm_renamexf, modetoo_renamexf, & + nspecfrm_renamexf, & + lspecfrma_renamexf, lspecfrmc_renamexf, & + lspectooa_renamexf, lspectooc_renamexf, & + alnsg_amode, voltonumblo_amode, & + voltonumbhi_amode, dgnum_amode, & + nspec_amode, specmw_amode, & + specdens_amode, lmassptr_amode, & + lmassptrcw_amode, numptr_amode, & + numptrcw_amode, pi, & + pver, gravit, & + errmsg, errflg ) use shr_spfn_mod, only: erfc => shr_spfn_erfc - implicit none - - -! !PARAMETERS: - character(len=*), intent(in) :: fromwhere ! identifies which module - ! is making the call - integer, intent(in) :: lchnk ! chunk identifier integer, intent(in) :: ncol ! number of atmospheric column - integer, intent(in) :: nstep ! model time-step number integer, intent(in) :: loffset ! offset applied to modal aero "ptrs" real(r8), intent(in) :: deltat ! time step (s) - real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: q(ncol,pver,pcnstxx) ! tracer mixing ratio array + real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) + real(r8), intent(in) :: q(:,:,:) ! tracer mixing ratio array ! *** MUST BE mol/mol-air or #/mol-air ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(in) :: qqcw(ncol,pver,pcnstxx) ! like q but for cloud-borne species + real(r8), intent(in) :: qqcw(:,:,:) ! like q but for cloud-borne species - real(r8), intent(inout) :: dqdt(ncol,pver,pcnstxx) ! TMR tendency array; + real(r8), intent(inout) :: dqdt(:,:,:) ! TMR tendency array; ! incoming dqdt = tendencies for the ! "fromwhere" continuous growth process ! the renaming tendencies are added on ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(inout) :: dqqcwdt(ncol,pver,pcnstxx) - real(r8), intent(in) :: dqdt_other(ncol,pver,pcnstxx) + real(r8), intent(inout) :: dqqcwdt(:,:,:) + real(r8), intent(in) :: dqdt_other(:,:,:) ! tendencies for "other" continuous growth process ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(in) :: dqqcwdt_other(ncol,pver,pcnstxx) - logical, intent(inout) :: dotendrn(pcnstxx) ! identifies the species for which + real(r8), intent(in) :: dqqcwdt_other(:,:,:) + logical, intent(inout) :: dotendrn(:) ! identifies the species for which ! renaming dqdt is computed - logical, intent(inout) :: dotendqqcwrn(pcnstxx) + logical, intent(inout) :: dotendqqcwrn(:) logical, intent(in) :: is_dorename_atik ! true if dorename_atik is provided - logical, intent(in) :: dorename_atik(ncol,pver) ! true if renaming should + logical, intent(in) :: dorename_atik(:,:) ! true if renaming should ! be done at i,k integer, intent(in) :: jsrflx_rename ! qsrflx index for renaming integer, intent(in) :: nsrflx ! last dimension of qsrflx - real(r8), intent(inout) :: qsrflx(pcols,pcnstxx,nsrflx) + real(r8), intent(out) :: qsrflx(:,:,:) ! process-specific column tracer tendencies - real(r8), intent(inout) :: qqcwsrflx(pcols,pcnstxx,nsrflx) - + real(r8), intent(out) :: qqcwsrflx(:,:,:) + + integer, intent(in) :: pver ! number of vertical levels + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + character(len=*), intent(out) :: errmsg ! error message + integer, intent(out) :: errflg ! error flag + ! shared mode metadata + resolved renaming-pair tables (host-owned; passed in) + integer, intent(in) :: ntot_amode ! number of aerosol modes + integer, intent(in) :: npair_renamexf ! number of renaming pairs + integer, intent(in) :: modefrm_renamexf(:) ! source mode index per pair + integer, intent(in) :: modetoo_renamexf(:) ! destination mode index per pair + integer, intent(in) :: nspecfrm_renamexf(:) ! number of transferred species per pair + integer, intent(in) :: lspecfrma_renamexf(:,:) ! interstitial source species (pcnst-space) + integer, intent(in) :: lspecfrmc_renamexf(:,:) ! cloud-borne source species + integer, intent(in) :: lspectooa_renamexf(:,:) ! interstitial destination species + integer, intent(in) :: lspectooc_renamexf(:,:) ! cloud-borne destination species + real(r8), intent(in) :: alnsg_amode(:) ! ln(geometric std dev) of each mode + real(r8), intent(in) :: voltonumblo_amode(:) ! volume-to-number ratio, low limit + real(r8), intent(in) :: voltonumbhi_amode(:) ! volume-to-number ratio, high limit + real(r8), intent(in) :: dgnum_amode(:) ! nominal geometric mean diameter + integer, intent(in) :: nspec_amode(:) ! number of species in each mode + real(r8), intent(in) :: specmw_amode(:,:) ! species molecular weight + real(r8), intent(in) :: specdens_amode(:,:) ! species density + integer, intent(in) :: lmassptr_amode(:,:) ! interstitial mass pointer (pcnst-space) + integer, intent(in) :: lmassptrcw_amode(:,:) ! cloud-borne mass pointer + integer, intent(in) :: numptr_amode(:) ! interstitial number pointer + integer, intent(in) :: numptrcw_amode(:) ! cloud-borne number pointer + real(r8), intent(in) :: pi ! pi ! !DESCRIPTION: ! computes TMR (tracer mixing ratio) tendencies for "mode renaming" ! during a continuous growth process @@ -354,94 +528,99 @@ subroutine modal_aero_rename_no_acc_crs_sub( & real (r8) :: yn_tail, yv_tail ! begin - lunout = iulog + lunout = iulog + errmsg = '' + errflg = 0 + ! intent(out): fully define before any early return + qsrflx(:,:,:) = 0.0_r8 + qqcwsrflx(:,:,:) = 0.0_r8 ! ! calculations done once on initial entry ! ! "init" is now done through chem_init (and things under it) -! if (npair_renamexf .eq. -123456789) then -! npair_renamexf = 0 -! call modal_aero_rename_init -! end if +! if (npair_renamexf .eq. -123456789) then +! npair_renamexf = 0 +! call modal_aero_rename_init +! end if ! ! check if any renaming pairs exist ! - if (npair_renamexf .le. 0) return -! if (ncol .ne. -123456789) return -! if (fromwhere .eq. 'aqchem') return + if (npair_renamexf .le. 0) return +! if (ncol .ne. -123456789) return +! if (fromwhere .eq. 'aqchem') return ! ! compute aerosol dry-volume for the "from mode" of each renaming pair ! also compute dry-volume change during the continuous growth process -! using the incoming dqdt*deltat -! - deltatinv = 1.0_r8/(deltat*(1.0_r8 + 1.0e-15_r8)) - onethird = 1.0_r8/3.0_r8 - frelax = 27.0_r8 - xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps - - do n = 1, ntot_amode - idomode(n) = 0 - end do - - do ipair = 1, npair_renamexf - if (ipair .gt. 1) goto 8100 - idomode(modefrm_renamexf(ipair)) = 1 - - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - factoraa(mfrm) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mfrm)**2)) - factoraa(mtoo) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mtoo)**2)) - factoryy(mfrm) = sqrt( 0.5_r8 )/alnsg_amode(mfrm) +! using the incoming dqdt*deltat +! + deltatinv = 1.0_r8/(deltat*(1.0_r8 + 1.0e-15_r8)) + onethird = 1.0_r8/3.0_r8 + frelax = 27.0_r8 + xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps + + do n = 1, ntot_amode + idomode(n) = 0 + end do + + do ipair = 1, npair_renamexf + if (ipair .gt. 1) goto 8100 + idomode(modefrm_renamexf(ipair)) = 1 + + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(ipair) + factoraa(mfrm) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mfrm)**2)) + factoraa(mtoo) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mtoo)**2)) + factoryy(mfrm) = sqrt( 0.5_r8 )/alnsg_amode(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_r8 - v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax - v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax - - dum3alnsg2(ipair) = 3.0_r8 * (alnsg_amode(mfrm)**2) - dp_cut(ipair) = sqrt( & - dgnum_amode(mfrm)*exp(1.5_r8*(alnsg_amode(mfrm)**2)) * & - dgnum_amode(mtoo)*exp(1.5_r8*(alnsg_amode(mtoo)**2)) ) - lndp_cut(ipair) = log( dp_cut(ipair) ) - dp_belowcut(ipair) = 0.99_r8*dp_cut(ipair) - end do - - do n = 1, ntot_amode - if (idomode(n) .gt. 0) then - dryvol_a(1:ncol,:,n) = 0.0_r8 - dryvol_c(1:ncol,:,n) = 0.0_r8 - deldryvol_a(1:ncol,:,n) = 0.0_r8 - deldryvol_c(1:ncol,:,n) = 0.0_r8 - do l1 = 1, nspec_amode(n) + dryvol_smallest(mfrm) = 1.0e-25_r8 + v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax + v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax + + dum3alnsg2(ipair) = 3.0_r8 * (alnsg_amode(mfrm)**2) + dp_cut(ipair) = sqrt( & + dgnum_amode(mfrm)*exp(1.5_r8*(alnsg_amode(mfrm)**2)) * & + dgnum_amode(mtoo)*exp(1.5_r8*(alnsg_amode(mtoo)**2)) ) + lndp_cut(ipair) = log( dp_cut(ipair) ) + dp_belowcut(ipair) = 0.99_r8*dp_cut(ipair) + end do + + do n = 1, ntot_amode + if (idomode(n) .gt. 0) then + dryvol_a(1:ncol,:,n) = 0.0_r8 + dryvol_c(1:ncol,:,n) = 0.0_r8 + deldryvol_a(1:ncol,:,n) = 0.0_r8 + deldryvol_c(1:ncol,:,n) = 0.0_r8 + do l1 = 1, nspec_amode(n) ! dum_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) ! [m3-AP/kmol-AP]= [kg-AP/kmol-AP] / [kg-AP/m3-AP] dum_m2v = specmw_amode(l1,n) / specdens_amode(l1,n) - dum_m2vdt = dum_m2v*deltat - la = lmassptr_amode(l1,n)-loffset - if (la > 0) then - dryvol_a(1:ncol,:,n) = dryvol_a(1:ncol,:,n) & - + dum_m2v*max( 0.0_r8, & + dum_m2vdt = dum_m2v*deltat + la = lmassptr_amode(l1,n)-loffset + if (la > 0) then + dryvol_a(1:ncol,:,n) = dryvol_a(1:ncol,:,n) & + + dum_m2v*max( 0.0_r8, & q(1:ncol,:,la)-deltat*dqdt_other(1:ncol,:,la) ) - deldryvol_a(1:ncol,:,n) = deldryvol_a(1:ncol,:,n) & - + (dqdt_other(1:ncol,:,la) + dqdt(1:ncol,:,la))*dum_m2vdt - end if - - lc = lmassptrcw_amode(l1,n)-loffset - if (lc > 0) then - dryvol_c(1:ncol,:,n) = dryvol_c(1:ncol,:,n) & - + dum_m2v*max( 0.0_r8, & + deldryvol_a(1:ncol,:,n) = deldryvol_a(1:ncol,:,n) & + + (dqdt_other(1:ncol,:,la) + dqdt(1:ncol,:,la))*dum_m2vdt + end if + + lc = lmassptrcw_amode(l1,n)-loffset + if (lc > 0) then + dryvol_c(1:ncol,:,n) = dryvol_c(1:ncol,:,n) & + + dum_m2v*max( 0.0_r8, & qqcw(1:ncol,:,lc)-deltat*dqqcwdt_other(1:ncol,:,lc) ) - deldryvol_c(1:ncol,:,n) = deldryvol_c(1:ncol,:,n) & - + (dqqcwdt_other(1:ncol,:,lc) + & - dqqcwdt(1:ncol,:,lc))*dum_m2vdt - end if - end do - end if - end do + deldryvol_c(1:ncol,:,n) = deldryvol_c(1:ncol,:,n) & + + (dqqcwdt_other(1:ncol,:,lc) + & + dqqcwdt(1:ncol,:,lc))*dum_m2vdt + end if + end do + end if + end do @@ -452,93 +631,93 @@ subroutine modal_aero_rename_no_acc_crs_sub( & mainloop1_i: do i = 1, ncol ! if dorename_atik is provided, then check if renaming needed at this i,k - if (is_dorename_atik) then - if (.not. dorename_atik(i,k)) cycle mainloop1_i - end if - pdel_fac = pdel(i,k)/gravit + if (is_dorename_atik) then + if (.not. dorename_atik(i,k)) cycle mainloop1_i + end if + pdel_fac = pdel(i,k)/gravit ! ! loop over renameing pairs ! mainloop1_ipair: do ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(ipair) ! dryvol_t_old is the old total (a+c) dry-volume for the "from" mode -! in m^3-AP/kmol-air +! in m^3-AP/kmol-air ! dryvol_t_new is the new total dry-volume -! (old/new = before/after the continuous growth) - dryvol_t_old = dryvol_a(i,k,mfrm) + dryvol_c(i,k,mfrm) - dryvol_t_del = deldryvol_a(i,k,mfrm) + deldryvol_c(i,k,mfrm) - dryvol_t_new = dryvol_t_old + dryvol_t_del - dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) ) +! (old/new = before/after the continuous growth) + dryvol_t_old = dryvol_a(i,k,mfrm) + dryvol_c(i,k,mfrm) + dryvol_t_del = deldryvol_a(i,k,mfrm) + deldryvol_c(i,k,mfrm) + dryvol_t_new = dryvol_t_old + dryvol_t_del + dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) ) ! no renaming if dryvol_t_new ~ 0 or dryvol_t_del ~ 0 - if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_ipair - if (dryvol_t_del .le. 1.0e-6_r8*dryvol_t_oldbnd) cycle mainloop1_ipair + if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_ipair + if (dryvol_t_del .le. 1.0e-6_r8*dryvol_t_oldbnd) cycle mainloop1_ipair ! num_t_old is total number in particles/kmol-air - num_t_old = q(i,k,numptr_amode(mfrm)-loffset) - num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset) - 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 ) + num_t_old = q(i,k,numptr_amode(mfrm)-loffset) + num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset) + 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_amode(mfrm)) cycle mainloop1_ipair + dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird + if (dgn_t_new .le. dgnum_amode(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 + dum3alnsg2(ipair) - yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm) - yv_tail = (lndp_cut(ipair) - lndgv_new)*factoryy(mfrm) - tailfr_numnew = 0.5_r8*erfc( yn_tail ) - tailfr_volnew = 0.5_r8*erfc( yv_tail ) + lndgn_new = log( dgn_t_new ) + lndgv_new = lndgn_new + dum3alnsg2(ipair) + yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm) + yv_tail = (lndp_cut(ipair) - 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_old = & + (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird ! if dgn_t_new exceeds dp_cut, use the minimum of dgn_t_old and ! dp_belowcut to guarantee some transfer - if (dgn_t_new .ge. dp_cut(ipair)) then - dgn_t_old = min( dgn_t_old, dp_belowcut(ipair) ) - end if - lndgn_old = log( dgn_t_old ) - lndgv_old = lndgn_old + dum3alnsg2(ipair) - yn_tail = (lndp_cut(ipair) - lndgn_old)*factoryy(mfrm) - yv_tail = (lndp_cut(ipair) - lndgv_old)*factoryy(mfrm) - tailfr_numold = 0.5_r8*erfc( yn_tail ) - tailfr_volold = 0.5_r8*erfc( yv_tail ) + if (dgn_t_new .ge. dp_cut(ipair)) then + dgn_t_old = min( dgn_t_old, dp_belowcut(ipair) ) + end if + lndgn_old = log( dgn_t_old ) + lndgv_old = lndgn_old + dum3alnsg2(ipair) + yn_tail = (lndp_cut(ipair) - lndgn_old)*factoryy(mfrm) + yv_tail = (lndp_cut(ipair) - 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 - dum = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_old - if (dum .le. 0.0_r8) cycle mainloop1_ipair + dum = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_old + if (dum .le. 0.0_r8) cycle mainloop1_ipair - xferfrac_vol = min( dum, 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 ) ) + xferfrac_vol = min( dum, 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 ) ) ! ! compute tendencies for the renaming transfer ! - j = jsrflx_rename - do iq = 1, nspecfrm_renamexf(ipair) - xfercoef = xferfrac_vol*deltatinv - if (iq .eq. 1) xfercoef = xferfrac_num*deltatinv + j = jsrflx_rename + do iq = 1, nspecfrm_renamexf(ipair) + xfercoef = xferfrac_vol*deltatinv + if (iq .eq. 1) xfercoef = xferfrac_num*deltatinv - lsfrma = lspecfrma_renamexf(iq,ipair)-loffset - lsfrmc = lspecfrmc_renamexf(iq,ipair)-loffset - lstooa = lspectooa_renamexf(iq,ipair)-loffset - lstooc = lspectooc_renamexf(iq,ipair)-loffset + lsfrma = lspecfrma_renamexf(iq,ipair)-loffset + lsfrmc = lspecfrmc_renamexf(iq,ipair)-loffset + lstooa = lspectooa_renamexf(iq,ipair)-loffset + lstooc = lspectooc_renamexf(iq,ipair)-loffset - if (lsfrma .gt. 0) then - xfertend = xfercoef*max( 0.0_r8, & - (q(i,k,lsfrma)+dqdt(i,k,lsfrma)*deltat) ) + if (lsfrma .gt. 0) then + xfertend = xfercoef*max( 0.0_r8, & + (q(i,k,lsfrma)+dqdt(i,k,lsfrma)*deltat) ) ! diagnostic output start ---------------------------------------- if (ldiag1 > 0) then @@ -558,277 +737,77 @@ subroutine modal_aero_rename_no_acc_crs_sub( & ! diagnostic output end ------------------------------------------ - dqdt(i,k,lsfrma) = dqdt(i,k,lsfrma) - xfertend - qsrflx(i,lsfrma,j) = qsrflx(i,lsfrma,j) - xfertend*pdel_fac - if (lstooa .gt. 0) then - dqdt(i,k,lstooa) = dqdt(i,k,lstooa) + xfertend - qsrflx(i,lstooa,j) = qsrflx(i,lstooa,j) + xfertend*pdel_fac - end if - end if + dqdt(i,k,lsfrma) = dqdt(i,k,lsfrma) - xfertend + qsrflx(i,lsfrma,j) = qsrflx(i,lsfrma,j) - xfertend*pdel_fac + if (lstooa .gt. 0) then + dqdt(i,k,lstooa) = dqdt(i,k,lstooa) + xfertend + qsrflx(i,lstooa,j) = qsrflx(i,lstooa,j) + xfertend*pdel_fac + end if + end if - if (lsfrmc .gt. 0) then - xfertend = xfercoef*max( 0.0_r8, & - (qqcw(i,k,lsfrmc)+dqqcwdt(i,k,lsfrmc)*deltat) ) - dqqcwdt(i,k,lsfrmc) = dqqcwdt(i,k,lsfrmc) - xfertend - qqcwsrflx(i,lsfrmc,j) = qqcwsrflx(i,lsfrmc,j) - xfertend*pdel_fac - if (lstooc .gt. 0) then - dqqcwdt(i,k,lstooc) = dqqcwdt(i,k,lstooc) + xfertend - qqcwsrflx(i,lstooc,j) = qqcwsrflx(i,lstooc,j) + xfertend*pdel_fac - end if - end if + if (lsfrmc .gt. 0) then + xfertend = xfercoef*max( 0.0_r8, & + (qqcw(i,k,lsfrmc)+dqqcwdt(i,k,lsfrmc)*deltat) ) + dqqcwdt(i,k,lsfrmc) = dqqcwdt(i,k,lsfrmc) - xfertend + qqcwsrflx(i,lsfrmc,j) = qqcwsrflx(i,lsfrmc,j) - xfertend*pdel_fac + if (lstooc .gt. 0) then + dqqcwdt(i,k,lstooc) = dqqcwdt(i,k,lstooc) + xfertend + qqcwsrflx(i,lstooc,j) = qqcwsrflx(i,lstooc,j) + xfertend*pdel_fac + end if + end if - end do ! "iq = 1, nspecfrm_renamexf(ipair)" + end do ! "iq = 1, nspecfrm_renamexf(ipair)" - end do mainloop1_ipair + end do mainloop1_ipair - end do mainloop1_i - end do mainloop1_k + end do mainloop1_i + end do mainloop1_k ! ! set dotend's ! - dotendrn(:) = .false. - dotendqqcwrn(:) = .false. - do ipair = 1, npair_renamexf - do iq = 1, nspecfrm_renamexf(ipair) - lsfrma = lspecfrma_renamexf(iq,ipair) - loffset - lsfrmc = lspecfrmc_renamexf(iq,ipair) - loffset - lstooa = lspectooa_renamexf(iq,ipair) - loffset - lstooc = lspectooc_renamexf(iq,ipair) - loffset - if (lsfrma .gt. 0) then - dotendrn(lsfrma) = .true. - if (lstooa .gt. 0) dotendrn(lstooa) = .true. - end if - if (lsfrmc .gt. 0) then - dotendqqcwrn(lsfrmc) = .true. - if (lstooc .gt. 0) dotendqqcwrn(lstooc) = .true. - end if - end do - end do - - - return + dotendrn(:) = .false. + dotendqqcwrn(:) = .false. + do ipair = 1, npair_renamexf + do iq = 1, nspecfrm_renamexf(ipair) + lsfrma = lspecfrma_renamexf(iq,ipair) - loffset + lsfrmc = lspecfrmc_renamexf(iq,ipair) - loffset + lstooa = lspectooa_renamexf(iq,ipair) - loffset + lstooc = lspectooc_renamexf(iq,ipair) - loffset + if (lsfrma .gt. 0) then + dotendrn(lsfrma) = .true. + if (lstooa .gt. 0) dotendrn(lstooa) = .true. + end if + if (lsfrmc .gt. 0) then + dotendqqcwrn(lsfrmc) = .true. + if (lstooc .gt. 0) dotendqqcwrn(lstooc) = .true. + end if + end do + end do -! -! error -- renaming currently just works for 1 pair -! -8100 write(lunout,9050) ipair - call endrun( 'modal_aero_rename_no_acc_crs_sub error' ) -9050 format( / '*** subr. modal_aero_rename_no_acc_crs_sub ***' / & - 4x, 'aerosol renaming not implemented for ipair =', i5 ) - -!EOC - end subroutine modal_aero_rename_no_acc_crs_sub - + return -!------------------------------------------------------------------------- - subroutine modal_aero_rename_no_acc_crs_init ! -! computes pointers for species transfer during aerosol renaming -! (a2 --> a1 transfer) -! transfers include number_a, number_c, mass_a, mass_c and -! water_a +! error -- renaming currently just works for 1 pair ! +8100 write(lunout,9050) ipair + errflg = 1 + errmsg = 'modal_aero_rename_no_acc_crs_sub error' + return +9050 format( / '*** subr. modal_aero_rename_no_acc_crs_sub ***' / & + 4x, 'aerosol renaming not implemented for ipair =', i5 ) - implicit none - -! local variables - integer :: ipair, iq, iqfrm, iqtoo - integer :: lsfrma, lsfrmc, lstooa, lstooc, lunout - integer :: mfrm, mtoo - integer :: n1, n2, nspec - integer :: nchfrma, nchfrmc, nchfrmskip, nchtooa, nchtooc, nchtooskip - - lunout = iulog -! -! define "from mode" and "to mode" for each tail-xfer pairing -! currently just a2-->a1 -! - n1 = modeptr_accum - n2 = modeptr_aitken - if ((n1 .gt. 0) .and. (n2 .gt. 0)) then - npair_renamexf = 1 - modefrm_renamexf(1) = n2 - modetoo_renamexf(1) = n1 - else - npair_renamexf = 0 - return - end if +!EOC + end subroutine modal_aero_rename_no_acc_crs_sub -! -! define species involved in each tail-xfer pairing -! (include aerosol water) -! -aa_ipair: do ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(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 renaming - cycle aa_iqfrm -! lsfrma = lwaterptr_amode(mfrm) -! lsfrmc = 0 -! lstooa = lwaterptr_amode(mtoo) -! lstooc = 0 - 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(lunout,9100) mfrm, iqfrm, lsfrma - call endrun( 'modal_aero_rename_init error aa' ) - end if - if ((lsfrmc < 1) .or. (lsfrmc > pcnst)) then - write(lunout,9102) mfrm, iqfrm, lsfrmc - call endrun( 'modal_aero_rename_init error bb' ) - end if - - - if (iqfrm > 0) then - nchfrma = len( trim( cnst_name(lsfrma) ) ) - nchfrmskip - -! find "too" species having same lspectype_amode as the "frm" species -! AND same cnst_name (except for last 1/2/3 characters which are the mode index) - do iqtoo = 1, nspec_amode(mtoo) -! if ( lspectype_amode(iqtoo,mtoo) .eq. & -! lspectype_amode(iqfrm,mfrm) ) then - 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 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(lunout,9104) mfrm, iqfrm, lsfrma, iqtoo, lstooa - call endrun( 'modal_aero_rename_init error cc' ) - end if - if ((lstooc == 0) .and. (iqfrm /= 0)) then - write(lunout,9104) mfrm, iqfrm, lsfrmc, iqtoo, lstooc - call endrun( 'modal_aero_rename_init error dd' ) - end if - - nspec = nspec + 1 - lspecfrma_renamexf(nspec,ipair) = lsfrma - lspectooa_renamexf(nspec,ipair) = lstooa - lspecfrmc_renamexf(nspec,ipair) = lsfrmc - lspectooc_renamexf(nspec,ipair) = lstooc - end do aa_iqfrm - - nspecfrm_renamexf(ipair) = nspec - end do aa_ipair - -9100 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & - 'lspecfrma out of range' / & - 'modefrm, ispecfrm, lspecfrma =', 3i6 / ) -9102 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & - 'lspecfrmc out of range' / & - 'modefrm, ispecfrm, lspecfrmc =', 3i6 / ) -9104 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & - 'lspectooa out of range' / & - 'modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 5i6 / ) -9106 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & - 'lspectooc out of range' / & - 'modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 5i6 / ) -! -! output results -! - if ( masterproc ) then - - write(lunout,9310) - - do 2900 ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - write(lunout,9320) ipair, mfrm, mtoo - - do iq = 1, nspecfrm_renamexf(ipair) - lsfrma = lspecfrma_renamexf(iq,ipair) - lstooa = lspectooa_renamexf(iq,ipair) - lsfrmc = lspecfrmc_renamexf(iq,ipair) - lstooc = lspectooc_renamexf(iq,ipair) - if (lstooa .gt. 0) then - write(lunout,9330) lsfrma, cnst_name(lsfrma), & - lstooa, cnst_name(lstooa) - else - write(lunout,9340) lsfrma, cnst_name(lsfrma) - end if - if (lstooc .gt. 0) then - write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc), & - lstooc, cnst_name_cw(lstooc) - else if (lsfrmc .gt. 0) then - write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc) - else - write(lunout,9350) - end if - end do - -2900 continue - write(lunout,*) - - end if ! ( masterproc ) - -9310 format( / 'subr. modal_aero_rename_no_acc_crs_init' ) -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' ) - - return - end subroutine modal_aero_rename_no_acc_crs_init -!---------------------------------------------------------------------- -! code for troposphere and stratosphere -! -- allows accumulation to coarse mode exchange -!---------------------------------------------------------------------- -!BOP -! !ROUTINE: modal_aero_rename_acc_crs_sub --- ... -! -! !INTERFACE: - subroutine modal_aero_rename_acc_crs_sub( & - fromwhere, lchnk, & - ncol, nstep, & + subroutine modal_aero_rename_acc_crs_sub( & + ncol, & loffset, deltat, & pdel, troplev, & dotendrn, q, & @@ -838,59 +817,104 @@ subroutine modal_aero_rename_acc_crs_sub( & is_dorename_atik, dorename_atik, & jsrflx_rename, nsrflx, & qsrflx, qqcwsrflx, & - dqdt_rnpos ) + dqdt_rnpos, & + ntot_amode, npair_renamexf, & + modefrm_renamexf, modetoo_renamexf, & + nspecfrm_renamexf, & + lspecfrma_renamexf, lspecfrmc_renamexf, & + lspectooa_renamexf, lspectooc_renamexf, & + alnsg_amode, voltonumblo_amode, & + voltonumbhi_amode, dgnum_amode, & + nspec_amode, specmw_amode, & + specdens_amode, lmassptr_amode, & + lmassptrcw_amode, numptr_amode, & + numptrcw_amode, pi, & + modeptr_accum, modeptr_coarse, & + modeptr_stracoar, & + igrow_shrink_renamexf, & + ixferable_all_renamexf, & + ixferable_a_renamexf, ixferable_c_renamexf, & + strat_only_renamexf, & + pver, gravit, & + errmsg, errflg ) ! !USES: - use physconst, only: gravit, mwdry use shr_spfn_mod, only: erfc => shr_spfn_erfc - implicit none - - ! !PARAMETERS: - character(len=*), intent(in) :: fromwhere ! identifies which module - ! is making the call - integer, intent(in) :: lchnk ! chunk identifier integer, intent(in) :: ncol ! number of atmospheric column - integer, intent(in) :: nstep ! model time-step number integer, intent(in) :: loffset ! offset applied to modal aero "ptrs" real(r8), intent(in) :: deltat ! time step (s) - integer, intent(in) :: troplev(pcols) + integer, intent(in) :: troplev(:) - real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: q(ncol,pver,pcnstxx) ! tracer mixing ratio array + real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) + real(r8), intent(in) :: q(:,:,:) ! tracer mixing ratio array ! *** MUST BE mol/mol-air or #/mol-air ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(in) :: qqcw(ncol,pver,pcnstxx) ! like q but for cloud-borne species + real(r8), intent(in) :: qqcw(:,:,:) ! like q but for cloud-borne species - real(r8), intent(inout) :: dqdt(ncol,pver,pcnstxx) ! TMR tendency array; + real(r8), intent(inout) :: dqdt(:,:,:) ! TMR tendency array; ! incoming dqdt = tendencies for the ! "fromwhere" continuous growth process ! the renaming tendencies are added on ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(inout) :: dqqcwdt(ncol,pver,pcnstxx) - real(r8), intent(in) :: dqdt_other(ncol,pver,pcnstxx) + real(r8), intent(inout) :: dqqcwdt(:,:,:) + real(r8), intent(in) :: dqdt_other(:,:,:) ! tendencies for "other" continuous growth process ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(in) :: dqqcwdt_other(ncol,pver,pcnstxx) - logical, intent(inout) :: dotendrn(pcnstxx) ! identifies the species for which + real(r8), intent(in) :: dqqcwdt_other(:,:,:) + logical, intent(inout) :: dotendrn(:) ! identifies the species for which ! renaming dqdt is computed - logical, intent(inout) :: dotendqqcwrn(pcnstxx) + logical, intent(inout) :: dotendqqcwrn(:) logical, intent(in) :: is_dorename_atik ! true if dorename_atik is provided - logical, intent(in) :: dorename_atik(ncol,pver) ! true if renaming should + logical, intent(in) :: dorename_atik(:,:) ! true if renaming should ! be done at i,k integer, intent(in) :: jsrflx_rename ! qsrflx index for renaming integer, intent(in) :: nsrflx ! last dimension of qsrflx - real(r8), intent(inout) :: qsrflx(pcols,pcnstxx,nsrflx) + real(r8), intent(out) :: qsrflx(:,:,:) ! process-specific column tracer tendencies - real(r8), intent(inout) :: qqcwsrflx(pcols,pcnstxx,nsrflx) - real(r8), optional, intent(out) & - :: dqdt_rnpos(ncol,pver,pcnstxx) + real(r8), intent(out) :: qqcwsrflx(:,:,:) + real(r8), intent(out) :: dqdt_rnpos(:,:,:) ! the positive (production) part of the renaming tendency + integer, intent(in) :: pver ! number of vertical levels + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + character(len=*), intent(out) :: errmsg ! error message + integer, intent(out) :: errflg ! error flag + ! shared mode metadata + resolved renaming-pair tables (host-owned; passed in) + integer, intent(in) :: ntot_amode ! number of aerosol modes + integer, intent(in) :: npair_renamexf ! number of renaming pairs + integer, intent(in) :: modefrm_renamexf(:) ! source mode index per pair + integer, intent(in) :: modetoo_renamexf(:) ! destination mode index per pair + integer, intent(in) :: nspecfrm_renamexf(:) ! number of transferred species per pair + integer, intent(in) :: lspecfrma_renamexf(:,:) ! interstitial source species (pcnst-space) + integer, intent(in) :: lspecfrmc_renamexf(:,:) ! cloud-borne source species + integer, intent(in) :: lspectooa_renamexf(:,:) ! interstitial destination species + integer, intent(in) :: lspectooc_renamexf(:,:) ! cloud-borne destination species + real(r8), intent(in) :: alnsg_amode(:) ! ln(geometric std dev) of each mode + real(r8), intent(in) :: voltonumblo_amode(:) ! volume-to-number ratio, low limit + real(r8), intent(in) :: voltonumbhi_amode(:) ! volume-to-number ratio, high limit + real(r8), intent(in) :: dgnum_amode(:) ! nominal geometric mean diameter + integer, intent(in) :: nspec_amode(:) ! number of species in each mode + real(r8), intent(in) :: specmw_amode(:,:) ! species molecular weight + real(r8), intent(in) :: specdens_amode(:,:) ! species density + integer, intent(in) :: lmassptr_amode(:,:) ! interstitial mass pointer (pcnst-space) + integer, intent(in) :: lmassptrcw_amode(:,:) ! cloud-borne mass pointer + integer, intent(in) :: numptr_amode(:) ! interstitial number pointer + integer, intent(in) :: numptrcw_amode(:) ! cloud-borne number pointer + real(r8), intent(in) :: pi ! pi + ! accum-coarse-exchange path flags (host-owned; passed in) + integer, intent(in) :: modeptr_accum ! accumulation mode index + integer, intent(in) :: modeptr_coarse ! coarse mode index + integer, intent(in) :: modeptr_stracoar ! stratospheric coarse mode index + integer, intent(in) :: igrow_shrink_renamexf(:) ! +1 growing / -1 shrinking per pair + integer, intent(in) :: ixferable_all_renamexf(:) ! all-species-transferable flag per pair + integer, intent(in) :: ixferable_a_renamexf(:,:) ! per-species interstitial transferable flag + integer, intent(in) :: ixferable_c_renamexf(:,:) ! per-species cloud-borne transferable flag + logical, intent(in) :: strat_only_renamexf(:) ! restrict renaming to the stratosphere ! !DESCRIPTION: ! computes TMR (tracer mixing ratio) tendencies for "mode renaming" ! during a continuous growth process @@ -944,35 +968,37 @@ subroutine modal_aero_rename_acc_crs_sub( & real (r8) :: yn_tail, yv_tail ! begin - lunout = iulog + lunout = iulog + errmsg = '' + errflg = 0 + ! intent(out): fully define before any early return + qsrflx(:,:,:) = 0.0_r8 + qqcwsrflx(:,:,:) = 0.0_r8 ! ! calculations done once on initial entry ! ! "init" is now done through chem_init (and things under it) -! if (npair_renamexf .eq. -123456789) then -! npair_renamexf = 0 -! call modal_aero_rename_init -! end if +! if (npair_renamexf .eq. -123456789) then +! npair_renamexf = 0 +! call modal_aero_rename_init +! end if ! ! check if any renaming pairs exist ! - if (npair_renamexf .le. 0) return -! if (ncol .ne. -123456789) return -! if (fromwhere .eq. 'aqchem') return + if (npair_renamexf .le. 0) return +! if (ncol .ne. -123456789) return +! if (fromwhere .eq. 'aqchem') return - deltatinv = 1.0_r8/(deltat*(1.0_r8 + 1.0e-15_r8)) - onethird = 1.0_r8/3.0_r8 - xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps + deltatinv = 1.0_r8/(deltat*(1.0_r8 + 1.0e-15_r8)) + onethird = 1.0_r8/3.0_r8 + xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps - if ( present( dqdt_rnpos ) ) then - l_dqdt_rnpos = .true. - dqdt_rnpos(:,:,:) = 0.0_r8 - else - l_dqdt_rnpos = .false. - end if + ! dqdt_rnpos is now a required output; always produced. + l_dqdt_rnpos = .true. + dqdt_rnpos(:,:,:) = 0.0_r8 @@ -981,8 +1007,8 @@ subroutine modal_aero_rename_acc_crs_sub( & ! mainloop1_ipair: do ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(ipair) flagaa_shrink = & ((mfrm==modeptr_coarse) .and. (mtoo==modeptr_accum)) .or. & @@ -991,54 +1017,54 @@ subroutine modal_aero_rename_acc_crs_sub( & ! ! compute aerosol dry-volume for the "from mode" of each renaming pair ! also compute dry-volume change during the continuous growth process -! using the incoming dqdt*deltat -! - dryvol_a(:,:) = 0.0_r8 - dryvol_c(:,:) = 0.0_r8 - deldryvol_a(:,:) = 0.0_r8 - deldryvol_c(:,:) = 0.0_r8 - if (ixferable_all_renamexf(ipair) <= 0) then - dryvol_a_xfab(:,:) = 0.0_r8 - dryvol_c_xfab(:,:) = 0.0_r8 - end if - - n = mfrm - do l1 = 1, nspec_amode(n) +! using the incoming dqdt*deltat +! + dryvol_a(:,:) = 0.0_r8 + dryvol_c(:,:) = 0.0_r8 + deldryvol_a(:,:) = 0.0_r8 + deldryvol_c(:,:) = 0.0_r8 + if (ixferable_all_renamexf(ipair) <= 0) then + dryvol_a_xfab(:,:) = 0.0_r8 + dryvol_c_xfab(:,:) = 0.0_r8 + end if + + n = mfrm + do l1 = 1, nspec_amode(n) ! tmp_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) ! [m3-AP/kmol-AP]= [kg-AP/kmol-AP] / [kg-AP/m3-AP] tmp_m2v = specmw_amode(l1,n) / specdens_amode(l1,n) - tmp_m2vdt = tmp_m2v*deltat - la = lmassptr_amode(l1,n)-loffset - if (la > 0) then - dryvol_a(1:ncol,:) = dryvol_a(1:ncol,:) & - + tmp_m2v*max( 0.0_r8, & - q(1:ncol,:,la)-deltat*dqdt_other(1:ncol,:,la) ) - deldryvol_a(1:ncol,:) = deldryvol_a(1:ncol,:) & - + (dqdt_other(1:ncol,:,la) + dqdt(1:ncol,:,la))*tmp_m2vdt - if ( (ixferable_all_renamexf(ipair) <= 0) .and. & - (ixferable_a_renamexf(l1,ipair) > 0) ) then - dryvol_a_xfab(1:ncol,:) = dryvol_a_xfab(1:ncol,:) & - + tmp_m2v*max( 0.0_r8, & - q(1:ncol,:,la)+deltat*dqdt(1:ncol,:,la) ) - end if - end if - - lc = lmassptrcw_amode(l1,n)-loffset - if (lc > 0) then - dryvol_c(1:ncol,:) = dryvol_c(1:ncol,:) & - + tmp_m2v*max( 0.0_r8, & - qqcw(1:ncol,:,lc)-deltat*dqqcwdt_other(1:ncol,:,lc) ) - deldryvol_c(1:ncol,:) = deldryvol_c(1:ncol,:) & - + (dqqcwdt_other(1:ncol,:,lc) + & - dqqcwdt(1:ncol,:,lc))*tmp_m2vdt - if ( (ixferable_all_renamexf(ipair) <= 0) .and. & - (ixferable_c_renamexf(l1,ipair) > 0) ) then - dryvol_c_xfab(1:ncol,:) = dryvol_c_xfab(1:ncol,:) & - + tmp_m2v*max( 0.0_r8, & - qqcw(1:ncol,:,lc)+deltat*dqqcwdt(1:ncol,:,lc) ) - end if - end if - end do + tmp_m2vdt = tmp_m2v*deltat + la = lmassptr_amode(l1,n)-loffset + if (la > 0) then + dryvol_a(1:ncol,:) = dryvol_a(1:ncol,:) & + + tmp_m2v*max( 0.0_r8, & + q(1:ncol,:,la)-deltat*dqdt_other(1:ncol,:,la) ) + deldryvol_a(1:ncol,:) = deldryvol_a(1:ncol,:) & + + (dqdt_other(1:ncol,:,la) + dqdt(1:ncol,:,la))*tmp_m2vdt + if ( (ixferable_all_renamexf(ipair) <= 0) .and. & + (ixferable_a_renamexf(l1,ipair) > 0) ) then + dryvol_a_xfab(1:ncol,:) = dryvol_a_xfab(1:ncol,:) & + + tmp_m2v*max( 0.0_r8, & + q(1:ncol,:,la)+deltat*dqdt(1:ncol,:,la) ) + end if + end if + + lc = lmassptrcw_amode(l1,n)-loffset + if (lc > 0) then + dryvol_c(1:ncol,:) = dryvol_c(1:ncol,:) & + + tmp_m2v*max( 0.0_r8, & + qqcw(1:ncol,:,lc)-deltat*dqqcwdt_other(1:ncol,:,lc) ) + deldryvol_c(1:ncol,:) = deldryvol_c(1:ncol,:) & + + (dqqcwdt_other(1:ncol,:,lc) + & + dqqcwdt(1:ncol,:,lc))*tmp_m2vdt + if ( (ixferable_all_renamexf(ipair) <= 0) .and. & + (ixferable_c_renamexf(l1,ipair) > 0) ) then + dryvol_c_xfab(1:ncol,:) = dryvol_c_xfab(1:ncol,:) & + + tmp_m2v*max( 0.0_r8, & + qqcw(1:ncol,:,lc)+deltat*dqqcwdt(1:ncol,:,lc) ) + end if + end if + end do ! ! @@ -1049,9 +1075,9 @@ subroutine modal_aero_rename_acc_crs_sub( & mainloop1_i: do i = 1, ncol ! if dorename_atik is provided, then check if renaming needed at this i,k - if (is_dorename_atik) then - if (.not. dorename_atik(i,k)) cycle mainloop1_i - end if + if (is_dorename_atik) then + if (.not. dorename_atik(i,k)) cycle mainloop1_i + end if ! if strat_only_renamexf is true, then cycle when at or below the tropopause level if ( strat_only_renamexf(ipair) ) then @@ -1060,231 +1086,231 @@ subroutine modal_aero_rename_acc_crs_sub( & ! dryvol_t_old is the old total (a+c) dry-volume for the "from" mode -! in m^3-AP/kmol-air +! in m^3-AP/kmol-air ! dryvol_t_new is the new total dry-volume -! (old/new = before/after the continuous growth) - dryvol_t_old = dryvol_a(i,k) + dryvol_c(i,k) - dryvol_t_del = deldryvol_a(i,k) + deldryvol_c(i,k) - dryvol_t_new = dryvol_t_old + dryvol_t_del - dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) ) +! (old/new = before/after the continuous growth) + dryvol_t_old = dryvol_a(i,k) + dryvol_c(i,k) + dryvol_t_del = deldryvol_a(i,k) + deldryvol_c(i,k) + dryvol_t_new = dryvol_t_old + dryvol_t_del + dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) ) grow_shrink_conditional1: & - if (igrow_shrink_renamexf(ipair) > 0) then + if (igrow_shrink_renamexf(ipair) > 0) then ! do renaming for growing particles ! no renaming if dryvol_t_new ~ 0 - if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_i + if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_i ! no renaming if delta_dryvol is very small or negative - if ( (method_optbb_renamexf /= 2) .and. & - (dryvol_t_del .le. 1.0e-6_r8*dryvol_t_oldbnd) ) cycle mainloop1_i + if ( (method_optbb_renamexf /= 2) .and. & + (dryvol_t_del .le. 1.0e-6_r8*dryvol_t_oldbnd) ) cycle mainloop1_i ! num_t_old is total number in particles/kmol-air - num_t_old = q(i,k,numptr_amode(mfrm)-loffset) - num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset) - 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 ) + num_t_old = q(i,k,numptr_amode(mfrm)-loffset) + num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset) + 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 ) ! compute new dgnum - dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird + dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird ! no renaming if dgn_t_new < threshold value - if (dgn_t_new .le. dp_xfernone_threshaa(ipair)) cycle mainloop1_i + if (dgn_t_new .le. dp_xfernone_threshaa(ipair)) cycle mainloop1_i ! compute old dgnum and possibly a smaller value to get more renaming transfer - dgn_t_old = & - (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird - dgn_t_oldb = dgn_t_old - dryvol_t_oldb = dryvol_t_old - if ( method_optbb_renamexf == 2) then - if (dgn_t_old .ge. dp_cut(ipair)) then - ! this revised volume corresponds to dgn_t_old == dp_belowcut, and same number conc - dryvol_t_oldb = dryvol_t_old * (dp_belowcut(ipair)/dgn_t_old)**3 - dgn_t_oldb = dp_belowcut(ipair) - end if - if (dgn_t_new .lt. dp_xferall_thresh(ipair)) then - ! no renaming if delta_dryvol is very small or negative - if ((dryvol_t_new-dryvol_t_oldb) .le. 1.0e-6_r8*dryvol_t_oldbnd) cycle mainloop1_i - end if - - else if (dgn_t_new .ge. dp_cut(ipair)) then + dgn_t_old = & + (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird + dgn_t_oldb = dgn_t_old + dryvol_t_oldb = dryvol_t_old + if ( method_optbb_renamexf == 2) then + if (dgn_t_old .ge. dp_cut(ipair)) then + ! this revised volume corresponds to dgn_t_old == dp_belowcut, and same number conc + dryvol_t_oldb = dryvol_t_old * (dp_belowcut(ipair)/dgn_t_old)**3 + dgn_t_oldb = dp_belowcut(ipair) + end if + if (dgn_t_new .lt. dp_xferall_thresh(ipair)) then + ! no renaming if delta_dryvol is very small or negative + if ((dryvol_t_new-dryvol_t_oldb) .le. 1.0e-6_r8*dryvol_t_oldbnd) cycle mainloop1_i + end if + + else if (dgn_t_new .ge. dp_cut(ipair)) then ! if dgn_t_new exceeds dp_cut, use the minimum of dgn_t_oldb and ! dp_belowcut to guarantee some transfer - dgn_t_oldb = min( dgn_t_oldb, dp_belowcut(ipair) ) - end if + dgn_t_oldb = min( dgn_t_oldb, dp_belowcut(ipair) ) + end if ! compute new fraction of number and mass in the tail (dp > dp_cut) - lndgn_new = log( dgn_t_new ) - lndgv_new = lndgn_new + factor_3alnsg2(ipair) - yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm) - yv_tail = (lndp_cut(ipair) - lndgv_new)*factoryy(mfrm) - tailfr_numnew = 0.5_r8*erfc( yn_tail ) - tailfr_volnew = 0.5_r8*erfc( yv_tail ) + lndgn_new = log( dgn_t_new ) + lndgv_new = lndgn_new + factor_3alnsg2(ipair) + yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm) + yv_tail = (lndp_cut(ipair) - 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) - lndgn_old = log( dgn_t_oldb ) - lndgv_old = lndgn_old + factor_3alnsg2(ipair) - yn_tail = (lndp_cut(ipair) - lndgn_old)*factoryy(mfrm) - yv_tail = (lndp_cut(ipair) - lndgv_old)*factoryy(mfrm) - tailfr_numold = 0.5_r8*erfc( yn_tail ) - tailfr_volold = 0.5_r8*erfc( yv_tail ) + lndgn_old = log( dgn_t_oldb ) + lndgv_old = lndgn_old + factor_3alnsg2(ipair) + yn_tail = (lndp_cut(ipair) - lndgn_old)*factoryy(mfrm) + yv_tail = (lndp_cut(ipair) - 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 - if ( (method_optbb_renamexf == 2) .and. & - (dgn_t_new .ge. dp_xferall_thresh(ipair)) ) then - dryvol_xferamt = dryvol_t_new - else - dryvol_xferamt = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_oldb - end if - if (dryvol_xferamt .le. 0.0_r8) cycle mainloop1_i - - xferfrac_vol = max( 0.0_r8, (dryvol_xferamt/dryvol_t_new) ) - if ( method_optbb_renamexf == 2 .and. & - (xferfrac_vol >= xferfrac_max) ) then - ! transfer entire contents of mode - xferfrac_vol = 1.0_r8 - xferfrac_num = 1.0_r8 - else - xferfrac_vol = min( xferfrac_vol, xferfrac_max ) - xferfrac_num = tailfr_numnew - tailfr_numold - xferfrac_num = max( 0.0_r8, min( xferfrac_num, xferfrac_vol ) ) - end if - - if (ixferable_all_renamexf(ipair) <= 0) then - ! not all species are xferable - dryvol_t_new_xfab = max( 0.0_r8, (dryvol_a_xfab(i,k) + dryvol_c_xfab(i,k)) ) - dryvol_xferamt = xferfrac_vol*dryvol_t_new - if (dryvol_t_new_xfab >= 0.999999_r8*dryvol_xferamt) then - ! xferable dryvol can supply the needed dryvol_xferamt - ! but xferfrac_vol must be increased - xferfrac_vol = min( 1.0_r8, (dryvol_xferamt/dryvol_t_new_xfab) ) - else if (dryvol_t_new_xfab >= 1.0e-7_r8*dryvol_xferamt) then - ! xferable dryvol cannot supply the needed dryvol_xferamt - ! so transfer all of it, and reduce the number transfer - xferfrac_vol = 1.0_r8 - xferfrac_num = xferfrac_num*(dryvol_t_new_xfab/dryvol_xferamt) - else - ! xferable dryvol << needed dryvol_xferamt - cycle mainloop1_i - end if - end if - - else grow_shrink_conditional1 + if ( (method_optbb_renamexf == 2) .and. & + (dgn_t_new .ge. dp_xferall_thresh(ipair)) ) then + dryvol_xferamt = dryvol_t_new + else + dryvol_xferamt = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_oldb + end if + if (dryvol_xferamt .le. 0.0_r8) cycle mainloop1_i + + xferfrac_vol = max( 0.0_r8, (dryvol_xferamt/dryvol_t_new) ) + if ( method_optbb_renamexf == 2 .and. & + (xferfrac_vol >= xferfrac_max) ) then + ! transfer entire contents of mode + xferfrac_vol = 1.0_r8 + xferfrac_num = 1.0_r8 + else + xferfrac_vol = min( xferfrac_vol, xferfrac_max ) + xferfrac_num = tailfr_numnew - tailfr_numold + xferfrac_num = max( 0.0_r8, min( xferfrac_num, xferfrac_vol ) ) + end if + + if (ixferable_all_renamexf(ipair) <= 0) then + ! not all species are xferable + dryvol_t_new_xfab = max( 0.0_r8, (dryvol_a_xfab(i,k) + dryvol_c_xfab(i,k)) ) + dryvol_xferamt = xferfrac_vol*dryvol_t_new + if (dryvol_t_new_xfab >= 0.999999_r8*dryvol_xferamt) then + ! xferable dryvol can supply the needed dryvol_xferamt + ! but xferfrac_vol must be increased + xferfrac_vol = min( 1.0_r8, (dryvol_xferamt/dryvol_t_new_xfab) ) + else if (dryvol_t_new_xfab >= 1.0e-7_r8*dryvol_xferamt) then + ! xferable dryvol cannot supply the needed dryvol_xferamt + ! so transfer all of it, and reduce the number transfer + xferfrac_vol = 1.0_r8 + xferfrac_num = xferfrac_num*(dryvol_t_new_xfab/dryvol_xferamt) + else + ! xferable dryvol << needed dryvol_xferamt + cycle mainloop1_i + end if + end if + + else grow_shrink_conditional1 ! do renaming for shrinking particles ! no renaming if (dryvol_t_old ~ 0) - if (dryvol_t_old .le. dryvol_smallest(mfrm)) cycle mainloop1_i + if (dryvol_t_old .le. dryvol_smallest(mfrm)) cycle mainloop1_i ! when (delta_dryvol is very small or positive), ! which means particles are not evaporating, ! only do renaming if [(flagaa_shrink true) and (in stratosphere)]], ! and set flagbb_shrink true to identify this special case - if (dryvol_t_del .ge. -1.0e-6_r8*dryvol_t_oldbnd) then - if ( ( flagaa_shrink ) .and. ( k < troplev(i) ) ) then - flagbb_shrink = .true. - else - cycle mainloop1_i - end if - else - flagbb_shrink = .false. - end if + if (dryvol_t_del .ge. -1.0e-6_r8*dryvol_t_oldbnd) then + if ( ( flagaa_shrink ) .and. ( k < troplev(i) ) ) then + flagbb_shrink = .true. + else + cycle mainloop1_i + end if + else + flagbb_shrink = .false. + end if ! num_t_old is total number in particles/kmol-air - num_t_old = q(i,k,numptr_amode(mfrm)-loffset) - num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset) - 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 ) + num_t_old = q(i,k,numptr_amode(mfrm)-loffset) + num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset) + 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 ) ! compute new dgnum - dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird + dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird ! no renaming if (dgn_t_new > xfernone threshold value) - if (dgn_t_new .ge. dp_xfernone_threshaa(ipair)) cycle mainloop1_i + if (dgn_t_new .ge. dp_xfernone_threshaa(ipair)) cycle mainloop1_i ! if (flagbb_shrink true), renaming only when (dgn_t_new <= dp_cut value) - if ( flagbb_shrink ) then - if (dgn_t_new .gt. dp_cut(ipair)) cycle mainloop1_i - end if + if ( flagbb_shrink ) then + if (dgn_t_new .gt. dp_cut(ipair)) cycle mainloop1_i + end if - if ( dgn_t_new .le. dp_xferall_thresh(ipair) ) then + if ( dgn_t_new .le. dp_xferall_thresh(ipair) ) then ! special case of (dgn_t_new <= xferall threshold value) - tailfr_numnew = 1.0_r8 - tailfr_volnew = 1.0_r8 - else + tailfr_numnew = 1.0_r8 + tailfr_volnew = 1.0_r8 + else ! compute new fraction of number and mass in the tail (dp < dp_cut) - lndgn_new = log( dgn_t_new ) - lndgv_new = lndgn_new + factor_3alnsg2(ipair) - yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm) - yv_tail = (lndp_cut(ipair) - lndgv_new)*factoryy(mfrm) - tailfr_numnew = 1.0_r8 - 0.5_r8*erfc( yn_tail ) - tailfr_volnew = 1.0_r8 - 0.5_r8*erfc( yv_tail ) - end if + lndgn_new = log( dgn_t_new ) + lndgv_new = lndgn_new + factor_3alnsg2(ipair) + yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm) + yv_tail = (lndp_cut(ipair) - lndgv_new)*factoryy(mfrm) + tailfr_numnew = 1.0_r8 - 0.5_r8*erfc( yn_tail ) + tailfr_volnew = 1.0_r8 - 0.5_r8*erfc( yv_tail ) + end if ! compute old dgnum - dgn_t_old = & - (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird - dgn_t_oldb = dgn_t_old - dryvol_t_oldb = dryvol_t_old + dgn_t_old = & + (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird + dgn_t_oldb = dgn_t_old + dryvol_t_oldb = dryvol_t_old ! no need to compute old fraction of number and mass in the tail - tailfr_numold = 0.0_r8 - tailfr_volold = 0.0_r8 + tailfr_numold = 0.0_r8 + tailfr_volold = 0.0_r8 ! transfer fraction is new tail-fraction - xferfrac_vol = tailfr_volnew - if (xferfrac_vol .le. 0.0_r8) cycle mainloop1_i - xferfrac_num = tailfr_numnew - - if (xferfrac_vol >= xferfrac_max) then - ! transfer entire contents of mode - xferfrac_vol = 1.0_r8 - xferfrac_num = 1.0_r8 - else - xferfrac_vol = min( xferfrac_vol, xferfrac_max ) + xferfrac_vol = tailfr_volnew + if (xferfrac_vol .le. 0.0_r8) cycle mainloop1_i + xferfrac_num = tailfr_numnew + + if (xferfrac_vol >= xferfrac_max) then + ! transfer entire contents of mode + xferfrac_vol = 1.0_r8 + xferfrac_num = 1.0_r8 + else + xferfrac_vol = min( xferfrac_vol, xferfrac_max ) ! transfer fraction for number cannot be less than that of volume - xferfrac_num = max( xferfrac_num, xferfrac_vol ) - xferfrac_num = min( xferfrac_max, xferfrac_num ) - end if - - if (ixferable_all_renamexf(ipair) <= 0) then - ! not all species are xferable - dryvol_t_new_xfab = max( 0.0_r8, (dryvol_a_xfab(i,k) + dryvol_c_xfab(i,k)) ) - dryvol_xferamt = xferfrac_vol*dryvol_t_new - if (dryvol_t_new_xfab >= 0.999999_r8*dryvol_xferamt) then - ! xferable dryvol can supply the needed dryvol_xferamt - ! but xferfrac_vol must be increased - xferfrac_vol = min( 1.0_r8, (dryvol_xferamt/dryvol_t_new_xfab) ) - else if (dryvol_t_new_xfab >= 1.0e-7_r8*dryvol_xferamt) then - ! xferable dryvol cannot supply the needed dryvol_xferamt - ! so transfer all of it, and reduce the number transfer - xferfrac_vol = 1.0_r8 - xferfrac_num = xferfrac_num*(dryvol_t_new_xfab/dryvol_xferamt) - else - ! xferable dryvol << needed dryvol_xferamt - cycle mainloop1_i - end if - end if - - endif grow_shrink_conditional1 + xferfrac_num = max( xferfrac_num, xferfrac_vol ) + xferfrac_num = min( xferfrac_max, xferfrac_num ) + end if + + if (ixferable_all_renamexf(ipair) <= 0) then + ! not all species are xferable + dryvol_t_new_xfab = max( 0.0_r8, (dryvol_a_xfab(i,k) + dryvol_c_xfab(i,k)) ) + dryvol_xferamt = xferfrac_vol*dryvol_t_new + if (dryvol_t_new_xfab >= 0.999999_r8*dryvol_xferamt) then + ! xferable dryvol can supply the needed dryvol_xferamt + ! but xferfrac_vol must be increased + xferfrac_vol = min( 1.0_r8, (dryvol_xferamt/dryvol_t_new_xfab) ) + else if (dryvol_t_new_xfab >= 1.0e-7_r8*dryvol_xferamt) then + ! xferable dryvol cannot supply the needed dryvol_xferamt + ! so transfer all of it, and reduce the number transfer + xferfrac_vol = 1.0_r8 + xferfrac_num = xferfrac_num*(dryvol_t_new_xfab/dryvol_xferamt) + else + ! xferable dryvol << needed dryvol_xferamt + cycle mainloop1_i + end if + end if + + endif grow_shrink_conditional1 ! ! compute tendencies for the renaming transfer ! - pdel_fac = pdel(i,k)/gravit - j = jsrflx_rename - do iq = 1, nspecfrm_renamexf(ipair) - xfercoef = xferfrac_vol*deltatinv - if (iq .eq. 1) xfercoef = xferfrac_num*deltatinv + pdel_fac = pdel(i,k)/gravit + j = jsrflx_rename + do iq = 1, nspecfrm_renamexf(ipair) + xfercoef = xferfrac_vol*deltatinv + if (iq .eq. 1) xfercoef = xferfrac_num*deltatinv - lsfrma = lspecfrma_renamexf(iq,ipair)-loffset - lsfrmc = lspecfrmc_renamexf(iq,ipair)-loffset - lstooa = lspectooa_renamexf(iq,ipair)-loffset - lstooc = lspectooc_renamexf(iq,ipair)-loffset + lsfrma = lspecfrma_renamexf(iq,ipair)-loffset + lsfrmc = lspecfrmc_renamexf(iq,ipair)-loffset + lstooa = lspectooa_renamexf(iq,ipair)-loffset + lstooc = lspectooc_renamexf(iq,ipair)-loffset - if (lsfrma .gt. 0) then - xfertend = xfercoef*max( 0.0_r8, & - (q(i,k,lsfrma)+dqdt(i,k,lsfrma)*deltat) ) + if (lsfrma .gt. 0) then + xfertend = xfercoef*max( 0.0_r8, & + (q(i,k,lsfrma)+dqdt(i,k,lsfrma)*deltat) ) ! diagnostic output start ---------------------------------------- if (ldiag1 > 0) then @@ -1304,440 +1330,71 @@ subroutine modal_aero_rename_acc_crs_sub( & ! diagnostic output end ------------------------------------------ - dqdt(i,k,lsfrma) = dqdt(i,k,lsfrma) - xfertend - qsrflx(i,lsfrma,j) = qsrflx(i,lsfrma,j) - xfertend*pdel_fac - if (lstooa .gt. 0) then - dqdt(i,k,lstooa) = dqdt(i,k,lstooa) + xfertend - qsrflx(i,lstooa,j) = qsrflx(i,lstooa,j) + xfertend*pdel_fac - if ( l_dqdt_rnpos ) & - dqdt_rnpos(i,k,lstooa) = dqdt_rnpos(i,k,lstooa) + xfertend - end if - end if + dqdt(i,k,lsfrma) = dqdt(i,k,lsfrma) - xfertend + qsrflx(i,lsfrma,j) = qsrflx(i,lsfrma,j) - xfertend*pdel_fac + if (lstooa .gt. 0) then + dqdt(i,k,lstooa) = dqdt(i,k,lstooa) + xfertend + qsrflx(i,lstooa,j) = qsrflx(i,lstooa,j) + xfertend*pdel_fac + if ( l_dqdt_rnpos ) & + dqdt_rnpos(i,k,lstooa) = dqdt_rnpos(i,k,lstooa) + xfertend + end if + end if - if (lsfrmc .gt. 0) then - xfertend = xfercoef*max( 0.0_r8, & - (qqcw(i,k,lsfrmc)+dqqcwdt(i,k,lsfrmc)*deltat) ) - dqqcwdt(i,k,lsfrmc) = dqqcwdt(i,k,lsfrmc) - xfertend - qqcwsrflx(i,lsfrmc,j) = qqcwsrflx(i,lsfrmc,j) - xfertend*pdel_fac - if (lstooc .gt. 0) then - dqqcwdt(i,k,lstooc) = dqqcwdt(i,k,lstooc) + xfertend - qqcwsrflx(i,lstooc,j) = qqcwsrflx(i,lstooc,j) + xfertend*pdel_fac - end if - end if + if (lsfrmc .gt. 0) then + xfertend = xfercoef*max( 0.0_r8, & + (qqcw(i,k,lsfrmc)+dqqcwdt(i,k,lsfrmc)*deltat) ) + dqqcwdt(i,k,lsfrmc) = dqqcwdt(i,k,lsfrmc) - xfertend + qqcwsrflx(i,lsfrmc,j) = qqcwsrflx(i,lsfrmc,j) - xfertend*pdel_fac + if (lstooc .gt. 0) then + dqqcwdt(i,k,lstooc) = dqqcwdt(i,k,lstooc) + xfertend + qqcwsrflx(i,lstooc,j) = qqcwsrflx(i,lstooc,j) + xfertend*pdel_fac + end if + end if - end do ! "iq = 1, nspecfrm_renamexf(ipair)" + end do ! "iq = 1, nspecfrm_renamexf(ipair)" - end do mainloop1_i - end do mainloop1_k + end do mainloop1_i + end do mainloop1_k - end do mainloop1_ipair + end do mainloop1_ipair ! ! set dotend's ! - dotendrn(:) = .false. - dotendqqcwrn(:) = .false. - do ipair = 1, npair_renamexf - do iq = 1, nspecfrm_renamexf(ipair) - lsfrma = lspecfrma_renamexf(iq,ipair) - loffset - lsfrmc = lspecfrmc_renamexf(iq,ipair) - loffset - lstooa = lspectooa_renamexf(iq,ipair) - loffset - lstooc = lspectooc_renamexf(iq,ipair) - loffset - if (lsfrma .gt. 0) then - dotendrn(lsfrma) = .true. - if (lstooa .gt. 0) dotendrn(lstooa) = .true. - end if - if (lsfrmc .gt. 0) then - dotendqqcwrn(lsfrmc) = .true. - if (lstooc .gt. 0) dotendqqcwrn(lstooc) = .true. - end if - end do - end do - - - return + dotendrn(:) = .false. + dotendqqcwrn(:) = .false. + do ipair = 1, npair_renamexf + do iq = 1, nspecfrm_renamexf(ipair) + lsfrma = lspecfrma_renamexf(iq,ipair) - loffset + lsfrmc = lspecfrmc_renamexf(iq,ipair) - loffset + lstooa = lspectooa_renamexf(iq,ipair) - loffset + lstooc = lspectooc_renamexf(iq,ipair) - loffset + if (lsfrma .gt. 0) then + dotendrn(lsfrma) = .true. + if (lstooa .gt. 0) dotendrn(lstooa) = .true. + end if + if (lsfrmc .gt. 0) then + dotendqqcwrn(lsfrmc) = .true. + if (lstooc .gt. 0) dotendqqcwrn(lstooc) = .true. + end if + end do + end do -! -! error -- renaming currently just works for 1 pair -! -8100 write(lunout,9050) ipair - call endrun( 'modal_aero_rename_acc_crs_sub error' ) -9050 format( / '*** subr. modal_aero_rename_acc_crs_sub ***' / & - 4x, 'aerosol renaming not implemented for ipair =', i5 ) - -!EOC - end subroutine modal_aero_rename_acc_crs_sub + return - -!------------------------------------------------------------------------- -! for modal aerosols in the troposphere and stratophere -! -- allows accumulation to coarse mode exchange -!------------------------------------------------------------------------- - subroutine modal_aero_rename_acc_crs_init -! -! computes pointers for species transfer during aerosol renaming -! (a2 --> a1 transfer) -! transfers include number_a, number_c, mass_a, mass_c and -! water_a ! - - implicit none - -! local variables - integer :: i, ipair, iq, iqfrm, iqtooa, iqtooc, itmpa - integer :: l, lsfrma, lsfrmc, lstooa, lstooc, lunout - integer :: mfrm, mtoo - integer :: n1, n2, nspec - integer :: nch_lfrm, nch_ltoo, nch_mfrmid, nch_mtooid - - real (r8) :: frelax - - lunout = iulog - -! -! define "from mode" and "to mode" for each tail-xfer pairing -! using the values in ipair_select_renamexf(:) -! - npair_renamexf = 0 - do ipair = 1, maxpair_renamexf - itmpa = ipair_select_renamexf(ipair) - if (itmpa == 0) then - exit - else if (itmpa == 2001) then !both mam4 and mam5 - mfrm = modeptr_aitken - mtoo = modeptr_accum - igrow_shrink_renamexf(ipair) = 1 - ixferable_all_needed_renamexf(ipair) = 1 - strat_only_renamexf(ipair) = .false. - else if (itmpa == 1003) then - mfrm = modeptr_accum - mtoo = modeptr_coarse - igrow_shrink_renamexf(ipair) = 1 - ixferable_all_needed_renamexf(ipair) = 0 - strat_only_renamexf(ipair) = .true. - else if (itmpa == 1005) then - mfrm = modeptr_accum - mtoo = modeptr_stracoar - igrow_shrink_renamexf(ipair) = 1 - ixferable_all_needed_renamexf(ipair) = 0 - strat_only_renamexf(ipair) = .true. - else if (itmpa == 3001) then - mfrm = modeptr_coarse - mtoo = modeptr_accum - igrow_shrink_renamexf(ipair) = -1 - ixferable_all_needed_renamexf(ipair) = 0 - strat_only_renamexf(ipair) = .true. - else if (itmpa == 5001) then - mfrm = modeptr_stracoar - mtoo = modeptr_accum - igrow_shrink_renamexf(ipair) = -1 - ixferable_all_needed_renamexf(ipair) = 0 - strat_only_renamexf(ipair) = .true. - else - write(lunout,'(/2a,3(1x,i12))') & - '*** subr. modal_aero_rename_acc_crs_init', & - 'bad ipair_select_renamexf', ipair, itmpa - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - - do i = 1, ipair-1 - if (itmpa .eq. ipair_select_renamexf(i)) then - write(lunout,'(/2a/10(1x,i12))') & - '*** subr. modal_aero_rename_acc_crs_init', & - 'duplicates in ipair_select_renamexf', & - ipair_select_renamexf(1:ipair) - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - end do - - if ( (mfrm .ge. 1) .and. (mfrm .le. ntot_amode) .and. & - (mtoo .ge. 1) .and. (mtoo .le. ntot_amode) ) then - npair_renamexf = ipair - modefrm_renamexf(ipair) = mfrm - modetoo_renamexf(ipair) = mtoo - else - write(lunout,'(/2a,3(1x,i12))') & - '*** subr. modal_aero_rename_acc_crs_init', & - 'bad mfrm or mtoo', ipair, mfrm, mtoo - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - end do ! ipair - - if (npair_renamexf .le. 0) then - write(lunout,'(/a/a,3(1x,i12))') & - '*** subr. modal_aero_rename_acc_crs_init -- npair_renamexf = 0' - return - end if - - -! -! define species involved in each tail-xfer pairing -! (include aerosol water) -! - do 1900 ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - ixferable_all_renamexf(ipair) = 1 - - if (mfrm < 10) then - nch_mfrmid = 1 - else if (mfrm < 100) then - nch_mfrmid = 2 - else - nch_mfrmid = 3 - end if - if (mtoo < 10) then - nch_mtooid = 1 - else if (mtoo < 100) then - nch_mtooid = 2 - else - nch_mtooid = 3 - end if - - nspec = 0 - do 1490 iqfrm = -1, nspec_amode(mfrm) - if (iqfrm .eq. -1) then - lsfrma = numptr_amode(mfrm) - lstooa = numptr_amode(mtoo) - lsfrmc = numptrcw_amode(mfrm) - lstooc = numptrcw_amode(mtoo) - else if (iqfrm .eq. 0) then -! bypass transfer of aerosol water due to renaming - goto 1490 -! lsfrma = lwaterptr_amode(mfrm) -! lsfrmc = 0 -! lstooa = lwaterptr_amode(mtoo) -! lstooc = 0 - else - lsfrma = lmassptr_amode(iqfrm,mfrm) - lsfrmc = lmassptrcw_amode(iqfrm,mfrm) - lstooa = 0 - lstooc = 0 - end if - - if ((lsfrma .lt. 1) .or. (lsfrma .gt. pcnst)) then - write(lunout,9100) ipair, mfrm, iqfrm, lsfrma - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - if (iqfrm .le. 0) goto 1430 - - if ((lsfrmc .lt. 1) .or. (lsfrmc .gt. pcnst)) then - write(lunout,9102) ipair, mfrm, iqfrm, lsfrmc - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - -! find "too" species having same name (except for mode number) as the "frm" species - nch_lfrm = len(trim(cnst_name(lsfrma))) - nch_mfrmid - iqtooa = -99 - do iq = 1, nspec_amode(mtoo) - l = lmassptr_amode(iq,mtoo) - if ((l .lt. 1) .or. (l .gt. pcnst)) cycle - nch_ltoo = len(trim(cnst_name(l))) - nch_mtooid - if ( cnst_name(lsfrma)(1:nch_lfrm) == & - cnst_name(l )(1:nch_ltoo) ) then - lstooa = l - iqtooa = iq - exit - end if - end do - - nch_lfrm = len(trim(cnst_name_cw(lsfrmc))) - nch_mfrmid - iqtooc = -99 - do iq = 1, nspec_amode(mtoo) - l = lmassptrcw_amode(iq,mtoo) - if ((l .lt. 1) .or. (l .gt. pcnst)) cycle - nch_ltoo = len(trim(cnst_name_cw(l))) - nch_mtooid - if ( cnst_name_cw(lsfrmc)(1:nch_lfrm) == & - cnst_name_cw(l )(1:nch_ltoo) ) then - lstooc = l - iqtooc = iq - exit - end if - end do - -1430 if ((lstooc .lt. 1) .or. (lstooc .gt. pcnst)) lstooc = 0 - if ((lstooa .lt. 1) .or. (lstooa .gt. pcnst)) lstooa = 0 - - if ((lstooa .eq. 0) .or. (lstooc .eq. 0)) then - if ( ( masterproc ) .or. & - ( (lstooa .ne. 0) .or. (lstooc .ne. 0) ) .or. & - ( ixferable_all_needed_renamexf(ipair) .gt. 0 ) ) then - if (lstooa .eq. 0) & - write(lunout,9104) trim(cnst_name(lsfrma)), & - ipair, mfrm, iqfrm, lsfrma, iqtooa, lstooa - if (lstooc .eq. 0) & - write(lunout,9106) trim(cnst_name_cw(lsfrmc)), & - ipair, mfrm, iqfrm, lsfrmc, iqtooc, lstooc - end if - if ((lstooa .ne. 0) .or. (lstooc .ne. 0)) then - write(lunout,9108) - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - if (ixferable_all_needed_renamexf(ipair) .gt. 0) then - write(lunout,9109) - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - ixferable_all_renamexf(ipair) = 0 - if (iqfrm .gt. 0) then - ixferable_a_renamexf(iqfrm,ipair) = 0 - ixferable_c_renamexf(iqfrm,ipair) = 0 - end if - else - nspec = nspec + 1 - lspecfrma_renamexf(nspec,ipair) = lsfrma - lspectooa_renamexf(nspec,ipair) = lstooa - lspecfrmc_renamexf(nspec,ipair) = lsfrmc - lspectooc_renamexf(nspec,ipair) = lstooc - if (iqfrm .gt. 0) then - ixferable_a_renamexf(iqfrm,ipair) = 1 - ixferable_c_renamexf(iqfrm,ipair) = 1 - end if - end if -1490 continue - - nspecfrm_renamexf(ipair) = nspec -1900 continue - -9100 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'lspecfrma out of range' / & - 'ipair, modefrm, ispecfrm, lspecfrma =', 4i6 ) -9102 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'lspecfrmc out of range' / & - 'ipair, modefrm, ispecfrm, lspecfrmc =', 4i6 ) -9104 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'lspectooa out of range for', 2x, a / & - 'ipair, modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 6i6 ) -9106 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'lspectooc out of range for', 2x, a / & - 'ipair, modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 6i6 ) -9108 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'only one of lspectooa and lspectooc is out of range' ) -9109 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'all species must be xferable for this pair' ) - - -! -! -! initialize some working variables -! -! - ido_mode_calcaa(:) = 0 - frelax = 27.0_r8 - - do ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - ido_mode_calcaa(mfrm) = 1 - - factoraa(mfrm) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mfrm)**2)) - factoraa(mtoo) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mtoo)**2)) - factoryy(mfrm) = sqrt( 0.5_r8 )/alnsg_amode(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_r8 - v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax - v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax - - factor_3alnsg2(ipair) = 3.0_r8 * (alnsg_amode(mfrm)**2) - - dp_cut(ipair) = sqrt( & - dgnum_amode(mfrm)*exp(1.5_r8*(alnsg_amode(mfrm)**2)) * & - dgnum_amode(mtoo)*exp(1.5_r8*(alnsg_amode(mtoo)**2)) ) - dp_xferall_thresh(ipair) = dgnum_amode(mtoo) - dp_xfernone_threshaa(ipair) = dgnum_amode(mfrm) - if (((mfrm == modeptr_accum) .and. (mtoo == modeptr_coarse)).or.& - ((mfrm == modeptr_accum) .and. (mtoo == modeptr_stracoar))) then - dp_cut(ipair) = 4.4e-7_r8 - dp_xfernone_threshaa(ipair) = 1.6e-7_r8 - dp_xferall_thresh(ipair) = 4.7e-7_r8 - else if (((mfrm == modeptr_coarse) .and. (mtoo == modeptr_accum)).or.& - ((mfrm == modeptr_stracoar) .and. (mtoo == modeptr_accum))) then - dp_cut(ipair) = 4.4e-7_r8 - dp_xfernone_threshaa(ipair) = 4.4e-7_r8 - dp_xferall_thresh(ipair) = 4.1e-7_r8 - end if - - lndp_cut(ipair) = log( dp_cut(ipair) ) - dp_belowcut(ipair) = 0.99_r8*dp_cut(ipair) - end do - - -! -! output results +! error -- renaming currently just works for 1 pair ! - if ( masterproc ) then - - write(lunout,9310) - write(lunout,'(a,1x,i12)') 'method_optbb_renamexf', method_optbb_renamexf - - do 2900 ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - write(lunout,9320) ipair, mfrm, mtoo, & - igrow_shrink_renamexf(ipair), ixferable_all_renamexf(ipair) - - do iq = 1, nspecfrm_renamexf(ipair) - lsfrma = lspecfrma_renamexf(iq,ipair) - lstooa = lspectooa_renamexf(iq,ipair) - lsfrmc = lspecfrmc_renamexf(iq,ipair) - lstooc = lspectooc_renamexf(iq,ipair) - if (lstooa .gt. 0) then - write(lunout,9330) lsfrma, cnst_name(lsfrma), & - lstooa, cnst_name(lstooa) - else - write(lunout,9340) lsfrma, cnst_name(lsfrma) - end if - if (lstooc .gt. 0) then - write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc), & - lstooc, cnst_name_cw(lstooc) - else if (lsfrmc .gt. 0) then - write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc) - else - write(lunout,9350) - end if - end do - - if (igrow_shrink_renamexf(ipair) > 0) then - write(lunout,'(5x,a,1p,2e12.3)') 'mfrm dgnum, dgnumhi ', & - dgnum_amode(mfrm), dgnumhi_amode(mfrm) - write(lunout,'(5x,a,1p,2e12.3)') 'mtoo dgnum, dgnumlo ', & - dgnum_amode(mtoo), dgnumlo_amode(mtoo) - else - write(lunout,'(5x,a,1p,2e12.3)') 'mfrm dgnum, dgnumlo ', & - dgnum_amode(mfrm), dgnumlo_amode(mfrm) - write(lunout,'(5x,a,1p,2e12.3)') 'mtoo dgnum, dgnumhi ', & - dgnum_amode(mtoo), dgnumhi_amode(mtoo) - end if - - write(lunout,'(5x,a,1p,2e12.3)') 'dp_cut ', & - dp_cut(ipair) - write(lunout,'(5x,a,1p,2e12.3)') 'dp_xfernone_threshaa', & - dp_xfernone_threshaa(ipair) - write(lunout,'(5x,a,1p,2e12.3)') 'dp_xferall_thresh ', & - dp_xferall_thresh(ipair) - -2900 continue - write(lunout,*) - - end if ! ( masterproc ) - -9310 format( / 'subr. modal_aero_rename_acc_crs_init' ) -9320 format( / 'pair', i3, 5x, 'mode', i3, ' ---> mode', i3, & - 5x, 'igrow_shrink', i3, 5x, 'ixferable_all', i3 ) -9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a ) -9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' ) -9350 format( 5x, 'no corresponding activated species' ) - - - return - end subroutine modal_aero_rename_acc_crs_init - -!---------------------------------------------------------------------- +8100 write(lunout,9050) ipair + errflg = 1 + errmsg = 'modal_aero_rename_acc_crs_sub error' + return +9050 format( / '*** subr. modal_aero_rename_acc_crs_sub ***' / & + 4x, 'aerosol renaming not implemented for ipair =', i5 ) - end module modal_aero_rename + end subroutine modal_aero_rename_acc_crs_sub +end module modal_aero_rename diff --git a/src/chemistry/modal_aero/modal_aero_rename_cam.F90 b/src/chemistry/modal_aero/modal_aero_rename_cam.F90 new file mode 100644 index 0000000000..aa79e7b704 --- /dev/null +++ b/src/chemistry/modal_aero/modal_aero_rename_cam.F90 @@ -0,0 +1,601 @@ +! CAM wrapper for modal_aero_rename. +! Owns the resolved renaming-pair tables (consumed by other CAM aerosol +! wrappers), performs the cnst_name-based pair resolution, and hands the +! tables + mode metadata to the portable modal_aero_rename_init. +!---------------------------------------------------------------------- + module modal_aero_rename_cam + +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use mo_constants, only: pi + use constituents, only: pcnst, cnst_name + use spmd_utils, only: masterproc + use modal_aero_data, only: maxspec_renamexf=>nspec_max, ntot_amode + use modal_aero_data, only: alnsg_amode, voltonumblo_amode, voltonumbhi_amode, dgnum_amode, nspec_amode + use modal_aero_data, only: lmassptr_amode, lmassptrcw_amode + use modal_aero_data, only: numptr_amode, numptrcw_amode, modeptr_coarse, modeptr_accum + use modal_aero_data, only: modeptr_stracoar + use modal_aero_data, only: dgnumhi_amode, dgnumlo_amode, cnst_name_cw, modeptr_aitken + use radiative_aerosol,only: rad_aer_get_mode_idx + use modal_aero_rename, only: maxpair_renamexf + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + public :: modal_aero_rename_cam_init + +! !PUBLIC DATA MEMBERS: +! Resolved renaming-pair tables (host constituent-index space). These are +! consumed by modal_aero_calcsize_cam and modal_aero_gasaerexch_cam. + integer, public :: npair_renamexf = -123456789 + integer, protected, public :: modefrm_renamexf(maxpair_renamexf) + integer, protected, public :: modetoo_renamexf(maxpair_renamexf) + integer, protected, public :: nspecfrm_renamexf(maxpair_renamexf) + + integer, allocatable, protected, public :: lspecfrma_renamexf(:,:) + integer, allocatable, protected, public :: lspecfrmc_renamexf(:,:) + integer, allocatable, protected, public :: lspectooa_renamexf(:,:) + integer, allocatable, protected, public :: lspectooc_renamexf(:,:) + +! ipair_select_renamexf defines the mode_from and mode_too for each renaming pair +! 2001 = aitken --> accum +! 1003 = accum --> coarse +! 3001 = coarse --> accum +! 1005 = accum --> stracoar +! 5001 = stracoar --> accum + integer :: ipair_select_renamexf(maxpair_renamexf) + +! Renaming-pair flags resolved here and consumed by the portable science: handed +! to modal_aero_rename_init, and passed by aero_model to modal_aero_rename_run. + integer, protected, public :: igrow_shrink_renamexf(maxpair_renamexf) + integer, protected, public :: ixferable_all_renamexf(maxpair_renamexf) + integer :: ixferable_all_needed_renamexf(maxpair_renamexf) + integer, allocatable, protected, public :: ixferable_a_renamexf(:,:) + integer, allocatable, protected, public :: ixferable_c_renamexf(:,:) + + logical, protected, public :: strat_only_renamexf(maxpair_renamexf) +! strat_only_renamexf - when true for a particular renaming pair, renaming is only +! done in stratosphere (when k < troplev(icol) ) + + logical :: modal_accum_coarse_exch = .false. + +!---------------------------------------------------------------------- +contains + + !------------------------------------------------------------------ + ! Resolve the renaming-pair tables from CAM constituent metadata, then hand + ! them (with the mode metadata) to the portable modal_aero_rename_init. + !------------------------------------------------------------------ + subroutine modal_aero_rename_cam_init(modal_accum_coarse_exch_in) + use modal_aero_rename, only: modal_aero_rename_init + + logical, optional, intent(in) :: modal_accum_coarse_exch_in + + character(len=512) :: errmsg + integer :: errflg + + ! ipair_select_renamexf defines the mode_from and mode_too for each renaming pair + ! 2001 = aitken --> accum + ! 1003 = accum --> coarse + ! 3001 = coarse --> accum + ! 1005 = accum --> stracoar + ! 5001 = stracoar --> accum + if( rad_aer_get_mode_idx(0,'coarse_strat') > 0 ) then + ipair_select_renamexf(1:maxpair_renamexf) = (/ 2001, 1005, 5001 /) + else + ipair_select_renamexf(1:maxpair_renamexf) = (/ 2001, 1003, 3001 /) + endif + + allocate( lspecfrma_renamexf(maxspec_renamexf,maxpair_renamexf) ) + allocate( lspecfrmc_renamexf(maxspec_renamexf,maxpair_renamexf) ) + allocate( lspectooa_renamexf(maxspec_renamexf,maxpair_renamexf) ) + allocate( lspectooc_renamexf(maxspec_renamexf,maxpair_renamexf) ) + + allocate( ixferable_a_renamexf(maxspec_renamexf,maxpair_renamexf) ) + allocate( ixferable_c_renamexf(maxspec_renamexf,maxpair_renamexf) ) + + ! Default-initialize the accum-coarse-exchange flags: the no_acc_crs + ! resolution path leaves them unset, and they are handed (unused) to the + ! portable code on that path. + igrow_shrink_renamexf(:) = 0 + ixferable_all_renamexf(:) = 0 + ixferable_a_renamexf(:,:) = 0 + ixferable_c_renamexf(:,:) = 0 + strat_only_renamexf(:) = .false. + + if (present(modal_accum_coarse_exch_in)) then + modal_accum_coarse_exch = modal_accum_coarse_exch_in + endif + + if (modal_accum_coarse_exch) then + call modal_aero_rename_acc_crs_init() + else + call modal_aero_rename_no_acc_crs_init() + endif + + ! Precompute rename's own accum-coarse-exchange physics coefficients. Only + ! the metadata the precompute + one-time log needs is handed over; the shared + ! tables/metadata are passed per-call to modal_aero_rename_run instead. + call modal_aero_rename_init( & + modal_accum_coarse_exch = modal_accum_coarse_exch, & + ntot_amode = ntot_amode, & + alnsg_amode = alnsg_amode, & + dgnum_amode = dgnum_amode, & + dgnumhi_amode = dgnumhi_amode, & + dgnumlo_amode = dgnumlo_amode, & + voltonumblo_amode = voltonumblo_amode, & + voltonumbhi_amode = voltonumbhi_amode, & + modeptr_accum = modeptr_accum, & + modeptr_coarse = modeptr_coarse, & + modeptr_stracoar = modeptr_stracoar, & + npair_renamexf = npair_renamexf, & + modefrm_renamexf = modefrm_renamexf, & + modetoo_renamexf = modetoo_renamexf, & + nspecfrm_renamexf = nspecfrm_renamexf, & + lspecfrma_renamexf = lspecfrma_renamexf, & + lspecfrmc_renamexf = lspecfrmc_renamexf, & + lspectooa_renamexf = lspectooa_renamexf, & + lspectooc_renamexf = lspectooc_renamexf, & + igrow_shrink_renamexf = igrow_shrink_renamexf, & + ixferable_all_renamexf = ixferable_all_renamexf, & + cnst_name_in = cnst_name, & + cnst_name_cw_in = cnst_name_cw, & + pi = pi, & + amRoot = masterproc, & + iulog_in = iulog, & + errmsg = errmsg, & + errflg = errflg ) + + if (errflg /= 0) then + call endrun('modal_aero_rename_cam_init: '//trim(errmsg)) + end if + + end subroutine modal_aero_rename_cam_init + +!---------------------------------------------------------------------- +! private methods -- renaming-pair resolution (verbatim from the original +! modal_aero_rename init routines; cnst_name matching is host-specific) +!---------------------------------------------------------------------- + + subroutine modal_aero_rename_no_acc_crs_init +! +! computes pointers for species transfer during aerosol renaming +! (a2 --> a1 transfer) +! transfers include number_a, number_c, mass_a, mass_c and +! water_a +! + + implicit none + +! local variables + integer :: ipair, iq, iqfrm, iqtoo + integer :: lsfrma, lsfrmc, lstooa, lstooc, lunout + integer :: mfrm, mtoo + integer :: n1, n2, nspec + integer :: nchfrma, nchfrmc, nchfrmskip, nchtooa, nchtooc, nchtooskip + + lunout = iulog +! +! define "from mode" and "to mode" for each tail-xfer pairing +! currently just a2-->a1 +! + n1 = modeptr_accum + n2 = modeptr_aitken + if ((n1 .gt. 0) .and. (n2 .gt. 0)) then + npair_renamexf = 1 + modefrm_renamexf(1) = n2 + modetoo_renamexf(1) = n1 + else + npair_renamexf = 0 + return + end if + +! +! define species involved in each tail-xfer pairing +! (include aerosol water) +! +aa_ipair: do ipair = 1, npair_renamexf + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(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 renaming + cycle aa_iqfrm +! lsfrma = lwaterptr_amode(mfrm) +! lsfrmc = 0 +! lstooa = lwaterptr_amode(mtoo) +! lstooc = 0 + 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(lunout,9100) mfrm, iqfrm, lsfrma + call endrun( 'modal_aero_rename_init error aa' ) + end if + if ((lsfrmc < 1) .or. (lsfrmc > pcnst)) then + write(lunout,9102) mfrm, iqfrm, lsfrmc + call endrun( 'modal_aero_rename_init error bb' ) + end if + + + if (iqfrm > 0) then + nchfrma = len( trim( cnst_name(lsfrma) ) ) - nchfrmskip + +! find "too" species having same lspectype_amode as the "frm" species +! AND same cnst_name (except for last 1/2/3 characters which are the mode index) + do iqtoo = 1, nspec_amode(mtoo) +! if ( lspectype_amode(iqtoo,mtoo) .eq. & +! lspectype_amode(iqfrm,mfrm) ) then + 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 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(lunout,9104) mfrm, iqfrm, lsfrma, iqtoo, lstooa + call endrun( 'modal_aero_rename_init error cc' ) + end if + if ((lstooc == 0) .and. (iqfrm /= 0)) then + write(lunout,9104) mfrm, iqfrm, lsfrmc, iqtoo, lstooc + call endrun( 'modal_aero_rename_init error dd' ) + end if + + nspec = nspec + 1 + lspecfrma_renamexf(nspec,ipair) = lsfrma + lspectooa_renamexf(nspec,ipair) = lstooa + lspecfrmc_renamexf(nspec,ipair) = lsfrmc + lspectooc_renamexf(nspec,ipair) = lstooc + end do aa_iqfrm + + nspecfrm_renamexf(ipair) = nspec + end do aa_ipair + +9100 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & + 'lspecfrma out of range' / & + 'modefrm, ispecfrm, lspecfrma =', 3i6 / ) +9102 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & + 'lspecfrmc out of range' / & + 'modefrm, ispecfrm, lspecfrmc =', 3i6 / ) +9104 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & + 'lspectooa out of range' / & + 'modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 5i6 / ) +9106 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & + 'lspectooc out of range' / & + 'modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 5i6 / ) + +! +! output results +! + if ( masterproc ) then + + write(lunout,9310) + + do 2900 ipair = 1, npair_renamexf + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(ipair) + write(lunout,9320) ipair, mfrm, mtoo + + do iq = 1, nspecfrm_renamexf(ipair) + lsfrma = lspecfrma_renamexf(iq,ipair) + lstooa = lspectooa_renamexf(iq,ipair) + lsfrmc = lspecfrmc_renamexf(iq,ipair) + lstooc = lspectooc_renamexf(iq,ipair) + if (lstooa .gt. 0) then + write(lunout,9330) lsfrma, cnst_name(lsfrma), & + lstooa, cnst_name(lstooa) + else + write(lunout,9340) lsfrma, cnst_name(lsfrma) + end if + if (lstooc .gt. 0) then + write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc), & + lstooc, cnst_name_cw(lstooc) + else if (lsfrmc .gt. 0) then + write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc) + else + write(lunout,9350) + end if + end do + +2900 continue + write(lunout,*) + + end if ! ( masterproc ) + +9310 format( / 'subr. modal_aero_rename_no_acc_crs_init' ) +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' ) + + return + end subroutine modal_aero_rename_no_acc_crs_init + + + + subroutine modal_aero_rename_acc_crs_init +! +! computes pointers for species transfer during aerosol renaming +! (a2 --> a1 transfer) +! transfers include number_a, number_c, mass_a, mass_c and +! water_a +! + + implicit none + +! local variables + integer :: i, ipair, iq, iqfrm, iqtooa, iqtooc, itmpa + integer :: l, lsfrma, lsfrmc, lstooa, lstooc, lunout + integer :: mfrm, mtoo + integer :: n1, n2, nspec + integer :: nch_lfrm, nch_ltoo, nch_mfrmid, nch_mtooid + + real (r8) :: frelax + + lunout = iulog + +! +! define "from mode" and "to mode" for each tail-xfer pairing +! using the values in ipair_select_renamexf(:) +! + npair_renamexf = 0 + do ipair = 1, maxpair_renamexf + itmpa = ipair_select_renamexf(ipair) + if (itmpa == 0) then + exit + else if (itmpa == 2001) then !both mam4 and mam5 + mfrm = modeptr_aitken + mtoo = modeptr_accum + igrow_shrink_renamexf(ipair) = 1 + ixferable_all_needed_renamexf(ipair) = 1 + strat_only_renamexf(ipair) = .false. + else if (itmpa == 1003) then + mfrm = modeptr_accum + mtoo = modeptr_coarse + igrow_shrink_renamexf(ipair) = 1 + ixferable_all_needed_renamexf(ipair) = 0 + strat_only_renamexf(ipair) = .true. + else if (itmpa == 1005) then + mfrm = modeptr_accum + mtoo = modeptr_stracoar + igrow_shrink_renamexf(ipair) = 1 + ixferable_all_needed_renamexf(ipair) = 0 + strat_only_renamexf(ipair) = .true. + else if (itmpa == 3001) then + mfrm = modeptr_coarse + mtoo = modeptr_accum + igrow_shrink_renamexf(ipair) = -1 + ixferable_all_needed_renamexf(ipair) = 0 + strat_only_renamexf(ipair) = .true. + else if (itmpa == 5001) then + mfrm = modeptr_stracoar + mtoo = modeptr_accum + igrow_shrink_renamexf(ipair) = -1 + ixferable_all_needed_renamexf(ipair) = 0 + strat_only_renamexf(ipair) = .true. + else + write(lunout,'(/2a,3(1x,i12))') & + '*** subr. modal_aero_rename_acc_crs_init', & + 'bad ipair_select_renamexf', ipair, itmpa + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + + do i = 1, ipair-1 + if (itmpa .eq. ipair_select_renamexf(i)) then + write(lunout,'(/2a/10(1x,i12))') & + '*** subr. modal_aero_rename_acc_crs_init', & + 'duplicates in ipair_select_renamexf', & + ipair_select_renamexf(1:ipair) + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + end do + + if ( (mfrm .ge. 1) .and. (mfrm .le. ntot_amode) .and. & + (mtoo .ge. 1) .and. (mtoo .le. ntot_amode) ) then + npair_renamexf = ipair + modefrm_renamexf(ipair) = mfrm + modetoo_renamexf(ipair) = mtoo + else + write(lunout,'(/2a,3(1x,i12))') & + '*** subr. modal_aero_rename_acc_crs_init', & + 'bad mfrm or mtoo', ipair, mfrm, mtoo + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + end do ! ipair + + if (npair_renamexf .le. 0) then + write(lunout,'(/a/a,3(1x,i12))') & + '*** subr. modal_aero_rename_acc_crs_init -- npair_renamexf = 0' + return + end if + + +! +! define species involved in each tail-xfer pairing +! (include aerosol water) +! + do 1900 ipair = 1, npair_renamexf + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(ipair) + ixferable_all_renamexf(ipair) = 1 + + if (mfrm < 10) then + nch_mfrmid = 1 + else if (mfrm < 100) then + nch_mfrmid = 2 + else + nch_mfrmid = 3 + end if + if (mtoo < 10) then + nch_mtooid = 1 + else if (mtoo < 100) then + nch_mtooid = 2 + else + nch_mtooid = 3 + end if + + nspec = 0 + do 1490 iqfrm = -1, nspec_amode(mfrm) + if (iqfrm .eq. -1) then + lsfrma = numptr_amode(mfrm) + lstooa = numptr_amode(mtoo) + lsfrmc = numptrcw_amode(mfrm) + lstooc = numptrcw_amode(mtoo) + else if (iqfrm .eq. 0) then +! bypass transfer of aerosol water due to renaming + goto 1490 +! lsfrma = lwaterptr_amode(mfrm) +! lsfrmc = 0 +! lstooa = lwaterptr_amode(mtoo) +! lstooc = 0 + else + lsfrma = lmassptr_amode(iqfrm,mfrm) + lsfrmc = lmassptrcw_amode(iqfrm,mfrm) + lstooa = 0 + lstooc = 0 + end if + + if ((lsfrma .lt. 1) .or. (lsfrma .gt. pcnst)) then + write(lunout,9100) ipair, mfrm, iqfrm, lsfrma + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + if (iqfrm .le. 0) goto 1430 + + if ((lsfrmc .lt. 1) .or. (lsfrmc .gt. pcnst)) then + write(lunout,9102) ipair, mfrm, iqfrm, lsfrmc + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + +! find "too" species having same name (except for mode number) as the "frm" species + nch_lfrm = len(trim(cnst_name(lsfrma))) - nch_mfrmid + iqtooa = -99 + do iq = 1, nspec_amode(mtoo) + l = lmassptr_amode(iq,mtoo) + if ((l .lt. 1) .or. (l .gt. pcnst)) cycle + nch_ltoo = len(trim(cnst_name(l))) - nch_mtooid + if ( cnst_name(lsfrma)(1:nch_lfrm) == & + cnst_name(l )(1:nch_ltoo) ) then + lstooa = l + iqtooa = iq + exit + end if + end do + + nch_lfrm = len(trim(cnst_name_cw(lsfrmc))) - nch_mfrmid + iqtooc = -99 + do iq = 1, nspec_amode(mtoo) + l = lmassptrcw_amode(iq,mtoo) + if ((l .lt. 1) .or. (l .gt. pcnst)) cycle + nch_ltoo = len(trim(cnst_name_cw(l))) - nch_mtooid + if ( cnst_name_cw(lsfrmc)(1:nch_lfrm) == & + cnst_name_cw(l )(1:nch_ltoo) ) then + lstooc = l + iqtooc = iq + exit + end if + end do + +1430 if ((lstooc .lt. 1) .or. (lstooc .gt. pcnst)) lstooc = 0 + if ((lstooa .lt. 1) .or. (lstooa .gt. pcnst)) lstooa = 0 + + if ((lstooa .eq. 0) .or. (lstooc .eq. 0)) then + if ( ( masterproc ) .or. & + ( (lstooa .ne. 0) .or. (lstooc .ne. 0) ) .or. & + ( ixferable_all_needed_renamexf(ipair) .gt. 0 ) ) then + if (lstooa .eq. 0) & + write(lunout,9104) trim(cnst_name(lsfrma)), & + ipair, mfrm, iqfrm, lsfrma, iqtooa, lstooa + if (lstooc .eq. 0) & + write(lunout,9106) trim(cnst_name_cw(lsfrmc)), & + ipair, mfrm, iqfrm, lsfrmc, iqtooc, lstooc + end if + if ((lstooa .ne. 0) .or. (lstooc .ne. 0)) then + write(lunout,9108) + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + if (ixferable_all_needed_renamexf(ipair) .gt. 0) then + write(lunout,9109) + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + ixferable_all_renamexf(ipair) = 0 + if (iqfrm .gt. 0) then + ixferable_a_renamexf(iqfrm,ipair) = 0 + ixferable_c_renamexf(iqfrm,ipair) = 0 + end if + else + nspec = nspec + 1 + lspecfrma_renamexf(nspec,ipair) = lsfrma + lspectooa_renamexf(nspec,ipair) = lstooa + lspecfrmc_renamexf(nspec,ipair) = lsfrmc + lspectooc_renamexf(nspec,ipair) = lstooc + if (iqfrm .gt. 0) then + ixferable_a_renamexf(iqfrm,ipair) = 1 + ixferable_c_renamexf(iqfrm,ipair) = 1 + end if + end if +1490 continue + + nspecfrm_renamexf(ipair) = nspec +1900 continue + +9100 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'lspecfrma out of range' / & + 'ipair, modefrm, ispecfrm, lspecfrma =', 4i6 ) +9102 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'lspecfrmc out of range' / & + 'ipair, modefrm, ispecfrm, lspecfrmc =', 4i6 ) +9104 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'lspectooa out of range for', 2x, a / & + 'ipair, modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 6i6 ) +9106 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'lspectooc out of range for', 2x, a / & + 'ipair, modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 6i6 ) +9108 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'only one of lspectooa and lspectooc is out of range' ) +9109 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'all species must be xferable for this pair' ) + end subroutine modal_aero_rename_acc_crs_init + + end module modal_aero_rename_cam diff --git a/src/chemistry/modal_aero/modal_dust_emissions.F90 b/src/chemistry/modal_aero/modal_dust_emissions.F90 new file mode 100644 index 0000000000..fc7587f68f --- /dev/null +++ b/src/chemistry/modal_aero/modal_dust_emissions.F90 @@ -0,0 +1,138 @@ +!=============================================================================== +! Dust emissions for the Modal Aerosol Model +! Portable science routines split from modal_aero/dust_model.F90: selection +! of the emitted dust size distribution, and rebinning of the coupler dust +! flux into modal mass and number surface fluxes. +! Host constants and index maps are passed as arguments; array sizing is by +! runtime ncol. +!=============================================================================== +module modal_dust_emissions + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + private + + public :: modal_dust_emissions_init + public :: modal_dust_emissions_run + +contains + + !============================================================================= + ! Set the emitted dust size distribution (per-bin mass fractions) and the + ! bin mass-weighted diameters used for the number flux conversion. + !============================================================================= + subroutine modal_dust_emissions_init( ntot_amode, dust_nbin, pi, rair, gravit, & + dust_emis_sclfctr, dust_dmt_vwr, errmsg, errflg ) + use dust_common, only: dust_set_params + + integer, intent(in) :: ntot_amode ! number of aerosol modes + integer, intent(in) :: dust_nbin ! number of dust bins (mass species) + real(r8), intent(in) :: pi ! host model constants + real(r8), intent(in) :: rair ! gas constant for dry air (J/K/kg) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + real(r8), intent(out) :: dust_emis_sclfctr(:) ! mass fraction of emissions per bin + real(r8), intent(out) :: dust_dmt_vwr(:) ! mass-weighted diameter per bin (m) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(r8) :: dust_dmt_grd(dust_nbin+1) ! bin diameter edges (m) + real(r8) :: dust_stk_crc(dust_nbin) ! Stokes correction from dust_set_params; unused by emissions + + errmsg = '' + errflg = 0 + + ! dmleung edited the mass fraction of the emitted dust size distribution. 27 Oct 2025 ++ + ! The new mass fraction comes from Jun Meng et al. (2022) and MERRA-2. + ! Jun Meng's table indicates 2.1 % mass for 0.1-1 um and 97.9 % mass for 1-10 um. + ! ref: https://zenodo.org/records/6344524 + ! MERRA-2 dust emissions indicate 6 % mass for 0.1-1 um (bin1) and 94 % for 1-10 um (bin2-5). + ! dmleung adopts 2.1 % mass for 0.1-1 um and 97.9 % mass for 1-10 um for dust. + ! Distributing more mass to accumulation mode allows a longer lifetime of dust, reducing + ! low dust biases over remote oceans and reducing high dust biases over the Sahara. + ! This change impacts both Zender_2003 dust and Leung_2023 dust. + if ( ntot_amode == 3 ) then + dust_dmt_grd(:) = (/ 0.1e-6_r8, 1.0e-6_r8, 10.0e-6_r8/) + dust_emis_sclfctr(:) = (/ 0.021_r8,0.979_r8 /) + elseif ( ntot_amode == 4 .or. ntot_amode == 5 ) then + dust_dmt_grd(:) = (/ 0.01e-6_r8, 0.1e-6_r8, 1.0e-6_r8, 10.0e-6_r8 /) + dust_emis_sclfctr(:) = (/ 1.65E-05_r8, 0.021_r8, 0.979_r8 /) + else if( ntot_amode == 7 ) then + dust_dmt_grd(:) = (/ 0.1e-6_r8, 2.0e-6_r8, 10.0e-6_r8/) + dust_emis_sclfctr(:) = (/ 0.12_r8, 0.88_r8 /) + endif + ! dmleung -- + + call dust_set_params( nbin=dust_nbin, dmt_grd=dust_dmt_grd, & + dmt_vwr=dust_dmt_vwr, stk_crc=dust_stk_crc, & + pi=pi, rair=rair, gravit=gravit, & + errmsg=errmsg, errflg=errflg ) + + end subroutine modal_dust_emissions_init + + !=============================================================================== + ! Rebin and adjust the incoming coupler dust flux into per-bin mass and + ! number surface fluxes. + !=============================================================================== + subroutine modal_dust_emissions_run( ncol, dust_nbin, dust_indices, dust_emis_sclfctr, & + dust_dmt_vwr, dust_emis_fact, & + zender_soil_erod_from_atm, soil_erodibility, & + dust_flux_in, pi, cflx, soil_erod ) + use dust_common, only: dust_density + + ! args + integer, intent(in) :: ncol + integer, intent(in) :: dust_nbin ! number of dust bins (mass species) + integer, intent(in) :: dust_indices(:) ! constituent indices: mass bins, then number bins + real(r8), intent(in) :: dust_emis_sclfctr(:) ! mass fraction of emissions per bin + real(r8), intent(in) :: dust_dmt_vwr(:) ! mass-weighted diameter per bin (m) + real(r8), intent(in) :: dust_emis_fact ! tuning parameter for dust emissions + logical, intent(in) :: zender_soil_erod_from_atm ! Zender_2003 with soil erodibility applied in atm + real(r8), intent(in) :: soil_erodibility(:) ! soil erodibility factor (used only when + ! zender_soil_erod_from_atm) + real(r8), intent(in) :: dust_flux_in(:,:) ! dust fluxes from the coupler (kg/m2/s, negative down) + real(r8), intent(in) :: pi + real(r8), intent(inout) :: cflx(:,:) ! constituent surface fluxes (kg/m2/s) + real(r8), intent(out) :: soil_erod(:) ! thresholded soil erodibility + ! (not set on the Leung_2023 branch) + + ! local vars + integer :: i, m, idst, inum + real(r8) :: x_mton + real(r8),parameter :: soil_erod_threshold = 0.1_r8 + + ! set dust emissions + + if (zender_soil_erod_from_atm) then ! Zender_2003 dust emissions + col_loop1: do i = 1,ncol + soil_erod(i) = soil_erodibility(i) + if( soil_erod(i) .lt. soil_erod_threshold ) soil_erod(i) = 0._r8 + + ! rebin and adjust dust emissons. + do m = 1,dust_nbin + idst = dust_indices(m) + cflx(i,idst) = sum( -dust_flux_in(i,:) ) & + * dust_emis_sclfctr(m)*soil_erod(i)/dust_emis_fact*1.15_r8 + x_mton = 6._r8 / (pi * dust_density * (dust_dmt_vwr(m)**3._r8)) + inum = dust_indices(m+dust_nbin) + cflx(i,inum) = cflx(i,idst)*x_mton + enddo + enddo col_loop1 + else ! Leung_2023 dust emissions + + col_loop2: do i = 1,ncol + ! rebin and adjust dust emissons. + do m = 1,dust_nbin + idst = dust_indices(m) + + cflx(i,idst) = sum( -dust_flux_in(i,:) ) & + * dust_emis_sclfctr(m) / dust_emis_fact + x_mton = 6._r8 / (pi * dust_density * (dust_dmt_vwr(m)**3._r8)) + inum = dust_indices(m+dust_nbin) + cflx(i,inum) = cflx(i,idst)*x_mton + enddo + enddo col_loop2 + end if + + end subroutine modal_dust_emissions_run + +end module modal_dust_emissions diff --git a/src/chemistry/modal_aero/modal_seasalt_emissions.F90 b/src/chemistry/modal_aero/modal_seasalt_emissions.F90 new file mode 100644 index 0000000000..9fd5d9ddb6 --- /dev/null +++ b/src/chemistry/modal_aero/modal_seasalt_emissions.F90 @@ -0,0 +1,98 @@ +!=============================================================================== +! Sea salt emissions for the Modal Aerosol Model +! Portable science routine split from modal_aero/seasalt_model.F90, plus the +! 10 m wind extrapolation moved from modal_aero/aero_model.F90: sea salt +! section number fluxes accumulated into modal number and mass surface +! fluxes over the ocean fraction. +! Host constants and index maps are passed as arguments; array sizing is by +! runtime ncol. +!=============================================================================== +module modal_seasalt_emissions + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + private + + public :: modal_seasalt_emissions_run + + ! Sea salt aerosol material density used for the number-to-mass flux + ! conversion (value from CAM mo_constants). + real(r8), parameter :: seasalt_density = 2.2e+3_r8 ! [kg m-3] + +contains + + !============================================================================= + !============================================================================= + subroutine modal_seasalt_emissions_run( ncol, nslt, seasalt_indices, emis_scale, & + u_bottom, v_bottom, zmid_bottom, & + srf_temp, ocnfrc, pi, cflx ) + + use sslt_sections, only: nsections, fluxes, Dg, rdry + + ! dummy arguments + integer, intent(in) :: ncol + integer, intent(in) :: nslt ! number of seasalt bins (mass species) + integer, intent(in) :: seasalt_indices(:) ! constituent indices: mass bins, then number bins + real(r8), intent(in) :: emis_scale ! sea salt emission tuning factor + real(r8), intent(in) :: u_bottom(:) ! bottom layer zonal wind (m/s) + real(r8), intent(in) :: v_bottom(:) ! bottom layer meridional wind (m/s) + real(r8), intent(in) :: zmid_bottom(:) ! bottom layer midpoint geopotential height above surface (m) + real(r8), intent(in) :: srf_temp(:) ! sea surface temperature (K) + real(r8), intent(in) :: ocnfrc(:) ! ocean fraction + real(r8), intent(in) :: pi + real(r8), intent(inout) :: cflx(:,:) ! constituent surface fluxes (kg/m2/s or #/m2/s) + + ! local vars + integer :: mn, mm, ibin, i + real(r8) :: fi(ncol,nsections) + real(r8) :: u10cubed(ncol) + real (r8), parameter :: z0=0.0001_r8 ! m roughness length over oceans--from ocean model + + real(r8) :: sst_sz_range_lo (nslt) + real(r8) :: sst_sz_range_hi (nslt) + + u10cubed(:ncol)=sqrt(u_bottom(:ncol)**2+v_bottom(:ncol)**2) + + ! move the winds to 10m high from the midpoint of the gridbox: + ! follows Tie and Seinfeld and Pandis, p.859 with math. + + u10cubed(:ncol)=u10cubed(:ncol)*log(10._r8/z0)/log(zmid_bottom(:ncol)/z0) + + ! we need them to the 3.41 power, according to Gong et al., 1997: + u10cubed(:ncol)=u10cubed(:ncol)**3.41_r8 + + if (nslt==4) then + sst_sz_range_lo (:) = (/ 0.08e-6_r8, 0.02e-6_r8, 0.3e-6_r8, 1.0e-6_r8 /) ! accu, aitken, fine, coarse + sst_sz_range_hi (:) = (/ 0.3e-6_r8, 0.08e-6_r8, 1.0e-6_r8, 10.0e-6_r8 /) + else if (nslt==3) then + sst_sz_range_lo (:) = (/ 0.08e-6_r8, 0.02e-6_r8, 1.0e-6_r8 /) ! accu, aitken, coarse + sst_sz_range_hi (:) = (/ 1.0e-6_r8, 0.08e-6_r8, 10.0e-6_r8 /) + endif + + fi(:ncol,:nsections) = fluxes( srf_temp, u10cubed, ncol ) + + do ibin = 1,nslt + mm = seasalt_indices(ibin) + mn = seasalt_indices(nslt+ibin) + + if (mn>0) then + do i=1, nsections + if (Dg(i).ge.sst_sz_range_lo(ibin) .and. Dg(i).lt.sst_sz_range_hi(ibin)) then + cflx(:ncol,mn)=cflx(:ncol,mn)+fi(:ncol,i)*ocnfrc(:ncol)*emis_scale !++ ag: scale sea-salt + endif + enddo + endif + + cflx(:ncol,mm)=0.0_r8 + do i=1, nsections + if (Dg(i).ge.sst_sz_range_lo(ibin) .and. Dg(i).lt.sst_sz_range_hi(ibin)) then + cflx(:ncol,mm)=cflx(:ncol,mm)+fi(:ncol,i)*ocnfrc(:ncol)*emis_scale & !++ ag: scale sea-salt + *4._r8/3._r8*pi*rdry(i)**3*seasalt_density ! should use dry size, convert from number to mass flux (kg/m2/s) + endif + enddo + + enddo + + end subroutine modal_seasalt_emissions_run + +end module modal_seasalt_emissions diff --git a/src/chemistry/modal_aero/seasalt_model.F90 b/src/chemistry/modal_aero/seasalt_model.F90 index 565348787c..b5a499e22c 100644 --- a/src/chemistry/modal_aero/seasalt_model.F90 +++ b/src/chemistry/modal_aero/seasalt_model.F90 @@ -2,8 +2,7 @@ ! Seasalt for Modal Aerosol Model !=============================================================================== module seasalt_model - use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl - use ppgrid, only: pcols, pver + use shr_kind_mod, only: r8 => shr_kind_r8 use modal_aero_data,only: ntot_amode, nslt=>nSeaSalt implicit none @@ -81,56 +80,27 @@ end subroutine seasalt_init !============================================================================= !============================================================================= - subroutine seasalt_emis( u10cubed, srf_temp, ocnfrc, ncol, cflx ) + subroutine seasalt_emis( u_bottom, v_bottom, zmid_bottom, srf_temp, ocnfrc, ncol, cflx ) - use sslt_sections, only: nsections, fluxes, Dg, rdry - use mo_constants, only: dns_aer_sst=>seasalt_density, pi + use physconst, only: pi + use modal_seasalt_emissions, only: modal_seasalt_emissions_run ! dummy arguments - real(r8), intent(in) :: u10cubed(:) + real(r8), intent(in) :: u_bottom(:) ! bottom layer zonal wind (m/s) + real(r8), intent(in) :: v_bottom(:) ! bottom layer meridional wind (m/s) + real(r8), intent(in) :: zmid_bottom(:) ! bottom layer midpoint geopotential height above surface (m) real(r8), intent(in) :: srf_temp(:) real(r8), intent(in) :: ocnfrc(:) integer, intent(in) :: ncol real(r8), intent(inout) :: cflx(:,:) - ! local vars - integer :: mn, mm, ibin, isec, i - real(r8) :: fi(ncol,nsections) - - real(r8) :: sst_sz_range_lo (nslt) - real(r8) :: sst_sz_range_hi (nslt) - - if (nslt==4) then - sst_sz_range_lo (:) = (/ 0.08e-6_r8, 0.02e-6_r8, 0.3e-6_r8, 1.0e-6_r8 /) ! accu, aitken, fine, coarse - sst_sz_range_hi (:) = (/ 0.3e-6_r8, 0.08e-6_r8, 1.0e-6_r8, 10.0e-6_r8 /) - else if (nslt==3) then - sst_sz_range_lo (:) = (/ 0.08e-6_r8, 0.02e-6_r8, 1.0e-6_r8 /) ! accu, aitken, coarse - sst_sz_range_hi (:) = (/ 1.0e-6_r8, 0.08e-6_r8, 10.0e-6_r8 /) - endif - - fi(:ncol,:nsections) = fluxes( srf_temp, u10cubed, ncol ) - - do ibin = 1,nslt - mm = seasalt_indices(ibin) - mn = seasalt_indices(nslt+ibin) - - if (mn>0) then - do i=1, nsections - if (Dg(i).ge.sst_sz_range_lo(ibin) .and. Dg(i).lt.sst_sz_range_hi(ibin)) then - cflx(:ncol,mn)=cflx(:ncol,mn)+fi(:ncol,i)*ocnfrc(:ncol)*emis_scale !++ ag: scale sea-salt - endif - enddo - endif - - cflx(:ncol,mm)=0.0_r8 - do i=1, nsections - if (Dg(i).ge.sst_sz_range_lo(ibin) .and. Dg(i).lt.sst_sz_range_hi(ibin)) then - cflx(:ncol,mm)=cflx(:ncol,mm)+fi(:ncol,i)*ocnfrc(:ncol)*emis_scale & !++ ag: scale sea-salt - *4._r8/3._r8*pi*rdry(i)**3*dns_aer_sst ! should use dry size, convert from number to mass flux (kg/m2/s) - endif - enddo - - enddo + call modal_seasalt_emissions_run( ncol=ncol, nslt=nslt, & + seasalt_indices=seasalt_indices, & + emis_scale=emis_scale, & + u_bottom=u_bottom, v_bottom=v_bottom, & + zmid_bottom=zmid_bottom, & + srf_temp=srf_temp, ocnfrc=ocnfrc, & + pi=pi, cflx=cflx ) end subroutine seasalt_emis diff --git a/src/chemistry/utils/modal_aero_calcsize.F90 b/src/chemistry/utils/modal_aero_calcsize.F90 index 696713af1e..3073f3d900 100644 --- a/src/chemistry/utils/modal_aero_calcsize.F90 +++ b/src/chemistry/utils/modal_aero_calcsize.F90 @@ -1,275 +1,48 @@ +! Portable science module for modal aerosol size calculation. +! RCE 07.04.13: Adapted from MIRAGE2 code module modal_aero_calcsize + use shr_kind_mod, only: r8 => shr_kind_r8 -! RCE 07.04.13: Adapted from MIRAGE2 code + implicit none + private -use shr_kind_mod, only: r8 => shr_kind_r8 -use spmd_utils, only: masterproc -use physconst, only: pi, rhoh2o, gravit + public :: modal_aero_calcsize_run + public :: modal_aero_calcsize_diag_run + public :: modal_aero_calcdry_run -use ppgrid, only: pcols, pver -use physics_types, only: physics_state, physics_ptend -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field + integer, public, parameter :: calcsize_nsrflx = 4 -use phys_control, only: phys_getopts -use aerosol_properties_mod, only: aerosol_properties -use aerosol_state_mod, only: aerosol_state - -use cam_logfile, only: iulog -use cam_abortutils, only: endrun -use cam_history, only: addfld, add_default, fieldname_len, horiz_only, outfld -use constituents, only: pcnst, cnst_name -use modal_aero_wateruptake, only: modal_strat_sulfate - -use ref_pres, only: top_lev => clim_modal_aero_top_lev - -#ifdef MODAL_AERO - -! these are the variables needed for the diagnostic calculation of dry radius -use modal_aero_data, only: ntot_amode, nspec_amode, nspec_max, & - numptr_amode, & - alnsg_amode, & - voltonumbhi_amode, voltonumblo_amode, & - dgnum_amode, dgnumhi_amode, dgnumlo_amode - - -! these variables are needed for the prognostic calculations to exchange mass -! between modes -use modal_aero_data, only: numptrcw_amode, mprognum_amode, qqcw_get_field, lmassptrcw_amode, & - lmassptr_amode, modeptr_accum, modeptr_aitken, & - 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 - - -implicit none -private -save - -public modal_aero_calcsize_init, modal_aero_calcsize_sub, modal_aero_calcsize_diag -public :: modal_aero_calcsize_reg - -logical :: do_adjust_default -logical :: do_aitacc_transfer_default - -integer :: dgnum_idx = -1 -integer :: hygro_idx = -1 -integer :: dryvol_idx = -1 -integer :: dryrad_idx = -1 -integer :: drymass_idx = -1 -integer :: so4dryvol_idx = -1 -integer :: naer_idx = -1 -integer :: sulfeq_idx = -1 - - -!=============================================================================== contains -!=============================================================================== - -subroutine modal_aero_calcsize_reg() - use physics_buffer, only: pbuf_add_field, dtype_r8 - use radiative_aerosol, only: rad_aer_get_info - - integer :: nmodes - - call rad_aer_get_info(0, nmodes=nmodes) - - call pbuf_add_field('DGNUM', 'global', dtype_r8, (/pcols, pver, nmodes/), dgnum_idx) - - call pbuf_add_field('HYGRO', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), hygro_idx) - call pbuf_add_field('DRYVOL', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), dryvol_idx) - call pbuf_add_field('DRYRAD', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), dryrad_idx) - call pbuf_add_field('DRYMASS', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), drymass_idx) - call pbuf_add_field('SO4DRYVOL', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), so4dryvol_idx) - call pbuf_add_field('NAER', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), naer_idx) - -end subroutine modal_aero_calcsize_reg - -!=============================================================================== -!=============================================================================== - -subroutine modal_aero_calcsize_init(pbuf2d) - use time_manager, only: is_first_step - use physics_buffer,only: pbuf_set_field - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! set do_adjust_default and do_aitacc_transfer_default flags - ! create history fields for column tendencies associated with - ! modal_aero_calcsize - ! - ! Author: R. Easter - ! - !----------------------------------------------------------------------- - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - ! local - integer :: ipair, iq - integer :: jac - integer :: lsfrm, lstoo - integer :: n, nacc, nait - logical :: history_aerosol - - character(len=fieldname_len) :: tmpnamea, tmpnameb - character(len=fieldname_len+3) :: fieldname - character(128) :: long_name - character(8) :: unit - !----------------------------------------------------------------------- - - call phys_getopts(history_aerosol_out=history_aerosol) - - ! init entities required for both prescribed and prognostic modes - - if (is_first_step()) then - ! initialize fields in physics buffer - call pbuf_set_field(pbuf2d, dgnum_idx, 0.0_r8) - endif - -#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. - ! do_aitacc_transfer_default allows aitken <--> accum mode transfer to be turned on/off - ! *** it can only be true when aitken & accum modes are both present - ! and have prognosed number and diagnosed surface/sigmag - nait = modeptr_aitken - nacc = modeptr_accum - do_aitacc_transfer_default = .false. - if ((modeptr_aitken > 0) .and. & - (modeptr_accum > 0) .and. & - (modeptr_aitken /= modeptr_accum)) then - do_aitacc_transfer_default = .true. - if (mprognum_amode(nait) <= 0) do_aitacc_transfer_default = .false. - if (mprognum_amode(nacc) <= 0) do_aitacc_transfer_default = .false. - end if - - if ( .not. do_adjust_default ) return - - ! define history fields for number-adjust source-sink for all modes - do n = 1, ntot_amode - if (mprognum_amode(n) <= 0) cycle - - do jac = 1, 2 - if (jac == 1) then - tmpnamea = cnst_name(numptr_amode(n)) - else - tmpnamea = cnst_name_cw(numptrcw_amode(n)) - end if - unit = '#/m2/s' - fieldname = trim(tmpnamea) // '_sfcsiz1' - long_name = trim(tmpnamea) // ' calcsize number-adjust column source' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname - - fieldname = trim(tmpnamea) // '_sfcsiz2' - long_name = trim(tmpnamea) // ' calcsize number-adjust column sink' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(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 iq = 1, nspecfrm_renamexf(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 - 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 - - 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, horiz_only, 'A', unit, long_name ) - 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, horiz_only, 'A', unit, long_name ) - 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, horiz_only, 'A', unit, long_name ) - 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, horiz_only, 'A', unit, long_name ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname - - end do ! jac = ... - end do ! iq = ... - -#endif - -end subroutine modal_aero_calcsize_init - -!=============================================================================== - -subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_state, & - do_adjust_in, do_aitacc_transfer_in) +subroutine modal_aero_calcsize_run( & + ncol, pver, deltat, top_lev, & + ntot_amode, nspec_amode, nspec_max, & + dgnum_amode, dgnumlo_amode, dgnumhi_amode, & + alnsg_amode, voltonumb_amode, voltonumblo_amode, voltonumbhi_amode, & + specdens_amode, & + mprognum_amode, & + modeptr_aitken, modeptr_accum, & + lmassptr_amode, numptr_amode, & + lmassptrcw_amode, numptrcw_amode, & + pdel, & + gravit, pi, & + num_q, & + q, q_cw, & + do_adjust, do_aitacc_transfer, & + npair_renamexf, & + nspecfrm_renamexf, & + modefrm_renamexf, modetoo_renamexf, & + lspecfrma_renamexf, lspectooa_renamexf, & + lspecfrmc_renamexf, lspectooc_renamexf, & + dgncur_a, & + dqdt, dqdt_cw, & + dotend, dotend_cw, & + qsrflx, & + errmsg, errflg) !----------------------------------------------------------------------- ! - ! Calculates aerosol size distribution parameters + ! Calculates aerosol size distribution parameters ! mprognum_amode > 0 ! calculate Dgnum from mass, number, and fixed sigmag ! mprognum_amode <= 0 @@ -282,72 +55,109 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ ! !----------------------------------------------------------------------- - ! arguments - type(physics_state), target, intent(in) :: state ! Physics state variables - - type(physics_ptend), target, intent(inout) :: ptend ! indivdual parameterization tendencies - - real(r8), intent(in) :: deltat ! model time-step size (s) - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - class(aerosol_properties), intent(in), target :: aero_props - class(aerosol_state), intent(in) :: aero_state - - logical, optional :: do_adjust_in - logical, optional :: do_aitacc_transfer_in - -#ifdef MODAL_AERO - - ! local - - logical :: do_adjust - logical :: do_aitacc_transfer - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of columns - - real(r8), pointer :: t(:,:) ! Temperature in Kelvin - real(r8), pointer :: pmid(:,:) ! pressure at model levels (Pa) - real(r8), pointer :: pdel(:,:) ! pressure thickness of levels - real(r8), pointer :: q(:,:,:) ! Tracer MR array - - logical, pointer :: dotend(:) ! flag for doing tendency - real(r8), pointer :: dqdt(:,:,:) ! TMR tendency array - - real(r8), pointer :: dgncur_a(:,:,:) - - integer :: i, icol_diag, iduma, ipair, iq + ! Grid and time arguments + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: pver ! number of vertical levels + real(r8), intent(in) :: deltat ! model time-step size (s) + integer, intent(in) :: top_lev ! top level for aerosol calculations + + ! Mode dimension arguments + integer, intent(in) :: ntot_amode ! total number of aerosol modes + integer, intent(in) :: nspec_amode(:) ! number of species per mode (ntot_amode) + integer, intent(in) :: nspec_max ! max number of species in any mode + + ! Mode geometry + real(r8), intent(in) :: dgnum_amode(:) ! default geometric mean diameter (ntot_amode) + real(r8), intent(in) :: dgnumlo_amode(:) ! lower bound dgnum (ntot_amode) + real(r8), intent(in) :: dgnumhi_amode(:) ! upper bound dgnum (ntot_amode) + + ! Derived mode quantities + real(r8), intent(in) :: alnsg_amode(:) ! ln(sigmag) for each mode (ntot_amode) + real(r8), intent(in) :: voltonumb_amode(:) ! volume-to-number (ntot_amode) + real(r8), intent(in) :: voltonumblo_amode(:) ! vol-to-num at dgnumlo (ntot_amode) + real(r8), intent(in) :: voltonumbhi_amode(:) ! vol-to-num at dgnumhi (ntot_amode) + + ! Species densities + real(r8), intent(in) :: specdens_amode(:,:) ! species densities (nspec_max,ntot_amode) + + ! Prognostic number flags + integer, intent(in) :: mprognum_amode(:) ! prognostic number flag (ntot_amode) + + ! Mode pointers + integer, intent(in) :: modeptr_aitken ! index of aitken mode + integer, intent(in) :: modeptr_accum ! index of accumulation mode + + ! Species-to-q index maps (interstitial) + integer, intent(in) :: lmassptr_amode(:,:) ! mass species pointer (nspec_max,ntot_amode) + integer, intent(in) :: numptr_amode(:) ! number species pointer (ntot_amode) + + ! Species-to-q_cw index maps (cloud-borne) + integer, intent(in) :: lmassptrcw_amode(:,:) ! cloud-borne mass species pointer (nspec_max,ntot_amode) + integer, intent(in) :: numptrcw_amode(:) ! cloud-borne number species pointer (ntot_amode) + + ! Atmospheric state + real(r8), intent(in) :: pdel(:,:) ! pressure thickness (ncol,pver) + + ! Physical constants + real(r8), intent(in) :: gravit ! gravitational acceleration + real(r8), intent(in) :: pi ! pi + + ! Species arrays + integer, intent(in) :: num_q ! number of species (dimension of q/q_cw) + real(r8), intent(in) :: q(:,:,:) ! interstitial species (ncol,pver,num_q) + real(r8), intent(in) :: q_cw(:,:,:) ! cloud-borne species (ncol,pver,num_q) + + ! Control flags + logical, intent(in) :: do_adjust ! adjust number to size bounds + logical, intent(in) :: do_aitacc_transfer ! aitken<-->accum transfer + + ! Rename transfer data (only used when do_aitacc_transfer=.true.) + integer, intent(in) :: npair_renamexf ! number of rename pairs + integer, intent(in) :: nspecfrm_renamexf(:) ! species count per pair + integer, intent(in) :: modefrm_renamexf(:) ! from mode index per pair + integer, intent(in) :: modetoo_renamexf(:) ! to mode index per pair + integer, intent(in) :: lspecfrma_renamexf(:,:) ! interstitial from species indices + integer, intent(in) :: lspectooa_renamexf(:,:) ! interstitial to species indices + integer, intent(in) :: lspecfrmc_renamexf(:,:) ! cloud-borne from species indices + integer, intent(in) :: lspectooc_renamexf(:,:) ! cloud-borne to species indices + + ! Outputs + real(r8), intent(inout) :: dgncur_a(:,:,:) ! dry diameter (ncol,pver,ntot_amode) + real(r8), intent(out) :: dqdt(:,:,:) ! interstitial tendencies (ncol,pver,num_q) + real(r8), intent(out) :: dqdt_cw(:,:,:) ! cloud-borne tendencies (ncol,pver,num_q) + logical, intent(out) :: dotend(:) ! which species have interstitial tendencies (num_q) + logical, intent(out) :: dotend_cw(:) ! which species have cloud-borne tendencies (num_q) + real(r8), intent(out) :: qsrflx(:,:,:,:) ! diagnostic flux (ncol,num_q,calcsize_nsrflx,2) + + ! CCPP error reporting + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: i, ipair, iq integer :: ixfer_acc2ait, ixfer_ait2acc - integer :: ixfer_acc2ait_sv(pcols,pver), ixfer_ait2acc_sv(pcols,pver) - integer :: j, jac, jsrflx, k + integer :: j, jac, jsrflx, k integer :: l, l1, la, lc, lna, lnc, lsfrm, lstoo integer :: n, nacc, nait - integer, save :: idiagaa = 1 - - logical :: dotendqqcw(pcnst) logical :: noxf_acc2ait(nspec_max) - character(len=fieldname_len) :: tmpnamea, tmpnameb - character(len=fieldname_len+3) :: fieldname - real(r8), parameter :: third = 1.0_r8/3.0_r8 - real(r8), pointer :: fldcw(:,:) real(r8) :: delnum_a2, delnum_c2 ! work variables real(r8) :: delnum_a3, delnum_c3, delnum_t3 ! work variables real(r8) :: deltatinv ! 1/deltat - real(r8) :: dgncur_c(pcols,pver,ntot_amode) + real(r8) :: dgncur_c(ncol,pver,ntot_amode) real(r8) :: dgnyy, dgnxx ! dgnumlo/hi of current mode - real(r8) :: dqqcwdt(pcols,pver,pcnst) ! cloudborne TMR tendency array real(r8) :: drv_a, drv_c, drv_t ! dry volume (cm3/mol_air) real(r8) :: drv_t0 - real(r8) :: drv_a_noxf, drv_c_noxf, drv_t_noxf + real(r8) :: drv_a_noxf, drv_c_noxf, drv_t_noxf real(r8) :: drv_a_acc, drv_c_acc - real(r8) :: drv_a_accsv(pcols,pver), drv_c_accsv(pcols,pver) - real(r8) :: drv_a_aitsv(pcols,pver), drv_c_aitsv(pcols,pver) - real(r8) :: drv_a_sv(pcols,pver,ntot_amode), drv_c_sv(pcols,pver,ntot_amode) - real(r8) :: dryvol_a(pcols,pver) ! interstital aerosol dry + real(r8) :: drv_a_accsv(ncol,pver), drv_c_accsv(ncol,pver) + real(r8) :: drv_a_aitsv(ncol,pver), drv_c_aitsv(ncol,pver) + real(r8) :: drv_a_sv(ncol,pver,ntot_amode), drv_c_sv(ncol,pver,ntot_amode) + real(r8) :: dryvol_a(ncol,pver) ! interstital aerosol dry ! volume (cm^3/mol_air) - real(r8) :: dryvol_c(pcols,pver) ! activated aerosol dry volume + real(r8) :: dryvol_c(ncol,pver) ! activated aerosol dry volume real(r8) :: duma, dumb, dumc, dumd ! work variables real(r8) :: dumfac, dummwdens ! work variables real(r8) :: frelaxadj ! relaxation factor applied @@ -360,16 +170,16 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ real(r8) :: num_t_noxf real(r8) :: numbnd ! bounded number real(r8) :: num_a_acc, num_c_acc - real(r8) :: num_a_accsv(pcols,pver), num_c_accsv(pcols,pver) - real(r8) :: num_a_aitsv(pcols,pver), num_c_aitsv(pcols,pver) - real(r8) :: num_a_sv(pcols,pver,ntot_amode), num_c_sv(pcols,pver,ntot_amode) - real(r8) :: pdel_fac ! + real(r8) :: num_a_accsv(ncol,pver), num_c_accsv(ncol,pver) + real(r8) :: num_a_aitsv(ncol,pver), num_c_aitsv(ncol,pver) + real(r8) :: num_a_sv(ncol,pver,ntot_amode), num_c_sv(ncol,pver,ntot_amode) + real(r8) :: pdel_fac ! real(r8) :: tadj ! adjustment time scale real(r8) :: tadjinv ! 1/tadj - real(r8) :: v2ncur_a(pcols,pver,ntot_amode) - real(r8) :: v2ncur_c(pcols,pver,ntot_amode) + real(r8) :: v2ncur_a(ncol,pver,ntot_amode) + real(r8) :: v2ncur_c(ncol,pver,ntot_amode) real(r8) :: v2nyy, v2nxx, v2nzz ! voltonumblo/hi of current mode - real(r8) :: v2nyyrl, v2nxxrl ! relaxed voltonumblo/hi + real(r8) :: v2nyyrl, v2nxxrl ! relaxed voltonumblo/hi real(r8) :: xfercoef real(r8) :: xfercoef_num_acc2ait, xfercoef_vol_acc2ait real(r8) :: xfercoef_num_ait2acc, xfercoef_vol_ait2acc @@ -377,44 +187,23 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ real(r8) :: xferfrac_num_ait2acc, xferfrac_vol_ait2acc real(r8) :: xfertend, xfertend_num(2,2) - integer, parameter :: nsrflx = 4 ! last dimension of qsrflx - real(r8) :: qsrflx(pcols,pcnst,nsrflx,2) - ! process-specific column tracer tendencies - ! 3rd index -- - ! 1="standard" number adjust gain; - ! 2="standard" number adjust loss; - ! 3=aitken-->accum renaming; 4=accum-->aitken) - ! 4th index -- - ! 1="a" species; 2="c" species + integer :: ixfer_acc2ait_sv(ncol,pver), ixfer_ait2acc_sv(ncol,pver) !----------------------------------------------------------------------- - if (present(do_adjust_in)) then - do_adjust = do_adjust_in - else - do_adjust = do_adjust_default - end if - - if (present(do_aitacc_transfer_in)) then - do_aitacc_transfer = do_aitacc_transfer_in - else - do_aitacc_transfer = do_aitacc_transfer_default - end if - - lchnk = state%lchnk - ncol = state%ncol - - t => state%t - pmid => state%pmid - pdel => state%pdel - q => state%q - - dotend => ptend%lq - dqdt => ptend%q - - call pbuf_get_field(pbuf, dgnum_idx, dgncur_a) - - dotendqqcw(:) = .false. - dqqcwdt(:,:,:) = 0.0_r8 + errmsg = '' + errflg = 0 + + ! Initialize outputs. + ! + ! Note on dgncur_a: it is intent(inout) and is backed by the pbuf (CAM) or + ! non-advected constituent (SIMA) field; levels above top_lev are not modified here. + ! It is initialized to zero or a copy of the per-mode diameter when calcsize_diag + ! called by radiation for diagnostic lists when that is active. + ! So it should not be initialized as part of the other (pure out) variables here. + dotend(:) = .false. + dotend_cw(:) = .false. + dqdt(:,:,:) = 0.0_r8 + dqdt_cw(:,:,:) = 0.0_r8 qsrflx(:,:,:,:) = 0.0_r8 nait = modeptr_aitken @@ -430,7 +219,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ fracadj = deltat*tadjinv fracadj = max( 0.0_r8, min( 1.0_r8, fracadj ) ) - + ! ! ! the "do 40000" loop does the original (pre jan-2006) @@ -440,8 +229,6 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ ! ! do n = 1, ntot_amode - - ! initialize all parameters to the default values for the mode do k=top_lev,pver do i=1,ncol @@ -456,7 +243,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ end do end do - ! compute dry volume mixrats = + ! compute dry volume mixrats = ! sum_over_components{ component_mass mixrat / density } do l1 = 1, nspec_amode(n) ! need qmass*dummwdens = (kg/kg-air) * [1/(kg/m3)] = m3/kg-air @@ -469,11 +256,11 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ end do end do - fldcw => qqcw_get_field(pbuf,lmassptrcw_amode(l1,n),lchnk) + lc = lmassptrcw_amode(l1,n) do k=top_lev,pver do i=1,ncol dryvol_c(i,k) = dryvol_c(i,k) & - + max(0.0_r8,fldcw(i,k))*dummwdens + + max(0.0_r8,q_cw(i,k,lc))*dummwdens end do end do end do @@ -481,7 +268,6 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ ! set "short-hand" number pointers lna = numptr_amode(n) lnc = numptrcw_amode(n) - fldcw => qqcw_get_field(pbuf,numptrcw_amode(n),lchnk,.true.) ! go to section for appropriate number/surface diagnosed/prognosed options @@ -501,17 +287,15 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ end do end if if (lnc > 0) then - dotendqqcw(lnc) = .true. + dotend_cw(lnc) = .true. do k=top_lev,pver do i=1,ncol - dqqcwdt(i,k,lnc) = (dryvol_c(i,k)*voltonumb_amode(n) & - - fldcw(i,k)) * deltatinv + dqdt_cw(i,k,lnc) = (dryvol_c(i,k)*voltonumb_amode(n) & + - q_cw(i,k,lnc)) * deltatinv end do end do end if else - - ! ! option 2 -- number prognosed (variable dgnum, fixed sigmag) ! Compute number tendencies to adjust numbers if they are outside @@ -526,12 +310,12 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ ! number towards the primary bounds. ! ! note - ! v2nyy = voltonumblo_amode is proportional to dgnumlo**(-3), + ! v2nyy = voltonumblo_amode is proportional to dgnumlo**(-3), ! and produces the maximum allowed number for a given volume - ! v2nxx = voltonumbhi_amode is proportional to dgnumhi**(-3), + ! v2nxx = voltonumbhi_amode is proportional to dgnumhi**(-3), ! and produces the minimum allowed number for a given volume - ! v2nxxrl and v2nyyrl are their "relaxed" equivalents. - ! Setting frelaxadj=27=3**3 means that + ! v2nxxrl and v2nyyrl are their "relaxed" equivalents. + ! Setting frelaxadj=27=3**3 means that ! dgnumlo_relaxed = dgnumlo/3 and dgnumhi_relaxed = dgnumhi*3 ! ! if do_aitacc_transfer is .true., then @@ -542,7 +326,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ !OLD however, do not change the v2nyyrl/v2nxxrl so that !OLD the interstitial<-->activated adjustment is not changed !NEW also change the v2nyyrl/v2nxxrl so that - !NEW the interstitial<-->activated adjustment is turned off + !NEW the interstitial<-->activated adjustment is turned off ! end if frelaxadj = 27.0_r8 @@ -562,7 +346,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ if (do_adjust) then dotend(lna) = .true. - dotendqqcw(lnc) = .true. + dotend_cw(lnc) = .true. end if do k = top_lev, pver @@ -572,10 +356,10 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ num_a0 = q(i,k,lna) num_a = max( 0.0_r8, num_a0 ) drv_c = dryvol_c(i,k) - num_c0 = fldcw(i,k) + num_c0 = q_cw(i,k,lnc) num_c = max( 0.0_r8, num_c0 ) - if ( do_adjust) then + if (do_adjust) then ! ! do number adjustment for interstitial and activated particles @@ -590,12 +374,12 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ num_a = 0.0_r8 dqdt(i,k,lna) = -num_a0*deltatinv num_c = 0.0_r8 - dqqcwdt(i,k,lnc) = -num_c0*deltatinv + dqdt_cw(i,k,lnc) = -num_c0*deltatinv else if (drv_c <= 0.0_r8) then ! activated volume is zero, so interstitial number/volume == total/combined ! apply step 1 and 3, but skip the relaxed adjustment (step 2, see below) num_c = 0.0_r8 - dqqcwdt(i,k,lnc) = -num_c0*deltatinv + dqdt_cw(i,k,lnc) = -num_c0*deltatinv num_a1 = num_a numbnd = max( drv_a*v2nxx, min( drv_a*v2nyy, num_a1 ) ) num_a = num_a1 + (numbnd - num_a1)*fracadj @@ -608,7 +392,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ num_c1 = num_c numbnd = max( drv_c*v2nxx, min( drv_c*v2nyy, num_c1 ) ) num_c = num_c1 + (numbnd - num_c1)*fracadj - dqqcwdt(i,k,lnc) = (num_c - num_c0)*deltatinv + dqdt_cw(i,k,lnc) = (num_c - num_c0)*deltatinv else ! both volumes are positive ! apply 3 adjustment steps @@ -632,7 +416,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ num_c2 = max( drv_c*v2nxxrl, min( drv_c*v2nyyrl, & num_c1-delnum_a2 ) ) end if - ! step3: num_a,c2 --> num_a,c3 applies stricter bounds to the + ! step3: num_a,c2 --> num_a,c3 applies stricter bounds to the ! combined/total number drv_t = drv_a + drv_c num_t2 = num_a2 + num_c2 @@ -666,7 +450,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ num_a = num_a2 + delnum_a3 dqdt(i,k,lna) = (num_a - num_a0)*deltatinv num_c = num_c2 + delnum_c3 - dqqcwdt(i,k,lnc) = (num_c - num_c0)*deltatinv + dqdt_cw(i,k,lnc) = (num_c - num_c0)*deltatinv end if end if ! do_adjust @@ -704,8 +488,8 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ end if end if jac = 2 - qsrflx(i,lnc,1,jac) = qsrflx(i,lnc,1,jac) + max(0.0_r8,dqqcwdt(i,k,lnc))*pdel_fac - qsrflx(i,lnc,2,jac) = qsrflx(i,lnc,2,jac) + min(0.0_r8,dqqcwdt(i,k,lnc))*pdel_fac + qsrflx(i,lnc,1,jac) = qsrflx(i,lnc,1,jac) + max(0.0_r8,dqdt_cw(i,k,lnc))*pdel_fac + qsrflx(i,lnc,2,jac) = qsrflx(i,lnc,2,jac) + min(0.0_r8,dqdt_cw(i,k,lnc))*pdel_fac ! save number and dryvol for aitken <--> accum renaming @@ -740,8 +524,8 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ ! ! - ! the following section (from here to label 49000) - ! does aitken <--> accum mode transfer + ! the following section + ! does aitken <--> accum mode transfer ! ! when the aitken mode mean size is too big, the largest ! aitken particles are transferred into the accum mode @@ -755,27 +539,19 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ 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 + errmsg = 'modal_aero_calcsize_run error -- npair_renamexf <= 0' + errflg = 1 + return end if ! 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_sub error -- ', & - 'modefrm/too_renamexf(1) are wrong' - call endrun( 'modal_aero_calcaersize_sub error' ) + errmsg = 'modal_aero_calcsize_run error -- modefrm/too_renamexf(1) are wrong' + errflg = 1 + return end if ! set dotend() for species that will be transferred @@ -789,8 +565,8 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ lsfrm = lspecfrmc_renamexf(iq,ipair) lstoo = lspectooc_renamexf(iq,ipair) if ((lsfrm > 0) .and. (lstoo > 0)) then - dotendqqcw(lsfrm) = .true. - dotendqqcw(lstoo) = .true. + dotend_cw(lsfrm) = .true. + dotend_cw(lstoo) = .true. end if end do @@ -854,8 +630,8 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ ! compute accum --> aitken transfer rates ! accum may have some species (seasalt, dust, poa, lll) that are ! not in aitken mode - ! so first divide the accum drv & num into not-transferred (noxf) species - ! and transferred species, and use the transferred-species + ! so first divide the accum drv & num into not-transferred (noxf) species + ! and transferred species, and use the transferred-species ! portion in what follows ixfer_acc2ait = 0 xfercoef_num_acc2ait = 0.0_r8 @@ -876,10 +652,9 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ drv_a_noxf = drv_a_noxf & + max(0.0_r8,q(i,k,la))*dummwdens lc = lmassptrcw_amode(l1,nacc) - - fldcw => qqcw_get_field(pbuf,lmassptrcw_amode(l1,nacc),lchnk) + drv_c_noxf = drv_c_noxf & - + max(0.0_r8,fldcw(i,k))*dummwdens + + max(0.0_r8,q_cw(i,k,lc))*dummwdens end if end do drv_t_noxf = drv_a_noxf + drv_c_noxf @@ -969,7 +744,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ dgncur_a(i,k,n) = dgnum_amode(n) v2ncur_a(i,k,n) = voltonumb_amode(n) end if - + if (drv_c > 0.0_r8) then if (num_c <= drv_c*voltonumbhi_amode(n)) then dgncur_c(i,k,n) = dgnumhi_amode(n) @@ -992,40 +767,8 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ ! ! compute tendency amounts for aitken <--> accum transfer ! - - if ( masterproc ) then - if (idiagaa > 0) then - do j = 1, 2 - do iq = 1, nspecfrm_renamexf(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) - else - lsfrm = lspecfrmc_renamexf(iq,ipair) - lstoo = lspectooc_renamexf(iq,ipair) - end if - else - if (jac .eq. 1) then - lsfrm = lspectooa_renamexf(iq,ipair) - lstoo = lspecfrma_renamexf(iq,ipair) - else - lsfrm = lspectooc_renamexf(iq,ipair) - lstoo = lspecfrmc_renamexf(iq,ipair) - end if - end if - write( 6, '(a,3i3,2i4)' ) 'calcsize j,iq,jac, lsfrm,lstoo', & - j,iq,jac, lsfrm,lstoo - end do - end do - end do - end if - end if - idiagaa = -1 - - ! j=1 does aitken-->accum; j=2 does accum-->aitken + ! j=1 does aitken-->accum; j=2 does accum-->aitken do j = 1, 2 if ((j .eq. 1 .and. ixfer_ait2acc > 0) .or. & @@ -1040,7 +783,7 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ do iq = 1, nspecfrm_renamexf(ipair) - ! jac=1 does interstitial ("_a"); jac=2 does activated ("_c"); + ! jac=1 does interstitial ("_a"); jac=2 does activated ("_c"); do jac = 1, 2 ! the lspecfrma_renamexf (and lspecfrmc_renamexf) are aitken species @@ -1078,11 +821,10 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ if (iq .eq. 1) then xfertend = xfertend_num(j,jac) else - fldcw => qqcw_get_field(pbuf,lsfrm,lchnk) - xfertend = max(0.0_r8,fldcw(i,k))*xfercoef + xfertend = max(0.0_r8,q_cw(i,k,lsfrm))*xfercoef end if - dqqcwdt(i,k,lsfrm) = dqqcwdt(i,k,lsfrm) - xfertend - dqqcwdt(i,k,lstoo) = dqqcwdt(i,k,lstoo) + xfertend + dqdt_cw(i,k,lsfrm) = dqdt_cw(i,k,lsfrm) - xfertend + dqdt_cw(i,k,lstoo) = dqdt_cw(i,k,lstoo) + xfertend end if qsrflx(i,lsfrm,jsrflx,jac) = qsrflx(i,lsfrm,jsrflx,jac) - xfertend*pdel_fac qsrflx(i,lstoo,jsrflx,jac) = qsrflx(i,lstoo,jsrflx,jac) + xfertend*pdel_fac @@ -1098,151 +840,214 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ end do - end if ! do_aitacc_transfer + end if ! do_aitacc_transfer lsfrm = -123456789 ! executable statement for debugging +end subroutine modal_aero_calcsize_run - ! - ! apply tendencies to cloud-borne species MRs - ! - do l = 1, pcnst - lc = l - if ( lc>0 .and. dotendqqcw(lc) ) then - fldcw=> qqcw_get_field(pbuf,l,lchnk) - do k = top_lev, pver - do i = 1, ncol - fldcw(i,k) = max( 0.0_r8, & - (fldcw(i,k) + dqqcwdt(i,k,lc)*deltat) ) - end do - end do - end if - end do +!=============================================================================== - ! - ! do outfld calls - ! +subroutine modal_aero_calcdry_run( & + aero_props, aero_state, & + ncol, pver, top_lev, & + do_strat_sulfate, & + pi, & + dgncur_a, & + hygro, dryvol, dryrad, drymass, so4dryvol, naer, & + errmsg, errflg) + +!----------------------------------------------------------------------- +! +! Compute derived dry aerosol properties from mixing ratios and +! adjusted number mode diameter. Called after calcsize_run. +! +!----------------------------------------------------------------------- + + use aerosol_properties_mod, only: aerosol_properties + use aerosol_state_mod, only: aerosol_state + + ! Arguments + class(aerosol_properties), intent(in) :: aero_props + class(aerosol_state), intent(in) :: aero_state + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: pver ! number of vertical levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + logical, intent(in) :: do_strat_sulfate ! use stratospheric sulfate treatment + real(r8), intent(in) :: pi ! pi + real(r8), intent(in) :: dgncur_a(:,:,:) ! dry number mode diameter (m) + + real(r8), intent(out) :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) + real(r8), intent(out) :: dryvol(:,:,:) ! single-particle-mean dry volume (m3) + real(r8), intent(out) :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) + real(r8), intent(out) :: drymass(:,:,:) ! single-particle-mean dry mass (kg) + real(r8), intent(out) :: so4dryvol(:,:,:) ! single-particle-mean so4 dry volume (m3) + real(r8), intent(out) :: naer(:,:,:) ! aerosol number MR (#/kg-air) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(r8), parameter :: third = 1._r8/3._r8 + real(r8) :: pi43 - ! history fields for number-adjust source-sink for all modes - if ( .not. do_adjust ) return - - do n = 1, ntot_amode - if (mprognum_amode(n) <= 0) cycle - - do jac = 1, 2 - if (jac == 1) then - l = numptr_amode(n) - tmpnamea = cnst_name(l) - else - l = numptrcw_amode(n) - tmpnamea = cnst_name_cw(l) - end if - fieldname = trim(tmpnamea) // '_sfcsiz1' - call outfld( fieldname, qsrflx(:,l,1,jac), pcols, lchnk) - - fieldname = trim(tmpnamea) // '_sfcsiz2' - call outfld( fieldname, qsrflx(:,l,2,jac), pcols, lchnk) - end do ! jac = ... + integer :: i, k, l, m + integer :: nmodes, nspec + + real(r8) :: specdens + real(r8) :: spechygro, spechygro_1 + real(r8) :: sigmag + real(r8) :: duma, dumb + real(r8) :: alnsg + + real(r8) :: v2ncur_a + real(r8) :: drydens ! dry particle density (kg/m^3) - end do ! n = ... + real(r8) :: maer(ncol, pver) + real(r8) :: dryvolmr(ncol, pver) + real(r8) :: so4dryvolmr(ncol, pver) + character(len=32) :: spectype - ! history fields for aitken-accum transfer - if ( .not. do_aitacc_transfer ) return + real(r8), pointer :: raer(:,:) + !----------------------------------------------------------------------- - do iq = 1, nspecfrm_renamexf(ipair) + errmsg = '' + errflg = 0 - ! jac=1 does interstitial ("_a"); jac=2 does activated ("_c"); - do jac = 1, 2 + pi43 = pi*4._r8/3._r8 - ! 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 - - if (jac .eq. 1) then - tmpnamea = cnst_name(lsfrm) - tmpnameb = cnst_name(lstoo) - else - tmpnamea = cnst_name_cw(lsfrm) - tmpnameb = cnst_name_cw(lstoo) + nmodes = aero_props%nbins() + + hygro(:,:,:) = 0._r8 + so4dryvol(:,:,:) = 0._r8 + + do m = 1, nmodes + + maer(:,:) = 0._r8 + dryvolmr(:,:) = 0._r8 + so4dryvolmr(:,:) = 0._r8 + + ! get mode properties + sigmag = exp(aero_props%alogsig(m)) + + ! get mode info + nspec = aero_props%nspecies(m) + + do l = 1, nspec + + ! get species interstitial mixing ratio ('a') + call aero_state%get_ambient_mmr(species_ndx=l, bin_ndx=m, mmr=raer) + call aero_props%get(m, l, density=specdens, & + hygro=spechygro, spectype=spectype) + + if (l == 1) then + ! save off these values to be used as defaults + spechygro_1 = spechygro end if - if ((lsfrm <= 0) .or. (lstoo <= 0)) cycle - fieldname = trim(tmpnamea) // '_sfcsiz3' - call outfld( fieldname, qsrflx(:,lsfrm,3,jac), pcols, lchnk) + do k = top_lev, pver + do i = 1, ncol + duma = raer(i,k) ! kg/kg air + maer(i,k) = maer(i,k) + duma + dumb = duma/specdens ! m3/kg air + dryvolmr(i,k) = dryvolmr(i,k) + dumb + if (do_strat_sulfate .and. (trim(spectype).eq.'sulfate')) then + so4dryvolmr(i,k) = so4dryvolmr(i,k) + dumb + end if + hygro(i,k,m) = hygro(i,k,m) + dumb*spechygro + end do + end do + end do - fieldname = trim(tmpnameb) // '_sfcsiz3' - call outfld( fieldname, qsrflx(:,lstoo,3,jac), pcols, lchnk) + alnsg = log(sigmag) - fieldname = trim(tmpnamea) // '_sfcsiz4' - call outfld( fieldname, qsrflx(:,lsfrm,4,jac), pcols, lchnk) + do k = top_lev, pver + do i = 1, ncol - fieldname = trim(tmpnameb) // '_sfcsiz4' - call outfld( fieldname, qsrflx(:,lstoo,4,jac), pcols, lchnk) + if (dryvolmr(i,k) > 1.0e-30_r8) then + hygro(i,k,m) = hygro(i,k,m)/dryvolmr(i,k) + else + hygro(i,k,m) = spechygro_1 + end if - end do ! jac = ... - end do ! iq = ... + ! dry aerosol properties - call modal_aero_calcdry(state, pbuf, aero_props, aero_state) + v2ncur_a = 1._r8 / ( (pi/6._r8)*(dgncur_a(i,k,m)**3._r8)*exp(4.5_r8*alnsg**2._r8) ) + ! naer = aerosol number (#/kg) + naer(i,k,m) = dryvolmr(i,k)*v2ncur_a -#endif + ! compute mean (1 particle) dry volume and mass for each mode + if (maer(i,k) .gt. 1.0e-31_r8) then + drydens = maer(i,k)/dryvolmr(i,k) ! kg/m3 aerosol + else + drydens = 1.0_r8 + end if + dryvol(i,k,m) = 1.0_r8/v2ncur_a ! m3/particle + drymass(i,k,m) = drydens*dryvol(i,k,m) ! kg/particle + dryrad(i,k,m) = (dryvol(i,k,m)/pi43)**third ! m + end do ! i = 1, ncol + end do ! k = top_lev, pver + + + if (do_strat_sulfate) then + do k = top_lev, pver + do i = 1, ncol + if (so4dryvolmr(i,k) .gt. 1.0e-31_r8) then + so4dryvol(i,k,m) = dryvol(i,k,m)*so4dryvolmr(i,k)/dryvolmr(i,k) + else + so4dryvol(i,k,m) = 0.0_r8 + end if + + end do ! i = 1, ncol + end do ! k = top_lev, pver -end subroutine modal_aero_calcsize_sub - + end if -!---------------------------------------------------------------------- + end do ! m = 1, nmodes +end subroutine modal_aero_calcdry_run -subroutine modal_aero_calcsize_diag(state, pbuf, aero_props, aero_state, dgnum_m, & - hygro_m, dryvol_m, dryrad_m, drymass_m, so4dryvol_m, naer_m) +subroutine modal_aero_calcsize_diag_run( & + aero_props, aero_state, & + ncol, pver, top_lev, & + pi, & + dgncur_a, & + errmsg, errflg) !----------------------------------------------------------------------- ! - ! Calculate aerosol size distribution parameters + ! Calculate aerosol size distribution parameters for a diagnostic + ! radiation list, using only the abstract aerosol interfaces. + ! Number is diagnosed from mass, Dgnum bounds, and fixed sigmag + ! (the mprognum <= 0 branch of the prognostic calculation). ! - ! ***N.B.*** DGNUM for the modes in the climate list are put directly into - ! the physics buffer. For diagnostic list calculations use the - ! optional dgnum_m args. !----------------------------------------------------------------------- - ! arguments - type(physics_state), intent(in), target :: state ! Physics state variables - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - class(aerosol_properties), intent(in), target :: aero_props - class(aerosol_state), intent(in), target :: aero_state - - real(r8), optional, pointer :: dgnum_m(:,:,:) ! interstital aerosol dry number mode radius (m) - real(r8), optional, pointer :: hygro_m(:,:,:) - real(r8), optional, pointer :: dryvol_m(:,:,:) - real(r8), optional, pointer :: dryrad_m(:,:,:) - real(r8), optional, pointer :: drymass_m(:,:,:) - real(r8), optional, pointer :: so4dryvol_m(:,:,:) - real(r8), optional, pointer :: naer_m(:,:,:) + use aerosol_properties_mod, only: aerosol_properties + use aerosol_state_mod, only: aerosol_state + ! Arguments + class(aerosol_properties), intent(in) :: aero_props + class(aerosol_state), intent(in) :: aero_state + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: pver ! number of vertical levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + real(r8), intent(in) :: pi ! pi + real(r8), intent(out) :: dgncur_a(:,:,:) ! dry number mode diameter (m) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! local integer :: i, k, l1, n - integer :: lchnk, ncol - integer :: list_idx, stat integer :: nmodes integer :: nspec - real(r8), pointer :: dgncur_a(:,:) ! (pcols,pver) - - real(r8), parameter :: third = 1.0_r8/3.0_r8 real(r8), pointer :: mode_num(:,:) ! mode number mixing ratio real(r8), pointer :: specmmr(:,:) ! specie mmr real(r8) :: specdens ! specie density - real(r8) :: dryvol_a(pcols,pver) ! interstital aerosol dry volume (cm^3/mol_air) + real(r8) :: dryvol_a(ncol,pver) ! interstital aerosol dry volume (cm^3/mol_air) real(r8) :: dgnum, dgnumhi, dgnumlo real(r8) :: dgnyy, dgnxx ! dgnumlo/hi of current mode @@ -1255,87 +1060,13 @@ subroutine modal_aero_calcsize_diag(state, pbuf, aero_props, aero_state, dgnum_m real(r8) :: sigmag, alnsg !----------------------------------------------------------------------- - lchnk = state%lchnk - ncol = state%ncol - - list_idx = aero_props%list_idx() + errmsg = '' + errflg = 0 nmodes = aero_props%nbins() - if (list_idx /= 0) then - if (.not. present(dgnum_m)) then - 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') - end if - - if (.not. present(hygro_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but hygro_m pointer not present') - end if - if (.not. associated(hygro_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but hygro_m not associated') - end if - - if (.not. present(dryvol_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but dryvol_m pointer not present') - end if - if (.not. associated(dryvol_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but dryvol_m not associated') - end if - - if (.not. present(dryrad_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but dryrad_m pointer not present') - end if - if (.not. associated(dryrad_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but dryrad_m not associated') - end if - - if (.not. present(drymass_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but drymass_m pointer not present') - end if - if (.not. associated(drymass_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but drymass_m not associated') - end if - - if (.not. present(so4dryvol_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but so4dryvol_m pointer not present') - end if - if (.not. associated(so4dryvol_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but so4dryvol_m not associated') - end if - - if (.not. present(naer_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but naer_m pointer not present') - end if - if (.not. associated(naer_m)) then - call endrun('modal_aero_calcsize_diag called for'// & - 'diagnostic list but naer_m not associated') - end if - - end if - do n = 1, nmodes - if (list_idx == 0) then - call pbuf_get_field(pbuf, dgnum_idx, dgncur_a, start=(/1,1,n/), kount=(/pcols,pver,1/)) - else - dgncur_a => dgnum_m(:,:,n) - end if - ! get mode properties dgnum = aero_props%dgnum(n) dgnumhi = aero_props%dgnumhi(n) @@ -1345,7 +1076,7 @@ subroutine modal_aero_calcsize_diag(state, pbuf, aero_props, aero_state, dgnum_m ! get mode number mixing ratio call aero_state%get_ambient_num(n, mode_num) - dgncur_a(:,:) = dgnum + dgncur_a(:,:,n) = dgnum dryvol_a(:,:) = 0.0_r8 ! compute dry volume mixrats = @@ -1385,11 +1116,11 @@ subroutine modal_aero_calcsize_diag(state, pbuf, aero_props, aero_state, dgnum_m if (drv_a > 0.0_r8) then if (num_a <= drv_a*v2nxx) then - dgncur_a(i,k) = dgnxx + dgncur_a(i,k,n) = dgnxx else if (num_a >= drv_a*v2nyy) then - dgncur_a(i,k) = dgnyy + dgncur_a(i,k,n) = dgnyy else - dgncur_a(i,k) = (drv_a/(dumfac*num_a))**third + dgncur_a(i,k,n) = (drv_a/(dumfac*num_a))**third end if end if @@ -1398,196 +1129,6 @@ subroutine modal_aero_calcsize_diag(state, pbuf, aero_props, aero_state, dgnum_m end do ! nmodes - call modal_aero_calcdry(state, pbuf, aero_props, aero_state, dgnum_m, hygro_m, dryvol_m, dryrad_m, drymass_m, so4dryvol_m, naer_m) - -end subroutine modal_aero_calcsize_diag - -subroutine modal_aero_calcdry(state, pbuf, aero_props, aero_state, dgnumdry_m, hygro_m, dryvol_m, dryrad_m, drymass_m, so4dryvol_m, naer_m) - - type(physics_state), target, intent(in) :: state ! Physics state variables - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - class(aerosol_properties), intent(in), target :: aero_props - class(aerosol_state), intent(in), target :: aero_state - real(r8), optional, pointer :: dgnumdry_m(:,:,:) - real(r8), optional, pointer :: hygro_m(:,:,:) - real(r8), optional, pointer :: dryvol_m(:,:,:) - real(r8), optional, pointer :: dryrad_m(:,:,:) - real(r8), optional, pointer :: drymass_m(:,:,:) - real(r8), optional, pointer :: so4dryvol_m(:,:,:) - real(r8), optional, pointer :: naer_m(:,:,:) - - real(r8), parameter :: third = 1._r8/3._r8 - real(r8), parameter :: pi43 = pi*4.0_r8/3.0_r8 - - real(r8), pointer :: maer(:,:) ! aerosol wet mass MR (including water) (kg/kg-air) - real(r8), pointer :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) - real(r8), pointer :: dryvol(:,:,:) ! single-particle-mean dry volume (m3) - real(r8), pointer :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) - real(r8), pointer :: drymass(:,:,:) ! single-particle-mean dry mass (kg) - real(r8), pointer :: so4dryvol(:,:,:) ! single-particle-mean so4 dry volume (m3) - real(r8), pointer :: naer(:,:,:) ! aerosol number MR (bounded!) (#/kg-air) - - real(r8), pointer :: dgncur_a(:,:,:) - real(r8), pointer :: raer(:,:) ! aerosol species MRs (kg/kg and #/kg) - - real(r8), pointer :: sulfeq(:,:,:) ! H2SO4 equilibrium mixing ratios over particles (mol/mol) - - real(r8) :: dryvolmr(pcols,pver) ! volume MR for aerosol mode (m3/kg) - real(r8) :: so4dryvolmr(pcols,pver) ! volume MR for sulfate aerosol in mode (m3/kg) - - real(r8) :: specdens - real(r8) :: spechygro, spechygro_1 - real(r8) :: sigmag - real(r8) :: duma, dumb - real(r8) :: alnsg - - real(r8) :: v2ncur_a - real(r8) :: drydens ! dry particle density (kg/m^3) - - character(len=fieldname_len+3) :: fieldname - character(len=32) :: spectype - - integer :: nmodes, lchnk, ncol, list_idx, i, k, l, m - integer :: nspec - - - - lchnk = state%lchnk - ncol = state%ncol - - list_idx = aero_props%list_idx() - - if (list_idx /= 0) then - ! check that all optional args are present - if (.not. present(dgnumdry_m)) then - call endrun('modal_aero_calcdry called for'// & - 'diagnostic list but required args not present') - end if - - ! arrays for diagnostic calculations must be associated - if (.not. associated(dgnumdry_m)) then - call endrun('modal_aero_calcdry called for'// & - 'diagnostic list but required args not associated') - end if - end if - - ! loop over all aerosol modes - nmodes = aero_props%nbins() - - allocate( maer(pcols,pver)) - - if (list_idx == 0) then - call pbuf_get_field(pbuf, dgnum_idx, dgncur_a ) - call pbuf_get_field(pbuf, hygro_idx, hygro) - call pbuf_get_field(pbuf, dryvol_idx, dryvol) - call pbuf_get_field(pbuf, dryrad_idx, dryrad) - call pbuf_get_field(pbuf, drymass_idx, drymass) - call pbuf_get_field(pbuf, so4dryvol_idx, so4dryvol) - call pbuf_get_field(pbuf, naer_idx, naer) - else - dgncur_a => dgnumdry_m - hygro => hygro_m - dryvol => dryvol_m - dryrad => dryrad_m - drymass => drymass_m - so4dryvol => so4dryvol_m - naer => naer_m - end if - - hygro(:,:,:) = 0._r8 - so4dryvol(:,:,:) = 0._r8 - - do m = 1, nmodes - - maer(:,:) = 0._r8 - dryvolmr(:,:) = 0._r8 - so4dryvolmr(:,:) = 0._r8 - - ! get mode properties - sigmag = exp(aero_props%alogsig(m)) - - ! get mode info - nspec = aero_props%nspecies(m) - - do l = 1, nspec - - ! get species interstitial mixing ratio ('a') - call aero_state%get_ambient_mmr(species_ndx=l, bin_ndx=m, mmr=raer) - call aero_props%get(m, l, density=specdens, & - hygro=spechygro, spectype=spectype) - - if (l == 1) then - ! save off these values to be used as defaults - spechygro_1 = spechygro - end if - - do k = top_lev, pver - do i = 1, ncol - duma = raer(i,k) ! kg/kg air - maer(i,k) = maer(i,k) + duma - dumb = duma/specdens ! m3/kg air - dryvolmr(i,k) = dryvolmr(i,k) + dumb - if (modal_strat_sulfate .and. (trim(spectype).eq.'sulfate')) then - so4dryvolmr(i,k) = so4dryvolmr(i,k) + dumb - end if - hygro(i,k,m) = hygro(i,k,m) + dumb*spechygro - end do - end do - end do - - alnsg = log(sigmag) - - do k = top_lev, pver - do i = 1, ncol - - if (dryvolmr(i,k) > 1.0e-30_r8) then - hygro(i,k,m) = hygro(i,k,m)/dryvolmr(i,k) - else - hygro(i,k,m) = spechygro_1 - end if - - ! dry aerosol properties - - v2ncur_a = 1._r8 / ( (pi/6._r8)*(dgncur_a(i,k,m)**3._r8)*exp(4.5_r8*alnsg**2._r8) ) - ! naer = aerosol number (#/kg) - naer(i,k,m) = dryvolmr(i,k)*v2ncur_a - - ! compute mean (1 particle) dry volume and mass for each mode - ! old coding is replaced because the new (1/v2ncur_a) is equal to - ! the mean particle volume - ! also moletomass forces maer >= 1.0e-30, so (maer/dryvolmr) - ! should never cause problems (but check for maer < 1.0e-31 anyway) - if (maer(i,k) .gt. 1.0e-31_r8) then - drydens = maer(i,k)/dryvolmr(i,k) ! kg/m3 aerosol - else - drydens = 1.0_r8 - end if - dryvol(i,k,m) = 1.0_r8/v2ncur_a ! m3/particle - drymass(i,k,m) = drydens*dryvol(i,k,m) ! kg/particle - dryrad(i,k,m) = (dryvol(i,k,m)/pi43)**third ! m - end do ! i = 1, ncol - end do ! k = top_lev, pver - - - if (modal_strat_sulfate) then - do k = top_lev, pver - do i = 1, ncol - if (so4dryvolmr(i,k) .gt. 1.0e-31_r8) then - so4dryvol(i,k,m) = dryvol(i,k,m)*so4dryvolmr(i,k)/dryvolmr(i,k) - else - so4dryvol(i,k,m) = 0.0_r8 - end if - - end do ! i = 1, ncol - end do ! k = top_lev, pver - - end if - - end do ! m = 1, nmodes - - deallocate( maer) - -end subroutine modal_aero_calcdry -!---------------------------------------------------------------------- +end subroutine modal_aero_calcsize_diag_run end module modal_aero_calcsize diff --git a/src/chemistry/utils/modal_aero_calcsize_cam.F90 b/src/chemistry/utils/modal_aero_calcsize_cam.F90 new file mode 100644 index 0000000000..d0cc864fd5 --- /dev/null +++ b/src/chemistry/utils/modal_aero_calcsize_cam.F90 @@ -0,0 +1,702 @@ +module modal_aero_calcsize_cam + +! CAM wrapper for modal_aero_calcsize. +! Handles pbuf registration, initialization, history output, +! state/ptend/qqcw marshaling, and calls the portable science +! routine modal_aero_calcsize_run. + +use shr_kind_mod, only: r8 => shr_kind_r8 +use spmd_utils, only: masterproc +use physconst, only: pi, rhoh2o, gravit + +use ppgrid, only: pcols, pver +use physics_types, only: physics_state, physics_ptend +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, & + pbuf_get_field, pbuf_add_field, pbuf_set_field, dtype_r8 + +use phys_control, only: phys_getopts +use aerosol_properties_mod, only: aerosol_properties +use aerosol_state_mod, only: aerosol_state + +use cam_logfile, only: iulog +use cam_abortutils, only: endrun +use cam_history, only: addfld, add_default, fieldname_len, horiz_only, outfld +use constituents, only: pcnst, cnst_name +use modal_aero_data, only: modal_strat_sulfate + +use ref_pres, only: top_lev => clim_modal_aero_top_lev + +#ifdef MODAL_AERO + +use modal_aero_data, only: ntot_amode, nspec_amode, nspec_max, & + numptr_amode, & + alnsg_amode, & + voltonumbhi_amode, voltonumblo_amode, & + dgnum_amode, dgnumhi_amode, dgnumlo_amode + +use modal_aero_data, only: numptrcw_amode, mprognum_amode, qqcw_get_field, lmassptrcw_amode, & + lmassptr_amode, modeptr_accum, modeptr_aitken, & + specmw_amode, specdens_amode, voltonumb_amode, & + cnst_name_cw + +use modal_aero_rename_cam, only: lspectooa_renamexf, lspecfrma_renamexf, lspectooc_renamexf, lspecfrmc_renamexf, & + modetoo_renamexf, nspecfrm_renamexf, npair_renamexf, modefrm_renamexf + +#endif + +use modal_aero_calcsize, only: modal_aero_calcsize_run, modal_aero_calcdry_run, calcsize_nsrflx + +implicit none +private +save + +public modal_aero_calcsize_init, modal_aero_calcsize_sub, modal_aero_calcsize_diag +public :: modal_aero_calcsize_reg + +logical :: do_adjust_default +logical :: do_aitacc_transfer_default + +integer :: dgnum_idx = -1 +integer :: hygro_idx = -1 +integer :: dryvol_idx = -1 +integer :: dryrad_idx = -1 +integer :: drymass_idx = -1 +integer :: so4dryvol_idx = -1 +integer :: naer_idx = -1 +integer :: sulfeq_idx = -1 + + +!=============================================================================== +contains +!=============================================================================== + +subroutine modal_aero_calcsize_reg() + use radiative_aerosol, only: rad_aer_get_info + + integer :: nmodes + + call rad_aer_get_info(0, nmodes=nmodes) + + call pbuf_add_field('DGNUM', 'global', dtype_r8, (/pcols, pver, nmodes/), dgnum_idx) + + call pbuf_add_field('HYGRO', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), hygro_idx) + call pbuf_add_field('DRYVOL', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), dryvol_idx) + call pbuf_add_field('DRYRAD', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), dryrad_idx) + call pbuf_add_field('DRYMASS', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), drymass_idx) + call pbuf_add_field('SO4DRYVOL', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), so4dryvol_idx) + call pbuf_add_field('NAER', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), naer_idx) + +end subroutine modal_aero_calcsize_reg + +!=============================================================================== +!=============================================================================== + +subroutine modal_aero_calcsize_init(pbuf2d) + use time_manager, only: is_first_step + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! set do_adjust_default and do_aitacc_transfer_default flags + ! create history fields for column tendencies associated with + ! modal_aero_calcsize + ! + ! Author: R. Easter + ! + !----------------------------------------------------------------------- + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + ! local + integer :: ipair, iq + integer :: jac + integer :: lsfrm, lstoo + integer :: n, nacc, nait + logical :: history_aerosol + + character(len=fieldname_len) :: tmpnamea, tmpnameb + character(len=fieldname_len+3) :: fieldname + character(128) :: long_name + character(8) :: unit + !----------------------------------------------------------------------- + + call phys_getopts(history_aerosol_out=history_aerosol) + + if (is_first_step()) then + call pbuf_set_field(pbuf2d, dgnum_idx, 0.0_r8) + endif + +#ifndef MODAL_AERO + do_adjust_default = .false. + do_aitacc_transfer_default = .false. +#else + do_adjust_default = .true. + + nait = modeptr_aitken + nacc = modeptr_accum + do_aitacc_transfer_default = .false. + if ((modeptr_aitken > 0) .and. & + (modeptr_accum > 0) .and. & + (modeptr_aitken /= modeptr_accum)) then + do_aitacc_transfer_default = .true. + if (mprognum_amode(nait) <= 0) do_aitacc_transfer_default = .false. + if (mprognum_amode(nacc) <= 0) do_aitacc_transfer_default = .false. + end if + + if ( .not. do_adjust_default ) return + + ! define history fields for number-adjust source-sink for all modes + do n = 1, ntot_amode + if (mprognum_amode(n) <= 0) cycle + + do jac = 1, 2 + if (jac == 1) then + tmpnamea = cnst_name(numptr_amode(n)) + else + tmpnamea = cnst_name_cw(numptrcw_amode(n)) + end if + unit = '#/m2/s' + fieldname = trim(tmpnamea) // '_sfcsiz1' + long_name = trim(tmpnamea) // ' calcsize number-adjust column source' + call addfld( fieldname, horiz_only, 'A', unit, long_name ) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + + fieldname = trim(tmpnamea) // '_sfcsiz2' + long_name = trim(tmpnamea) // ' calcsize number-adjust column sink' + call addfld( fieldname, horiz_only, 'A', unit, long_name ) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if ( masterproc ) write(*,'(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 iq = 1, nspecfrm_renamexf(ipair) + + ! jac=1 does interstitial ("_a"); jac=2 does activated ("_c"); + do jac = 1, 2 + + 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 + + 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, horiz_only, 'A', unit, long_name ) + 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, horiz_only, 'A', unit, long_name ) + 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, horiz_only, 'A', unit, long_name ) + 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, horiz_only, 'A', unit, long_name ) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + + end do ! jac = ... + end do ! iq = ... + +#endif + +end subroutine modal_aero_calcsize_init + +!=============================================================================== + +subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_state, & + do_adjust_in, do_aitacc_transfer_in) + + !----------------------------------------------------------------------- + ! CAM wrapper for modal_aero_calcsize_run. + ! Marshals state/ptend/pbuf/qqcw into explicit arrays, calls the + ! portable science routine, then applies tendencies and history output. + !----------------------------------------------------------------------- + + ! arguments + type(physics_state), target, intent(in) :: state + type(physics_ptend), target, intent(inout) :: ptend + real(r8), intent(in) :: deltat + type(physics_buffer_desc), pointer :: pbuf(:) + class(aerosol_properties), intent(in), target :: aero_props + class(aerosol_state), intent(in) :: aero_state + + logical, optional :: do_adjust_in + logical, optional :: do_aitacc_transfer_in + +#ifdef MODAL_AERO + + ! local + logical :: do_adjust + logical :: do_aitacc_transfer + + integer :: lchnk, ncol + integer :: i, ipair, iq, jac, k, l, lc, lsfrm, lstoo, n + real(r8), pointer :: dgncur_a(:,:,:) + real(r8), pointer :: fldcw(:,:) + + character(len=fieldname_len) :: tmpnamea, tmpnameb + character(len=fieldname_len+3) :: fieldname + + ! Work arrays for portable routine interface + real(r8), allocatable :: q_local(:,:,:) ! interstitial species (ncol,pver,pcnst) + real(r8), allocatable :: q_cw_local(:,:,:) ! cloud-borne species (ncol,pver,pcnst) + real(r8), allocatable :: dqdt_local(:,:,:) ! interstitial tendencies (ncol,pver,pcnst) + real(r8), allocatable :: dqdt_cw_local(:,:,:) ! cloud-borne tendencies (ncol,pver,pcnst) + logical, allocatable :: dotend_local(:) ! interstitial tendency flags (pcnst) + logical, allocatable :: dotend_cw_local(:) ! cloud-borne tendency flags (pcnst) + real(r8), allocatable :: qsrflx(:,:,:,:) ! diagnostic flux (ncol,pcnst,calcsize_nsrflx,2) + real(r8) :: qsrflx_pcols(pcols) ! work array for outfld + + character(len=512) :: errmsg + integer :: errflg + + !----------------------------------------------------------------------- + + if (present(do_adjust_in)) then + do_adjust = do_adjust_in + else + do_adjust = do_adjust_default + end if + + if (present(do_aitacc_transfer_in)) then + do_aitacc_transfer = do_aitacc_transfer_in + else + do_aitacc_transfer = do_aitacc_transfer_default + end if + + lchnk = state%lchnk + ncol = state%ncol + + ! Get dgnum from pbuf + call pbuf_get_field(pbuf, dgnum_idx, dgncur_a) + + ! Allocate work arrays + allocate(q_local(ncol, pver, pcnst)) + allocate(q_cw_local(ncol, pver, pcnst)) + allocate(dqdt_local(ncol, pver, pcnst)) + allocate(dqdt_cw_local(ncol, pver, pcnst)) + allocate(dotend_local(pcnst)) + allocate(dotend_cw_local(pcnst)) + allocate(qsrflx(ncol, pcnst, calcsize_nsrflx, 2)) + + ! Copy interstitial species from state%q + q_local(:,:,:) = state%q(:ncol,:,:) + + ! Gather cloud-borne species from qqcw into flat array + q_cw_local(:,:,:) = 0.0_r8 + do n = 1, ntot_amode + do l = 1, nspec_amode(n) + lc = lmassptrcw_amode(l,n) + if (lc > 0) then + fldcw => qqcw_get_field(pbuf, lc, lchnk) + if (associated(fldcw)) q_cw_local(:ncol,:,lc) = fldcw(:ncol,:) + end if + end do + lc = numptrcw_amode(n) + if (lc > 0) then + fldcw => qqcw_get_field(pbuf, lc, lchnk, .true.) + if (associated(fldcw)) q_cw_local(:ncol,:,lc) = fldcw(:ncol,:) + end if + end do + + ! Call portable science routine + call modal_aero_calcsize_run( & + ncol = ncol, & + pver = pver, & + deltat = deltat, & + top_lev = top_lev, & + ntot_amode = ntot_amode, & + nspec_amode = nspec_amode, & + nspec_max = nspec_max, & + dgnum_amode = dgnum_amode, & + dgnumlo_amode = dgnumlo_amode, & + dgnumhi_amode = dgnumhi_amode, & + alnsg_amode = alnsg_amode, & + voltonumb_amode = voltonumb_amode, & + voltonumblo_amode = voltonumblo_amode, & + voltonumbhi_amode = voltonumbhi_amode, & + specdens_amode = specdens_amode, & + mprognum_amode = mprognum_amode, & + modeptr_aitken = modeptr_aitken, & + modeptr_accum = modeptr_accum, & + lmassptr_amode = lmassptr_amode, & + numptr_amode = numptr_amode, & + lmassptrcw_amode = lmassptrcw_amode, & + numptrcw_amode = numptrcw_amode, & + pdel = state%pdel(:ncol,:), & + gravit = gravit, & + pi = pi, & + num_q = pcnst, & + q = q_local, & + q_cw = q_cw_local, & + do_adjust = do_adjust, & + do_aitacc_transfer = do_aitacc_transfer, & + npair_renamexf = npair_renamexf, & + nspecfrm_renamexf = nspecfrm_renamexf, & + modefrm_renamexf = modefrm_renamexf, & + modetoo_renamexf = modetoo_renamexf, & + lspecfrma_renamexf = lspecfrma_renamexf, & + lspectooa_renamexf = lspectooa_renamexf, & + lspecfrmc_renamexf = lspecfrmc_renamexf, & + lspectooc_renamexf = lspectooc_renamexf, & + dgncur_a = dgncur_a(:ncol,:,:), & + dqdt = dqdt_local, & + dqdt_cw = dqdt_cw_local, & + dotend = dotend_local, & + dotend_cw = dotend_cw_local, & + qsrflx = qsrflx, & + errmsg = errmsg, & + errflg = errflg) + + if (errflg /= 0) then + call endrun('modal_aero_calcsize_sub: ' // trim(errmsg)) + end if + + ! Apply interstitial tendencies to ptend + do l = 1, pcnst + if (dotend_local(l)) then + ptend%lq(l) = .true. + ptend%q(:ncol,:,l) = dqdt_local(:,:,l) + end if + end do + + ! Apply cloud-borne tendencies to qqcw pbuf fields + do l = 1, pcnst + if (dotend_cw_local(l)) then + fldcw => qqcw_get_field(pbuf, l, lchnk) + if (associated(fldcw)) then + do k = top_lev, pver + do i = 1, ncol + fldcw(i,k) = max( 0.0_r8, & + (fldcw(i,k) + dqdt_cw_local(i,k,l)*deltat) ) + end do + end do + end if + end if + end do + + ! History output + if (do_adjust) then + + do n = 1, ntot_amode + if (mprognum_amode(n) <= 0) cycle + + do jac = 1, 2 + if (jac == 1) then + l = numptr_amode(n) + tmpnamea = cnst_name(l) + else + l = numptrcw_amode(n) + tmpnamea = cnst_name_cw(l) + end if + + ! Expand ncol-sized qsrflx to pcols for outfld + qsrflx_pcols(:) = 0.0_r8 + qsrflx_pcols(:ncol) = qsrflx(:,l,1,jac) + fieldname = trim(tmpnamea) // '_sfcsiz1' + call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + + qsrflx_pcols(:) = 0.0_r8 + qsrflx_pcols(:ncol) = qsrflx(:,l,2,jac) + fieldname = trim(tmpnamea) // '_sfcsiz2' + call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + end do ! jac = ... + end do ! n = ... + + if (do_aitacc_transfer) then + + ipair = 1 + do iq = 1, nspecfrm_renamexf(ipair) + do jac = 1, 2 + 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 + + 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 + if ((lsfrm <= 0) .or. (lstoo <= 0)) cycle + + qsrflx_pcols(:) = 0.0_r8 + qsrflx_pcols(:ncol) = qsrflx(:,lsfrm,3,jac) + fieldname = trim(tmpnamea) // '_sfcsiz3' + call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + + qsrflx_pcols(:) = 0.0_r8 + qsrflx_pcols(:ncol) = qsrflx(:,lstoo,3,jac) + fieldname = trim(tmpnameb) // '_sfcsiz3' + call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + + qsrflx_pcols(:) = 0.0_r8 + qsrflx_pcols(:ncol) = qsrflx(:,lsfrm,4,jac) + fieldname = trim(tmpnamea) // '_sfcsiz4' + call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + + qsrflx_pcols(:) = 0.0_r8 + qsrflx_pcols(:ncol) = qsrflx(:,lstoo,4,jac) + fieldname = trim(tmpnameb) // '_sfcsiz4' + call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + + end do ! jac = ... + end do ! iq = ... + + end if ! do_aitacc_transfer + + end if ! do_adjust + + call modal_aero_calcdry(state, pbuf, aero_props, aero_state) + + ! Deallocate work arrays + deallocate(q_local, q_cw_local, dqdt_local, dqdt_cw_local) + deallocate(dotend_local, dotend_cw_local, qsrflx) + +#endif + +end subroutine modal_aero_calcsize_sub + + +!---------------------------------------------------------------------- + + +subroutine modal_aero_calcsize_diag(state, pbuf, aero_props, aero_state) + + !----------------------------------------------------------------------- + ! + ! Calculate aerosol size distribution parameters + ! + ! ***N.B.*** DGNUM for the modes in the climate list are put directly into + ! the physics buffer. + !----------------------------------------------------------------------- + + ! arguments + type(physics_state), intent(in), target :: state ! Physics state variables + type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer + class(aerosol_properties), intent(in), target :: aero_props + class(aerosol_state), intent(in), target :: aero_state + + ! local + integer :: i, k, l1, n + integer :: lchnk, ncol + integer :: stat + integer :: nmodes + integer :: nspec + + real(r8), pointer :: dgncur_a(:,:) ! (pcols,pver) + + + real(r8), parameter :: third = 1.0_r8/3.0_r8 + + real(r8), pointer :: mode_num(:,:) ! mode number mixing ratio + real(r8), pointer :: specmmr(:,:) ! specie mmr + real(r8) :: specdens ! specie density + + real(r8) :: dryvol_a(pcols,pver) ! interstital aerosol dry volume (cm^3/mol_air) + + real(r8) :: dgnum, dgnumhi, dgnumlo + real(r8) :: dgnyy, dgnxx ! dgnumlo/hi of current mode + real(r8) :: drv_a ! dry volume (cm3/mol_air) + real(r8) :: dumfac, dummwdens ! work variables + real(r8) :: num_a0 ! initial number (#/mol_air) + real(r8) :: num_a ! final number (#/mol_air) + real(r8) :: voltonumbhi, voltonumblo + real(r8) :: v2nyy, v2nxx ! voltonumblo/hi of current mode + real(r8) :: sigmag, alnsg + !----------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + nmodes = aero_props%nbins() + + do n = 1, nmodes + + call pbuf_get_field(pbuf, dgnum_idx, dgncur_a, start=(/1,1,n/), kount=(/pcols,pver,1/)) + + ! get mode properties + dgnum = aero_props%dgnum(n) + dgnumhi = aero_props%dgnumhi(n) + dgnumlo = aero_props%dgnumlo(n) + sigmag = exp(aero_props%alogsig(n)) + + ! get mode number mixing ratio + call aero_state%get_ambient_num(n, mode_num) + + dgncur_a(:,:) = dgnum + dryvol_a(:,:) = 0.0_r8 + + ! compute dry volume mixrats = + ! sum_over_components{ component_mass mixrat / density } + nspec = aero_props%nspecies(n) + do l1 = 1, nspec + + call aero_state%get_ambient_mmr(species_ndx=l1, bin_ndx=n, mmr=specmmr) + call aero_props%get(n, l1, density=specdens) + + ! need qmass*dummwdens = (kg/kg-air) * [1/(kg/m3)] = m3/kg-air + dummwdens = 1.0_r8 / specdens + + do k=top_lev,pver + do i=1,ncol + dryvol_a(i,k) = dryvol_a(i,k) & + + max(0.0_r8, specmmr(i,k))*dummwdens + end do + end do + end do + + alnsg = log( sigmag ) + dumfac = exp(4.5_r8*alnsg**2)*pi/6.0_r8 + voltonumblo = 1._r8 / ( (pi/6._r8)*(dgnumlo**3)*exp(4.5_r8*alnsg**2) ) + voltonumbhi = 1._r8 / ( (pi/6._r8)*(dgnumhi**3)*exp(4.5_r8*alnsg**2) ) + v2nxx = voltonumbhi + v2nyy = voltonumblo + dgnxx = dgnumhi + dgnyy = dgnumlo + + do k = top_lev, pver + do i = 1, ncol + + drv_a = dryvol_a(i,k) + num_a0 = mode_num(i,k) + num_a = max( 0.0_r8, num_a0 ) + + if (drv_a > 0.0_r8) then + if (num_a <= drv_a*v2nxx) then + dgncur_a(i,k) = dgnxx + else if (num_a >= drv_a*v2nyy) then + dgncur_a(i,k) = dgnyy + else + dgncur_a(i,k) = (drv_a/(dumfac*num_a))**third + end if + end if + + end do + end do + + end do ! nmodes + + call modal_aero_calcdry(state, pbuf, aero_props, aero_state) + +end subroutine modal_aero_calcsize_diag + +subroutine modal_aero_calcdry(state, pbuf, aero_props, aero_state) + + type(physics_state), target, intent(in) :: state ! Physics state variables + type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer + class(aerosol_properties), intent(in), target :: aero_props + class(aerosol_state), intent(in), target :: aero_state + + real(r8), pointer :: hygro(:,:,:) + real(r8), pointer :: dryvol(:,:,:) + real(r8), pointer :: dryrad(:,:,:) + real(r8), pointer :: drymass(:,:,:) + real(r8), pointer :: so4dryvol(:,:,:) + real(r8), pointer :: naer(:,:,:) + real(r8), pointer :: dgncur_a(:,:,:) + + integer :: ncol + + character(len=512) :: errmsg_local + integer :: errflg_local + + ncol = state%ncol + + call pbuf_get_field(pbuf, dgnum_idx, dgncur_a) + call pbuf_get_field(pbuf, hygro_idx, hygro) + call pbuf_get_field(pbuf, dryvol_idx, dryvol) + call pbuf_get_field(pbuf, dryrad_idx, dryrad) + call pbuf_get_field(pbuf, drymass_idx, drymass) + call pbuf_get_field(pbuf, so4dryvol_idx, so4dryvol) + call pbuf_get_field(pbuf, naer_idx, naer) + + ! Zero output fields (allocated to pcols, _run writes 1:ncol) + hygro(:,:,:) = 0._r8 + dryvol(:,:,:) = 0._r8 + dryrad(:,:,:) = 0._r8 + drymass(:,:,:) = 0._r8 + so4dryvol(:,:,:) = 0._r8 + naer(:,:,:) = 0._r8 + + call modal_aero_calcdry_run( & + aero_props = aero_props, & + aero_state = aero_state, & + ncol = ncol, & + pver = pver, & + top_lev = top_lev, & + do_strat_sulfate = modal_strat_sulfate, & + pi = pi, & + dgncur_a = dgncur_a(:ncol,:,:), & + hygro = hygro(:ncol,:,:), & + dryvol = dryvol(:ncol,:,:), & + dryrad = dryrad(:ncol,:,:), & + drymass = drymass(:ncol,:,:), & + so4dryvol = so4dryvol(:ncol,:,:), & + naer = naer(:ncol,:,:), & + errmsg = errmsg_local, & + errflg = errflg_local) + if (errflg_local /= 0) then + call endrun('modal_aero_calcdry: ' // trim(errmsg_local)) + end if + +end subroutine modal_aero_calcdry +!---------------------------------------------------------------------- + +end module modal_aero_calcsize_cam diff --git a/src/chemistry/utils/modal_aero_wateruptake.F90 b/src/chemistry/utils/modal_aero_wateruptake.F90 index 0f14d81fac..93b4b0f051 100644 --- a/src/chemistry/utils/modal_aero_wateruptake.F90 +++ b/src/chemistry/utils/modal_aero_wateruptake.F90 @@ -1,367 +1,134 @@ module modal_aero_wateruptake -! RCE 07.04.13: Adapted from MIRAGE2 code - -use shr_kind_mod, only: r8 => shr_kind_r8 -use physconst, only: pi, rhoh2o, rair -use ppgrid, only: pcols, pver -use physics_types, only: physics_state -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field - -use wv_saturation, only: qsat_water -use aerosol_properties_mod, only: aerosol_properties -use aerosol_state_mod, only: aerosol_state -use cam_history, only: addfld, add_default, outfld, horiz_only -use cam_logfile, only: iulog -use ref_pres, only: top_lev => clim_modal_aero_top_lev -use phys_control, only: phys_getopts -use cam_abortutils, only: endrun +! Portable science module for modal aerosol water uptake. +! Contains Kohler theory wet radius calculation and polynomial solvers. +! +! RCE 07.04.13: Adapted from MIRAGE2 code + +use shr_kind_mod, only: r8 => shr_kind_r8 implicit none private save public :: & - modal_aero_wateruptake_init, & - modal_aero_wateruptake_dr, & - modal_aero_wateruptake_sub, & - modal_aero_kohler - -public :: modal_aero_wateruptake_reg + modal_aero_wateruptake_init, & + modal_aero_wateruptake_sub, & + modal_aero_wateruptake_diag real(r8), parameter :: third = 1._r8/3._r8 -real(r8), parameter :: pi43 = pi*4.0_r8/3.0_r8 - - -! Physics buffer indices -integer :: cld_idx = 0 -integer :: dgnum_idx = 0 -integer :: dgnumwet_idx = 0 -integer :: sulfeq_idx = 0 -integer :: wetdens_ap_idx = 0 -integer :: qaerwat_idx = 0 -integer :: hygro_idx = 0 -integer :: dryvol_idx = 0 -integer :: dryrad_idx = 0 -integer :: drymass_idx = 0 -integer :: so4dryvol_idx = 0 -integer :: naer_idx = 0 - - -logical, public :: modal_strat_sulfate = .false. ! If .true. then MAM sulfate surface area density used in stratospheric heterogeneous chemistry +real(r8) :: pi43 !=============================================================================== contains !=============================================================================== -subroutine modal_aero_wateruptake_reg() - - use physics_buffer, only: pbuf_add_field, dtype_r8 - use radiative_aerosol, only: rad_aer_get_info - - integer :: nmodes - - call rad_aer_get_info(0, nmodes=nmodes) - call pbuf_add_field('DGNUMWET', 'global', dtype_r8, (/pcols, pver, nmodes/), dgnumwet_idx) - call pbuf_add_field('WETDENS_AP', 'physpkg', dtype_r8, (/pcols, pver, nmodes/), wetdens_ap_idx) - - ! 1st order rate for direct conversion of strat. cloud water to precip (1/s) - call pbuf_add_field('QAERWAT', 'physpkg', dtype_r8, (/pcols, pver, nmodes/), qaerwat_idx) - - if (modal_strat_sulfate) then - call pbuf_add_field('MAMH2SO4EQ', 'global', dtype_r8, (/pcols, pver, nmodes/), sulfeq_idx) - end if +subroutine modal_aero_wateruptake_init(pi, errmsg, errflg) + real(r8), intent(in) :: pi + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + errmsg = '' + errflg = 0 -end subroutine modal_aero_wateruptake_reg - -!=============================================================================== -!=============================================================================== - -subroutine modal_aero_wateruptake_init(pbuf2d) - use time_manager, only: is_first_step - use physics_buffer,only: pbuf_set_field - use infnan, only : nan, assignment(=) - use radiative_aerosol, only: rad_aer_get_info - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - real(r8) :: real_nan - - integer :: m, nmodes - logical :: history_aerosol ! Output the MAM aerosol variables and tendencies - - character(len=3) :: trnum ! used to hold mode number (as characters) - !---------------------------------------------------------------------------- - - real_nan = nan - - cld_idx = pbuf_get_index('CLD') - dgnum_idx = pbuf_get_index('DGNUM') - - hygro_idx = pbuf_get_index('HYGRO') - dryvol_idx = pbuf_get_index('DRYVOL') - dryrad_idx = pbuf_get_index('DRYRAD') - drymass_idx = pbuf_get_index('DRYMASS') - so4dryvol_idx = pbuf_get_index('SO4DRYVOL') - naer_idx = pbuf_get_index('NAER') - - ! assume for now that will compute wateruptake for climate list modes only - - call rad_aer_get_info(0, nmodes=nmodes) - - do m = 1, nmodes - write(trnum, '(i3.3)') m - call addfld('dgnd_a'//trnum(2:3), (/ 'lev' /), 'A', 'm', & - 'dry dgnum, interstitial, mode '//trnum(2:3)) - call addfld('dgnw_a'//trnum(2:3), (/ 'lev' /), 'A', 'm', & - 'wet dgnum, interstitial, mode '//trnum(2:3)) - call addfld('wat_a'//trnum(3:3), (/ 'lev' /), 'A', 'm', & - 'aerosol water, interstitial, mode '//trnum(2:3)) - - ! determine default variables - call phys_getopts(history_aerosol_out = history_aerosol) - - if (history_aerosol) then - call add_default('dgnd_a'//trnum(2:3), 1, ' ') - call add_default('dgnw_a'//trnum(2:3), 1, ' ') - call add_default('wat_a'//trnum(3:3), 1, ' ') - endif - - end do - - call addfld('PM25', (/ 'lev' /), 'A', 'kg/m3', 'PM2.5 mass concentration') - call addfld('PM25_SRF', horiz_only, 'A', 'kg/m3', 'surface PM2.5 mass concentration') - ! dmleung added a few more below, 20 Nov 2023 - call addfld('PM25_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM2.5 mass mixing ratio') - call addfld('PM1_SRF', horiz_only, 'A', 'kg/m3', 'surface PM1 mass concentration') - call addfld('PM1_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM1 mass mixing ratio') - call addfld('PM10_SRF', horiz_only, 'A', 'kg/m3', 'surface PM10 mass concentration') - call addfld('PM10_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM10 mass mixing ratio') - call addfld('PMTOT_MMR', (/ 'lev' /), 'A', 'kg/kg', 'total PM mass mixing ratio') - call addfld('RHO_AIR', (/ 'lev' /), 'A', 'kg/m3', 'air density') ! I know RHO_CLUBB exists. Does this exist? - - call add_default('RHO_AIR', 1, ' ') - call add_default('PM25_SRF', 1, ' ') - call add_default('PM25_MMR', 1, ' ') - call add_default('PM10_MMR', 1, ' ') - ! dmleung -- - - if (is_first_step()) then - ! initialize fields in physics buffer - call pbuf_set_field(pbuf2d, dgnumwet_idx, 0.0_r8) - if (modal_strat_sulfate) then - ! initialize fields in physics buffer to NaN (not a number) - ! so model will crash if used before initialization - call pbuf_set_field(pbuf2d, sulfeq_idx, real_nan) - endif - endif + pi43 = pi*4.0_r8/3.0_r8 end subroutine modal_aero_wateruptake_init -!=============================================================================== - +subroutine modal_aero_wateruptake_sub( & + aero_props, aero_state, & + ncol, pver, top_lev, & + do_strat_sulfate, & + t, pmid, h2ommr, cldn, & + dryrad, hygro, dryvol, so4dryvol, & + dgncur_awet, troplev, & + wetrad, wetvol, wtrvol, & + sulfeq, wtpct, sulden, & + specdens_1, alnsg_out, maer, & + errmsg, errflg) -subroutine modal_aero_wateruptake_dr(state, pbuf, aero_props, aero_state, & - dgnumdry_m, dgnumwet_m, & - qaerwat_m, wetdens_m, hygro_m, dryvol_m, dryrad_m, drymass_m,& - so4dryvol_m, naer_m) !----------------------------------------------------------------------- ! -! CAM specific driver for modal aerosol water uptake code. +! Purpose: Compute aerosol wet radius +! +! Method: Kohler theory ! -! *** N.B. *** The calculation has been enabled for diagnostic mode lists -! via optional arguments. For diagnostic list calculations -! all the optional array args must be present. +! Author: S. Ghan ! !----------------------------------------------------------------------- - use time_manager, only: is_first_step - use cam_history, only: outfld, fieldname_len - use tropopause, only: tropopause_find_cam, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE + use aerosol_properties_mod, only: aerosol_properties + use aerosol_state_mod, only: aerosol_state + use wv_saturation, only: qsat_water ! Arguments - type(physics_state), target, intent(in) :: state ! Physics state variables - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - class(aerosol_properties), intent(in), target :: aero_props - class(aerosol_state), intent(in), target :: aero_state - - real(r8), optional, pointer :: dgnumdry_m(:,:,:) - real(r8), optional, pointer :: dgnumwet_m(:,:,:) - real(r8), optional, pointer :: qaerwat_m(:,:,:) - real(r8), optional, pointer :: wetdens_m(:,:,:) - real(r8), optional, pointer :: hygro_m(:,:,:) - real(r8), optional, pointer :: dryvol_m(:,:,:) - real(r8), optional, pointer :: dryrad_m(:,:,:) - real(r8), optional, pointer :: drymass_m(:,:,:) - real(r8), optional, pointer :: so4dryvol_m(:,:,:) - real(r8), optional, pointer :: naer_m(:,:,:) + class(aerosol_properties), intent(in) :: aero_props + class(aerosol_state), intent(in) :: aero_state + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: pver ! number of vertical levels + integer, intent(in) :: top_lev ! top level for aerosol calculations + logical, intent(in) :: do_strat_sulfate ! use stratospheric sulfate treatment + real(r8), intent(in) :: t(:,:) ! temperature (K) + real(r8), intent(in) :: pmid(:,:) ! layer pressure (Pa) + real(r8), intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) + real(r8), intent(in) :: cldn(:,:) ! cloud fraction (0-1) + real(r8), intent(in) :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) + real(r8), intent(in) :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) + real(r8), intent(in) :: dryvol(:,:,:) ! dry volume of single aerosol (m3) + real(r8), intent(in) :: so4dryvol(:,:,:) ! dry volume of sulfate in single aerosol (m3) + real(r8), intent(in) :: dgncur_awet(:,:,:) ! wet number mode diameter, prev timestep (m) + integer, intent(in) :: troplev(:) ! tropopause level index + + real(r8), intent(out) :: wetrad(:,:,:) ! wet radius of aerosol (m) + real(r8), intent(out) :: wetvol(:,:,:) ! single-particle-mean wet volume (m3) + real(r8), intent(out) :: wtrvol(:,:,:) ! single-particle-mean water volume (m3) + real(r8), intent(out) :: sulfeq(:,:,:) ! H2SO4 equilibrium mixing ratio (mol/mol) + real(r8), intent(out) :: wtpct(:,:,:) ! sulfate composition, weight % H2SO4 + real(r8), intent(out) :: sulden(:,:,:) ! sulfate aerosol mass density (g/cm3) + real(r8), intent(out) :: specdens_1(:) ! first-species density per mode (kg/m3) + real(r8), intent(out) :: alnsg_out(:) ! log(sigma_g) per mode + real(r8), intent(out) :: maer(:,:,:) ! accumulated mode mass (kg/kg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! local variables - integer :: lchnk ! chunk index - integer :: ncol ! number of columns - integer :: list_idx ! radiative constituents list index - integer :: stat - - integer :: i, k, l, m - integer :: itim_old - integer :: nmodes - integer :: nspec - integer :: tropLev(pcols) - - character(len=fieldname_len+3) :: fieldname - - real(r8), pointer :: h2ommr(:,:) ! specific humidity - real(r8), pointer :: t(:,:) ! temperatures (K) - real(r8), pointer :: pmid(:,:) ! layer pressure (Pa) - - real(r8), pointer :: cldn(:,:) ! layer cloud fraction (0-1) - real(r8), pointer :: dgncur_a(:,:,:) - real(r8), pointer :: dgncur_awet(:,:,:) - real(r8), pointer :: wetdens(:,:,:) - real(r8), pointer :: qaerwat(:,:,:) - - real(r8), pointer :: raer(:,:) ! aerosol species MRs (kg/kg) - real(r8), pointer :: maer(:,:,:) ! accumulated aerosol mode MRs - real(r8), pointer :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) - real(r8), pointer :: naer(:,:,:) ! aerosol number MR (bounded!) (#/kg-air) - real(r8), pointer :: dryvol(:,:,:) ! single-particle-mean dry volume (m3) - real(r8), pointer :: so4dryvol(:,:,:) ! single-particle-mean so4 dry volume (m3) - real(r8), pointer :: drymass(:,:,:) ! single-particle-mean dry mass (kg) - real(r8), pointer :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) - - real(r8), allocatable :: wetrad(:,:,:) ! wet radius of aerosol (m) - real(r8), allocatable :: wetvol(:,:,:) ! single-particle-mean wet volume (m3) - real(r8), allocatable :: wtrvol(:,:,:) ! single-particle-mean water volume in wet aerosol (m3) - - real(r8), allocatable :: rhcrystal(:) - real(r8), allocatable :: rhdeliques(:) - real(r8), allocatable :: specdens_1(:) - - real(r8), pointer :: sulfeq(:,:,:) ! H2SO4 equilibrium mixing ratios over particles (mol/mol) - real(r8), allocatable :: wtpct(:,:,:) ! sulfate aerosol composition, weight % H2SO4 - real(r8), allocatable :: sulden(:,:,:) ! sulfate aerosol mass density (g/cm3) - - real(r8) :: specdens, so4specdens - real(r8) :: sigmag - real(r8), allocatable :: alnsg(:) - real(r8) :: rh(pcols,pver) ! relative humidity (0-1) + integer :: i, k, l, m + integer :: nmodes, nspec + real(r8) :: so4specdens, specdens, sigmag + character(len=32) :: spectype real(r8) :: dmean, qh2so4_equilib, wtpct_mode, sulden_mode + real(r8) :: hystfac - real(r8) :: es(pcols) ! saturation vapor pressure - real(r8) :: qs(pcols) ! saturation specific humidity - - real(r8) :: pm25(pcols,pver) ! PM2.5 diagnostics - real(r8) :: rhoair(pcols,pver) - ! dmleung 20 Oct 2025 ++ - real(r8) :: pm25_mmr(pcols,pver) ! PM2.5 mass mixing ratio dmleung, 20 Nov 2023 - real(r8) :: pm1(pcols,pver) ! PM1 mass conc - real(r8) :: pm1_mmr(pcols,pver) ! PM1 mass mixing ratio dmleung, 20 Nov 2023 - real(r8) :: pm10(pcols,pver) ! PM10 mass conc - real(r8) :: pm10_mmr(pcols,pver) ! PM10 mass mixing ratio dmleung, 20 Nov 2023 - real(r8) :: pmtot_mmr(pcols,pver) ! total PM mass mixing ratio - ! dmleung -- - - character(len=3) :: trnum ! used to hold mode number (as characters) - character(len=32) :: spectype + real(r8), allocatable :: rhcrystal(:), rhdeliques(:) + real(r8) :: rh(ncol, pver) + real(r8) :: es(ncol), qs(ncol) + real(r8), pointer :: raer(:,:) !----------------------------------------------------------------------- - lchnk = state%lchnk - ncol = state%ncol - - list_idx = aero_props%list_idx() - - if (list_idx /= 0) then - ! check that all optional args are present - if (.not. present(dgnumdry_m) .or. .not. present(dgnumwet_m) .or. & - .not. present(qaerwat_m) .or. .not. present(wetdens_m)) then - call endrun('modal_aero_wateruptake_dr called for'// & - 'diagnostic list but required args not present') - end if - - ! arrays for diagnostic calculations must be associated - if (.not. associated(dgnumdry_m) .or. .not. associated(dgnumwet_m) .or. & - .not. associated(qaerwat_m) .or. .not. associated(wetdens_m)) then - call endrun('modal_aero_wateruptake_dr called for'// & - 'diagnostic list but required args not associated') - end if - - if (modal_strat_sulfate) then - call endrun('modal_aero_wateruptake_dr cannot be called with optional arguments and'// & - ' having modal_strat_sulfate set to true') - end if - end if + errmsg = '' + errflg = 0 - ! loop over all aerosol modes nmodes = aero_props%nbins() - if (modal_strat_sulfate) then - call pbuf_get_field(pbuf, sulfeq_idx, sulfeq ) - endif - - allocate( & - wetrad(pcols,pver,nmodes), & - wetvol(pcols,pver,nmodes), & - wtrvol(pcols,pver,nmodes), & - wtpct(pcols,pver,nmodes), & - sulden(pcols,pver,nmodes), & - rhcrystal(nmodes), & - rhdeliques(nmodes), & - specdens_1(nmodes), & - alnsg(nmodes) ) - - wtpct(:,:,:) = 75._r8 - sulden(:,:,:) = 1.923_r8 - - if (list_idx == 0) then - call pbuf_get_field(pbuf, dgnum_idx, dgncur_a ) - call pbuf_get_field(pbuf, dgnumwet_idx, dgncur_awet ) - call pbuf_get_field(pbuf, wetdens_ap_idx, wetdens) - call pbuf_get_field(pbuf, qaerwat_idx, qaerwat) - call pbuf_get_field(pbuf, hygro_idx, hygro) - call pbuf_get_field(pbuf, dryvol_idx, dryvol) - call pbuf_get_field(pbuf, dryrad_idx, dryrad) - call pbuf_get_field(pbuf, drymass_idx, drymass) - call pbuf_get_field(pbuf, so4dryvol_idx, so4dryvol) - call pbuf_get_field(pbuf, naer_idx, naer) - - if (is_first_step()) then - dgncur_awet(:,:,:) = dgncur_a(:,:,:) - end if - else - dgncur_a => dgnumdry_m - dgncur_awet => dgnumwet_m - qaerwat => qaerwat_m - wetdens => wetdens_m - hygro => hygro_m - dryvol => dryvol_m - dryrad => dryrad_m - drymass => drymass_m - so4dryvol => so4dryvol_m - naer => naer_m - end if - - if (modal_strat_sulfate) then - ! get tropopause level - !REMOVECAM - no longer need this when CAM is retired and pcols no longer exists - tropLev(:) = 0 - !REMOVECAM_END - call tropopause_find_cam(state, tropLev, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) - endif + ! Initialize defaults + wtpct(:,:,:) = 75._r8 + sulden(:,:,:) = 1.923_r8 + sulfeq(:,:,:) = 0._r8 + maer(:,:,:) = 0._r8 - h2ommr => state%q(:,:,1) - t => state%t - pmid => state%pmid + allocate(rhcrystal(nmodes), rhdeliques(nmodes)) - allocate( maer(pcols,pver,nmodes)) - maer(:,:,:) = 0._r8 + so4specdens = 0._r8 + ! Query mode properties and accumulate mode mass do m = 1, nmodes sigmag = exp(aero_props%alogsig(m)) rhcrystal(m) = aero_props%rhcrystal(m) rhdeliques(m) = aero_props%rhdeliques(m) + alnsg_out(m) = log(sigmag) ! get mode info nspec = aero_props%nspecies(m) @@ -370,13 +137,13 @@ subroutine modal_aero_wateruptake_dr(state, pbuf, aero_props, aero_state, & ! accumulate the aerosol masses of each mode call aero_state%get_ambient_mmr(species_ndx=l, bin_ndx=m, mmr=raer) - maer(:ncol,:,m)= maer(:ncol,:,m) + raer(:ncol,:) + maer(:ncol,:,m) = maer(:ncol,:,m) + raer(:ncol,:) ! get species interstitial mixing ratio ('a') call aero_props%get(m, l, density=specdens, & spectype=spectype) - if (modal_strat_sulfate .and. (trim(spectype).eq.'sulfate')) then + if (do_strat_sulfate .and. (trim(spectype).eq.'sulfate')) then so4specdens=specdens end if @@ -387,41 +154,28 @@ subroutine modal_aero_wateruptake_dr(state, pbuf, aero_props, aero_state, & end do - alnsg(m) = log(sigmag) - - if (modal_strat_sulfate) then + ! Compute stratospheric sulfate equilibrium + if (do_strat_sulfate) then do k = top_lev, pver do i = 1, ncol - dmean = dgncur_awet(i,k,m)*exp(1.5_r8*alnsg(m)**2) + dmean = dgncur_awet(i,k,m)*exp(1.5_r8*alnsg_out(m)**2) call calc_h2so4_equilib_mixrat( t(i,k), pmid(i,k), h2ommr(i,k), dmean, & - qh2so4_equilib, wtpct_mode, sulden_mode ) + qh2so4_equilib, wtpct_mode, sulden_mode, & + errmsg, errflg ) + if (errflg /= 0) then + deallocate(rhcrystal, rhdeliques) + return + end if sulfeq(i,k,m) = qh2so4_equilib wtpct(i,k,m) = wtpct_mode sulden(i,k,m) = sulden_mode end do ! i = 1, ncol end do ! k = top_lev, pver + end if - fieldname = ' ' - write(fieldname,fmt='(a,i1)') 'wtpct_a',m - call outfld(fieldname,wtpct(1:ncol,1:pver,m), ncol, lchnk ) - - fieldname = ' ' - write(fieldname,fmt='(a,i1)') 'sulfeq_a',m - call outfld(fieldname,sulfeq(1:ncol,1:pver,m), ncol, lchnk ) - - fieldname = ' ' - write(fieldname,fmt='(a,i1)') 'sulden_a',m - call outfld(fieldname,sulden(1:ncol,1:pver,m), ncol, lchnk ) - - end if - - end do ! m = 1, nmodes - - ! relative humidity calc - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + end do ! m = 1, nmodes + ! Compute relative humidity do k = top_lev, pver call qsat_water(t(1:ncol,k), pmid(1:ncol,k), es(1:ncol), qs(1:ncol), ncol) do i = 1, ncol @@ -436,143 +190,10 @@ subroutine modal_aero_wateruptake_dr(state, pbuf, aero_props, aero_state, & rh(i,k) = (rh(i,k) - cldn(i,k)) / (1.0_r8 - cldn(i,k)) ! clear portion end if rh(i,k) = max(rh(i,k), 0.0_r8) - rhoair(i,k) = pmid(i,k)/(rair*t(i,k)) end do end do - call modal_aero_wateruptake_sub( & - ncol, nmodes, rhcrystal, rhdeliques, dryrad, & - hygro, rh, dryvol, so4dryvol, so4specdens, tropLev, & - wetrad, wetvol, wtrvol, sulden, wtpct) - - qaerwat = 0.0_r8 - - do m = 1, nmodes - - do k = top_lev, pver - do i = 1, ncol - - dgncur_awet(i,k,m) = dgncur_a(i,k,m) * (wetrad(i,k,m)/dryrad(i,k,m)) - qaerwat(i,k,m) = rhoh2o*naer(i,k,m)*wtrvol(i,k,m) - - ! compute aerosol wet density (kg/m3) - if (wetvol(i,k,m) > 1.0e-30_r8) then - wetdens(i,k,m) = (drymass(i,k,m) + rhoh2o*wtrvol(i,k,m))/wetvol(i,k,m) - else - wetdens(i,k,m) = specdens_1(m) - end if - end do - end do - - end do ! modes - - if (list_idx == 0) then - - pm25(:,:)=0._r8 - ! dmleung 20 Oct 2025 ++ - pm25_mmr(:,:)=0._r8 - pm1(:,:)=0._r8 - pm1_mmr(:,:)=0._r8 - pm10(:,:)=0._r8 - pm10_mmr(:,:)=0._r8 - pmtot_mmr(:,:)=0._r8 - ! dmleung -- - - do m = 1, nmodes - ! output to history - write( trnum, '(i3.3)' ) m - call outfld( 'wat_a'//trnum(3:3), qaerwat(:,:,m), pcols, lchnk) - call outfld( 'dgnd_a'//trnum(2:3), dgncur_a(:,:,m), pcols, lchnk) - call outfld( 'dgnw_a'//trnum(2:3), dgncur_awet(:,:,m), pcols, lchnk) - - ! calculate PM2.5 diagnostics -- dgncur_a is zero above top_lev - do k = top_lev, pver - do i=1,ncol - pm25(i,k) = pm25(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(2.5e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) - ! dmleung 20 Oct 2025: calculate other PM diagnostics ++ - pm25_mmr(i,k) = pm25_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(2.5e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m))))) ! PM2.5 mass mixing ratio, dmleung - pm1(i,k) = pm1(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(1.0e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) - pm1_mmr(i,k) = pm1_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(1.0e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m))))) ! PM1 mass mixing ratio, dmleung - pm10(i,k) = pm10(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(10.0e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) - pm10_mmr(i,k) = pm10_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(10.0e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m))))) ! PM10 mass mixing ratio, dmleung - pmtot_mmr(i,k) = pmtot_mmr(i,k)+maer(i,k,m) ! toal PM mass mixing ratio, dmleung - ! dmleung -- - end do - end do - end do - - call outfld('PM25', pm25(:,:), pcols, lchnk) - call outfld('PM25_SRF', pm25(:,pver), pcols, lchnk) - ! dmleung 20 Oct 2025 added history fields below ++ - call outfld('PM25_MMR', pm25_mmr(:,:), pcols, lchnk) - call outfld('PM1_SRF', pm1(:,pver), pcols, lchnk) - call outfld('PM1_MMR', pm1_mmr(:,:), pcols, lchnk) - call outfld('PM10_SRF', pm10(:,pver), pcols, lchnk) - call outfld('PM10_MMR', pm10_mmr(:,:), pcols, lchnk) - call outfld('PMTOT_MMR',pmtot_mmr(:,:),pcols, lchnk) - call outfld('RHO_AIR', rhoair(:,:), pcols, lchnk) - ! dmleung -- - end if - - deallocate(maer, alnsg) - deallocate( & - wetrad, wetvol, wtrvol, wtpct, sulden, rhcrystal, rhdeliques, specdens_1 ) - -end subroutine modal_aero_wateruptake_dr - -!=============================================================================== - -subroutine modal_aero_wateruptake_sub( & - ncol, nmodes, rhcrystal, rhdeliques, dryrad, & - hygro, rh, dryvol, so4dryvol, so4specdens, troplev, & - wetrad, wetvol, wtrvol, sulden, wtpct) - -!----------------------------------------------------------------------- -! -! Purpose: Compute aerosol wet radius -! -! Method: Kohler theory -! -! Author: S. Ghan -! -!----------------------------------------------------------------------- - - - ! Arguments - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: nmodes - integer, intent(in) :: troplev(:) - - real(r8), intent(in) :: rhcrystal(:) - real(r8), intent(in) :: rhdeliques(:) - real(r8), intent(in) :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) - real(r8), intent(in) :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) - real(r8), intent(in) :: rh(:,:) ! relative humidity (0-1) - real(r8), intent(in) :: dryvol(:,:,:) ! dry volume of single aerosol (m3) - real(r8), intent(in) :: so4dryvol(:,:,:) ! dry volume of sulfate in single aerosol (m3) - real(r8), intent(in) :: so4specdens ! mass density sulfate in single aerosol (kg/m3) - real(r8), intent(in) :: wtpct(:,:,:) ! sulfate aerosol composition, weight % H2SO4 - real(r8), intent(in) :: sulden(:,:,:) ! sulfate aerosol mass density (g/cm3) - - real(r8), intent(out) :: wetrad(:,:,:) ! wet radius of aerosol (m) - real(r8), intent(out) :: wetvol(:,:,:) ! single-particle-mean wet volume (m3) - real(r8), intent(out) :: wtrvol(:,:,:) ! single-particle-mean water volume in wet aerosol (m3) - - ! local variables - - integer :: i, k, m - - real(r8) :: hystfac ! working variable for hysteresis - !----------------------------------------------------------------------- - - - ! loop over all aerosol modes + ! Compute wet radius using Kohler theory do m = 1, nmodes hystfac = 1.0_r8 / max(1.0e-5_r8, (rhdeliques(m) - rhcrystal(m))) @@ -580,7 +201,7 @@ subroutine modal_aero_wateruptake_sub( & do k = top_lev, pver do i = 1, ncol - if ( modal_strat_sulfate .and. (k 0) then + errmsg = 'modal_aero_wateruptake_diag: unable to allocate work arrays' + errflg = 1 return - end subroutine calc_h2so4_wtpct + end if + + ! dry size distribution parameters of the diagnostic list + call modal_aero_calcsize_diag_run( & + aero_props = aero_props, & + aero_state = aero_state, & + ncol = ncol, & + pver = nlev, & + top_lev = top_lev, & + pi = pi, & + dgncur_a = dgncur_a, & + errmsg = errmsg, & + errflg = errflg) + if (errflg /= 0) return + + ! Zero output fields (_run writes top_lev:nlev) + hygro(:,:,:) = 0._r8 + dryvol(:,:,:) = 0._r8 + dryrad(:,:,:) = 0._r8 + drymass(:,:,:) = 0._r8 + so4dryvol(:,:,:) = 0._r8 + naer(:,:,:) = 0._r8 + + call modal_aero_calcdry_run( & + aero_props = aero_props, & + aero_state = aero_state, & + ncol = ncol, & + pver = nlev, & + top_lev = top_lev, & + do_strat_sulfate = .false., & + pi = pi, & + dgncur_a = dgncur_a, & + hygro = hygro, & + dryvol = dryvol, & + dryrad = dryrad, & + drymass = drymass, & + so4dryvol = so4dryvol, & + naer = naer, & + errmsg = errmsg, & + errflg = errflg) + if (errflg /= 0) return + + ! Zero work arrays (_sub only writes top_lev:nlev). + ! dgncur_awet is an intent(in) of _sub read only under do_strat_sulfate; + ! zero it here for definedness before the post-processing fills it. + wetrad(:,:,:) = 0._r8 + wetvol(:,:,:) = 0._r8 + wtrvol(:,:,:) = 0._r8 + sulfeq(:,:,:) = 0._r8 + wtpct(:,:,:) = 0._r8 + sulden(:,:,:) = 0._r8 + maer(:,:,:) = 0._r8 + dgncur_awet(:,:,:) = 0._r8 + troplev(:) = 0 + + call modal_aero_wateruptake_sub( & + aero_props = aero_props, & + aero_state = aero_state, & + ncol = ncol, & + pver = nlev, & + top_lev = top_lev, & + do_strat_sulfate = .false., & + t = t, & + pmid = pmid, & + h2ommr = h2ommr, & + cldn = cldn, & + dryrad = dryrad, & + hygro = hygro, & + dryvol = dryvol, & + so4dryvol = so4dryvol, & + dgncur_awet = dgncur_awet, & + troplev = troplev, & + wetrad = wetrad, & + wetvol = wetvol, & + wtrvol = wtrvol, & + sulfeq = sulfeq, & + wtpct = wtpct, & + sulden = sulden, & + specdens_1 = specdens_1, & + alnsg_out = alnsg, & + maer = maer, & + errmsg = errmsg, & + errflg = errflg) + if (errflg /= 0) return + + ! Post-processing: wet density, qaerwat, dgncur_awet update + qaerwat_m = 0.0_r8 + + do m = 1, nmodes + + do k = top_lev, nlev + do i = 1, ncol + + dgncur_awet(i,k,m) = dgncur_a(i,k,m) * (wetrad(i,k,m)/dryrad(i,k,m)) + qaerwat_m(i,k,m) = rhoh2o*naer(i,k,m)*wtrvol(i,k,m) + + ! compute aerosol wet density (kg/m3) + if (wetvol(i,k,m) > 1.0e-30_r8) then + wetdens(i,k,m) = (drymass(i,k,m) + rhoh2o*wtrvol(i,k,m))/wetvol(i,k,m) + else + wetdens(i,k,m) = specdens_1(m) + end if + end do + end do + + end do ! modes + + dgnumwet(:ncol,:nlev) = dgncur_awet(:ncol,:nlev,bin_idx) + qaerwat (:ncol,:nlev) = qaerwat_m(:ncol,:nlev,bin_idx) + + deallocate( & + dgncur_a, dgncur_awet, qaerwat_m, wetdens, hygro, dryvol, dryrad, & + drymass, so4dryvol, naer, wetrad, wetvol, wtrvol, wtpct, sulden, & + sulfeq, specdens_1, alnsg, maer) +end subroutine modal_aero_wateruptake_diag !---------------------------------------------------------------------- - end module modal_aero_wateruptake +end module modal_aero_wateruptake diff --git a/src/chemistry/utils/modal_aero_wateruptake_cam.F90 b/src/chemistry/utils/modal_aero_wateruptake_cam.F90 new file mode 100644 index 0000000000..90bab93e79 --- /dev/null +++ b/src/chemistry/utils/modal_aero_wateruptake_cam.F90 @@ -0,0 +1,453 @@ +module modal_aero_wateruptake_cam + +! CAM wrapper for modal_aero_wateruptake. +! Handles pbuf registration, initialization, history output, +! state/pbuf/aero_props marshaling, and calls the portable +! science routines. + +use shr_kind_mod, only: r8 => shr_kind_r8 +use physconst, only: pi, rhoh2o, rair +use ppgrid, only: pcols, pver +use physics_types, only: physics_state +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field + +use aerosol_properties_mod, only: aerosol_properties +use aerosol_state_mod, only: aerosol_state +use cam_history, only: addfld, add_default, outfld, horiz_only +use cam_logfile, only: iulog +use ref_pres, only: top_lev => clim_modal_aero_top_lev +use phys_control, only: phys_getopts +use cam_abortutils, only: endrun + +use modal_aero_wateruptake, only: modal_aero_wateruptake_init, & + modal_aero_wateruptake_sub +use modal_aero_data, only: modal_strat_sulfate + +implicit none +private +save + +public :: & + modal_aero_wateruptake_cam_init, & + modal_aero_wateruptake_dr, & + modal_aero_wateruptake_reg + +! Physics buffer indices +integer :: cld_idx = 0 +integer :: dgnum_idx = 0 +integer :: dgnumwet_idx = 0 +integer :: sulfeq_idx = 0 +integer :: wetdens_ap_idx = 0 +integer :: qaerwat_idx = 0 +integer :: hygro_idx = 0 +integer :: dryvol_idx = 0 +integer :: dryrad_idx = 0 +integer :: drymass_idx = 0 +integer :: so4dryvol_idx = 0 +integer :: naer_idx = 0 + + +!=============================================================================== +contains +!=============================================================================== + +subroutine modal_aero_wateruptake_reg() + + use physics_buffer, only: pbuf_add_field, dtype_r8 + use radiative_aerosol, only: rad_aer_get_info + + integer :: nmodes + + call rad_aer_get_info(0, nmodes=nmodes) + call pbuf_add_field('DGNUMWET', 'global', dtype_r8, (/pcols, pver, nmodes/), dgnumwet_idx) + call pbuf_add_field('WETDENS_AP', 'physpkg', dtype_r8, (/pcols, pver, nmodes/), wetdens_ap_idx) + + ! 1st order rate for direct conversion of strat. cloud water to precip (1/s) + call pbuf_add_field('QAERWAT', 'physpkg', dtype_r8, (/pcols, pver, nmodes/), qaerwat_idx) + + if (modal_strat_sulfate) then + call pbuf_add_field('MAMH2SO4EQ', 'global', dtype_r8, (/pcols, pver, nmodes/), sulfeq_idx) + end if + + +end subroutine modal_aero_wateruptake_reg + +!=============================================================================== +!=============================================================================== + +subroutine modal_aero_wateruptake_cam_init(pbuf2d) + use time_manager, only: is_first_step + use physics_buffer,only: pbuf_set_field + use infnan, only : nan, assignment(=) + use radiative_aerosol, only: rad_aer_get_info + use modal_aero_wateruptake, only: modal_aero_wateruptake_diag + use modal_aerosol_state_mod, only: modal_aerosol_state_register_water_uptake_diag + + use shr_const_mod, only: shr_const_pi + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + real(r8) :: real_nan + + integer :: m, nmodes + logical :: history_aerosol ! Output the MAM aerosol variables and tendencies + + character(len=3) :: trnum ! used to hold mode number (as characters) + + character(len=512) :: errmsg_local + integer :: errflg_local + !---------------------------------------------------------------------------- + + real_nan = nan + + cld_idx = pbuf_get_index('CLD') + dgnum_idx = pbuf_get_index('DGNUM') + + hygro_idx = pbuf_get_index('HYGRO') + dryvol_idx = pbuf_get_index('DRYVOL') + dryrad_idx = pbuf_get_index('DRYRAD') + drymass_idx = pbuf_get_index('DRYMASS') + so4dryvol_idx = pbuf_get_index('SO4DRYVOL') + naer_idx = pbuf_get_index('NAER') + + ! assume for now that will compute wateruptake for climate list modes only + + call rad_aer_get_info(0, nmodes=nmodes) + + do m = 1, nmodes + write(trnum, '(i3.3)') m + call addfld('dgnd_a'//trnum(2:3), (/ 'lev' /), 'A', 'm', & + 'dry dgnum, interstitial, mode '//trnum(2:3)) + call addfld('dgnw_a'//trnum(2:3), (/ 'lev' /), 'A', 'm', & + 'wet dgnum, interstitial, mode '//trnum(2:3)) + call addfld('wat_a'//trnum(3:3), (/ 'lev' /), 'A', 'm', & + 'aerosol water, interstitial, mode '//trnum(2:3)) + + ! determine default variables + call phys_getopts(history_aerosol_out = history_aerosol) + + if (history_aerosol) then + call add_default('dgnd_a'//trnum(2:3), 1, ' ') + call add_default('dgnw_a'//trnum(2:3), 1, ' ') + call add_default('wat_a'//trnum(3:3), 1, ' ') + endif + + end do + + call addfld('PM25', (/ 'lev' /), 'A', 'kg/m3', 'PM2.5 mass concentration') + call addfld('PM25_SRF', horiz_only, 'A', 'kg/m3', 'surface PM2.5 mass concentration') + ! dmleung added a few more below, 20 Nov 2023 + call addfld('PM25_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM2.5 mass mixing ratio') + call addfld('PM1_SRF', horiz_only, 'A', 'kg/m3', 'surface PM1 mass concentration') + call addfld('PM1_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM1 mass mixing ratio') + call addfld('PM10_SRF', horiz_only, 'A', 'kg/m3', 'surface PM10 mass concentration') + call addfld('PM10_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM10 mass mixing ratio') + call addfld('PMTOT_MMR', (/ 'lev' /), 'A', 'kg/kg', 'total PM mass mixing ratio') + call addfld('RHO_AIR', (/ 'lev' /), 'A', 'kg/m3', 'air density') ! I know RHO_CLUBB exists. Does this exist? + + call add_default('RHO_AIR', 1, ' ') + call add_default('PM25_SRF', 1, ' ') + call add_default('PM25_MMR', 1, ' ') + call add_default('PM10_MMR', 1, ' ') + ! dmleung -- + + if (is_first_step()) then + ! initialize fields in physics buffer + call pbuf_set_field(pbuf2d, dgnumwet_idx, 0.0_r8) + if (modal_strat_sulfate) then + ! initialize fields in physics buffer to NaN (not a number) + ! so model will crash if used before initialization + call pbuf_set_field(pbuf2d, sulfeq_idx, real_nan) + endif + endif + + call modal_aero_wateruptake_init(shr_const_pi, errmsg_local, errflg_local) + if (errflg_local /= 0) then + call endrun('modal_aero_wateruptake_cam_init: ' // trim(errmsg_local)) + end if + + ! Register the diagnostic-list water uptake recompute with the aerosol + ! interface (called by modal_aerosol_state%water_uptake for diagnostic + ! radiation lists; wired at init because the portable modal aerosol + ! schemes are not part of every build). + call modal_aerosol_state_register_water_uptake_diag(modal_aero_wateruptake_diag) + +end subroutine modal_aero_wateruptake_cam_init + +!=============================================================================== + + +subroutine modal_aero_wateruptake_dr(state, pbuf, aero_props, aero_state) +!----------------------------------------------------------------------- +! +! CAM specific driver for modal aerosol water uptake code. +! +!----------------------------------------------------------------------- + + use time_manager, only: is_first_step + use cam_history, only: fieldname_len + use tropopause, only: tropopause_find_cam, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE + + ! Arguments + type(physics_state), target, intent(in) :: state ! Physics state variables + type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer + class(aerosol_properties), intent(in), target :: aero_props + class(aerosol_state), intent(in), target :: aero_state + + ! local variables + + integer :: lchnk ! chunk index + integer :: ncol ! number of columns + + integer :: i, k, m + integer :: itim_old + integer :: nmodes + integer :: tropLev(pcols) + + character(len=fieldname_len+3) :: fieldname + + real(r8), pointer :: h2ommr(:,:) ! specific humidity + real(r8), pointer :: t(:,:) ! temperatures (K) + real(r8), pointer :: pmid(:,:) ! layer pressure (Pa) + + real(r8), pointer :: cldn(:,:) ! layer cloud fraction (0-1) + real(r8), pointer :: dgncur_a(:,:,:) + real(r8), pointer :: dgncur_awet(:,:,:) + real(r8), pointer :: wetdens(:,:,:) + real(r8), pointer :: qaerwat(:,:,:) + + real(r8), pointer :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) + real(r8), pointer :: naer(:,:,:) ! aerosol number MR (bounded!) (#/kg-air) + real(r8), pointer :: dryvol(:,:,:) ! single-particle-mean dry volume (m3) + real(r8), pointer :: so4dryvol(:,:,:) ! single-particle-mean so4 dry volume (m3) + real(r8), pointer :: drymass(:,:,:) ! single-particle-mean dry mass (kg) + real(r8), pointer :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) + + real(r8), allocatable :: wetrad(:,:,:) ! wet radius of aerosol (m) + real(r8), allocatable :: wetvol(:,:,:) ! single-particle-mean wet volume (m3) + real(r8), allocatable :: wtrvol(:,:,:) ! single-particle-mean water volume in wet aerosol (m3) + + real(r8), allocatable :: specdens_1(:) + + real(r8), pointer :: sulfeq(:,:,:) ! H2SO4 equilibrium mixing ratios over particles (mol/mol) + real(r8), allocatable :: sulfeq_local(:,:,:) ! local work array for _sub output + real(r8), allocatable :: wtpct(:,:,:) ! sulfate aerosol composition, weight % H2SO4 + real(r8), allocatable :: sulden(:,:,:) ! sulfate aerosol mass density (g/cm3) + + real(r8), allocatable :: alnsg(:) + real(r8), pointer :: maer(:,:,:) ! accumulated aerosol mode MRs + + real(r8) :: pm25(pcols,pver) ! PM2.5 diagnostics + real(r8) :: rhoair(pcols,pver) + ! dmleung 20 Oct 2025 ++ + real(r8) :: pm25_mmr(pcols,pver) ! PM2.5 mass mixing ratio dmleung, 20 Nov 2023 + real(r8) :: pm1(pcols,pver) ! PM1 mass conc + real(r8) :: pm1_mmr(pcols,pver) ! PM1 mass mixing ratio dmleung, 20 Nov 2023 + real(r8) :: pm10(pcols,pver) ! PM10 mass conc + real(r8) :: pm10_mmr(pcols,pver) ! PM10 mass mixing ratio dmleung, 20 Nov 2023 + real(r8) :: pmtot_mmr(pcols,pver) ! total PM mass mixing ratio + ! dmleung -- + + character(len=3) :: trnum ! used to hold mode number (as characters) + + character(len=512) :: errmsg_local + integer :: errflg_local + + !----------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + ! loop over all aerosol modes + nmodes = aero_props%nbins() + + allocate( & + wetrad(pcols,pver,nmodes), & + wetvol(pcols,pver,nmodes), & + wtrvol(pcols,pver,nmodes), & + wtpct(pcols,pver,nmodes), & + sulden(pcols,pver,nmodes), & + sulfeq_local(pcols,pver,nmodes), & + specdens_1(nmodes), & + alnsg(nmodes), & + maer(pcols,pver,nmodes) ) + + call pbuf_get_field(pbuf, dgnum_idx, dgncur_a ) + call pbuf_get_field(pbuf, dgnumwet_idx, dgncur_awet ) + call pbuf_get_field(pbuf, wetdens_ap_idx, wetdens) + call pbuf_get_field(pbuf, qaerwat_idx, qaerwat) + call pbuf_get_field(pbuf, hygro_idx, hygro) + call pbuf_get_field(pbuf, dryvol_idx, dryvol) + call pbuf_get_field(pbuf, dryrad_idx, dryrad) + call pbuf_get_field(pbuf, drymass_idx, drymass) + call pbuf_get_field(pbuf, so4dryvol_idx, so4dryvol) + call pbuf_get_field(pbuf, naer_idx, naer) + + if (is_first_step()) then + dgncur_awet(:,:,:) = dgncur_a(:,:,:) + end if + + if (modal_strat_sulfate) then + ! get tropopause level + !REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + tropLev(:) = 0 + !REMOVECAM_END + call tropopause_find_cam(state, tropLev, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) + endif + + h2ommr => state%q(:,:,1) + t => state%t + pmid => state%pmid + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + ! Zero output arrays (allocated at pcols, _sub only writes 1:ncol) + wetrad(:,:,:) = 0._r8 + wetvol(:,:,:) = 0._r8 + wtrvol(:,:,:) = 0._r8 + sulfeq_local(:,:,:) = 0._r8 + wtpct(:,:,:) = 0._r8 + sulden(:,:,:) = 0._r8 + maer(:,:,:) = 0._r8 + + call modal_aero_wateruptake_sub( & + aero_props = aero_props, & + aero_state = aero_state, & + ncol = ncol, & + pver = pver, & + top_lev = top_lev, & + do_strat_sulfate = modal_strat_sulfate, & + t = t(:ncol,:), & + pmid = pmid(:ncol,:), & + h2ommr = h2ommr(:ncol,:), & + cldn = cldn(:ncol,:), & + dryrad = dryrad(:ncol,:,:), & + hygro = hygro(:ncol,:,:), & + dryvol = dryvol(:ncol,:,:), & + so4dryvol = so4dryvol(:ncol,:,:), & + dgncur_awet = dgncur_awet(:ncol,:,:), & + troplev = tropLev(:ncol), & + wetrad = wetrad(:ncol,:,:), & + wetvol = wetvol(:ncol,:,:), & + wtrvol = wtrvol(:ncol,:,:), & + sulfeq = sulfeq_local(:ncol,:,:), & + wtpct = wtpct(:ncol,:,:), & + sulden = sulden(:ncol,:,:), & + specdens_1 = specdens_1, & + alnsg_out = alnsg, & + maer = maer(:ncol,:,:), & + errmsg = errmsg_local, & + errflg = errflg_local) + if (errflg_local /= 0) then + call endrun('modal_aero_wateruptake_dr: ' // trim(errmsg_local)) + end if + + ! Copy sulfeq to pbuf and output strat sulfate diagnostics + if (modal_strat_sulfate) then + call pbuf_get_field(pbuf, sulfeq_idx, sulfeq) + sulfeq(:,:,:) = sulfeq_local(:,:,:) + + do m = 1, nmodes + fieldname = ' ' + write(fieldname,fmt='(a,i1)') 'wtpct_a',m + call outfld(fieldname,wtpct(1:ncol,1:pver,m), ncol, lchnk ) + + fieldname = ' ' + write(fieldname,fmt='(a,i1)') 'sulfeq_a',m + call outfld(fieldname,sulfeq_local(1:ncol,1:pver,m), ncol, lchnk ) + + fieldname = ' ' + write(fieldname,fmt='(a,i1)') 'sulden_a',m + call outfld(fieldname,sulden(1:ncol,1:pver,m), ncol, lchnk ) + end do + end if + + ! Post-processing: wet density, qaerwat, dgncur_awet update + qaerwat = 0.0_r8 + + do m = 1, nmodes + + do k = top_lev, pver + do i = 1, ncol + + dgncur_awet(i,k,m) = dgncur_a(i,k,m) * (wetrad(i,k,m)/dryrad(i,k,m)) + qaerwat(i,k,m) = rhoh2o*naer(i,k,m)*wtrvol(i,k,m) + + ! compute aerosol wet density (kg/m3) + if (wetvol(i,k,m) > 1.0e-30_r8) then + wetdens(i,k,m) = (drymass(i,k,m) + rhoh2o*wtrvol(i,k,m))/wetvol(i,k,m) + else + wetdens(i,k,m) = specdens_1(m) + end if + end do + end do + + end do ! modes + + ! Compute air density for PM diagnostics + do k = top_lev, pver + do i = 1, ncol + rhoair(i,k) = pmid(i,k)/(rair*t(i,k)) + end do + end do + + pm25(:,:)=0._r8 + ! dmleung 20 Oct 2025 ++ + pm25_mmr(:,:)=0._r8 + pm1(:,:)=0._r8 + pm1_mmr(:,:)=0._r8 + pm10(:,:)=0._r8 + pm10_mmr(:,:)=0._r8 + pmtot_mmr(:,:)=0._r8 + ! dmleung -- + + do m = 1, nmodes + ! output to history + write( trnum, '(i3.3)' ) m + call outfld( 'wat_a'//trnum(3:3), qaerwat(:,:,m), pcols, lchnk) + call outfld( 'dgnd_a'//trnum(2:3), dgncur_a(:,:,m), pcols, lchnk) + call outfld( 'dgnw_a'//trnum(2:3), dgncur_awet(:,:,m), pcols, lchnk) + + ! calculate PM2.5 diagnostics -- dgncur_a is zero above top_lev + do k = top_lev, pver + do i=1,ncol + pm25(i,k) = pm25(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(2.5e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) + ! dmleung 20 Oct 2025: calculate other PM diagnostics ++ + pm25_mmr(i,k) = pm25_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(2.5e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m))))) ! PM2.5 mass mixing ratio, dmleung + pm1(i,k) = pm1(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(1.0e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) + pm1_mmr(i,k) = pm1_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(1.0e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m))))) ! PM1 mass mixing ratio, dmleung + pm10(i,k) = pm10(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(10.0e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) + pm10_mmr(i,k) = pm10_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(10.0e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m))))) ! PM10 mass mixing ratio, dmleung + pmtot_mmr(i,k) = pmtot_mmr(i,k)+maer(i,k,m) ! toal PM mass mixing ratio, dmleung + ! dmleung -- + end do + end do + end do + + call outfld('PM25', pm25(:,:), pcols, lchnk) + call outfld('PM25_SRF', pm25(:,pver), pcols, lchnk) + ! dmleung 20 Oct 2025 added history fields below ++ + call outfld('PM25_MMR', pm25_mmr(:,:), pcols, lchnk) + call outfld('PM1_SRF', pm1(:,pver), pcols, lchnk) + call outfld('PM1_MMR', pm1_mmr(:,:), pcols, lchnk) + call outfld('PM10_SRF', pm10(:,pver), pcols, lchnk) + call outfld('PM10_MMR', pm10_mmr(:,:), pcols, lchnk) + call outfld('PMTOT_MMR',pmtot_mmr(:,:),pcols, lchnk) + call outfld('RHO_AIR', rhoair(:,:), pcols, lchnk) + ! dmleung -- + + deallocate(maer, alnsg) + deallocate( & + wetrad, wetvol, wtrvol, wtpct, sulden, sulfeq_local, specdens_1 ) + +end subroutine modal_aero_wateruptake_dr + +!---------------------------------------------------------------------- + + end module modal_aero_wateruptake_cam diff --git a/src/physics/cam/aero_activate.F90 b/src/physics/cam/aero_activate.F90 new file mode 100644 index 0000000000..3d7d139a9a --- /dev/null +++ b/src/physics/cam/aero_activate.F90 @@ -0,0 +1,429 @@ +module aero_activate + +! Portable (CCPP-ready) Abdul-Razzak & Ghan aerosol activation kernel +! (activate_aerosol), extracted from the CAM ndrop module. The derived +! constants aten and sqrt(pi) are computed once by aero_activate_init from host +! physical constants; activate_aerosol receives the remaining host physical +! constants as arguments and returns errmsg/errflg instead of aborting. The +! polymorphic aerosol_properties abstraction is deliberately host-portable. +! CAM interface / callers: ndrop, aero_convproc. + +use shr_kind_mod, only: r8 => shr_kind_r8 +use wv_saturation, only: qsat +use shr_spfn_mod, only: erf => shr_spfn_erf + +use aerosol_properties_mod, only: aerosol_properties + +implicit none +private + +public :: aero_activate_init, activate_aerosol + +! mathematical constants +real(r8), parameter :: zero = 0._r8 +real(r8), parameter :: third = 1._r8/3._r8 +real(r8), parameter :: twothird = 2._r8*third +real(r8), parameter :: sixth = 1._r8/6._r8 +real(r8), parameter :: sq2 = sqrt(2._r8) +real(r8), parameter :: tmelt = 273._r8 + +! derived constants (set by aero_activate_init) +real(r8) :: aten +real(r8) :: sqpi + +!=============================================================================== +contains +!=============================================================================== + +subroutine aero_activate_init(mwh2o, r_universal, rhoh2o, pi) + + ! Compute the derived activation constants from host physical constants. + ! surften (surface tension of water) is a fixed property of the activation + ! parameterization, so it is set here rather than threaded from the host. + + real(r8), intent(in) :: mwh2o ! molecular weight of water (kg/kmol) + real(r8), intent(in) :: r_universal ! universal gas constant (J/K/kmol) + real(r8), intent(in) :: rhoh2o ! density of liquid water (kg/m3) + real(r8), intent(in) :: pi ! pi + + real(r8) :: surften ! surface tension of water w/respect to air (N/m) + + surften = 0.076_r8 + aten = 2._r8*mwh2o*surften/(r_universal*tmelt*rhoh2o) + sqpi = sqrt(pi) + +end subroutine aero_activate_init + +!=============================================================================== + +subroutine activate_aerosol(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & + na, nbins, volume, hygro, aero_props, & + fn, fm, fluxn, fluxm, flux_fullact, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, errmsg, errflg, & + smax_prescribed, in_cloud_in, smax_f) + + ! calculates number, surface, and mass fraction of aerosols activated as CCN + ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud + ! assumes an internal mixture within each of up to nbin multiple aerosol bins + ! a gaussiam spectrum of updrafts can be treated. + + ! mks units + + ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. + ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. + + ! input + + real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) + real(r8), intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) + real(r8), intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) + real(r8), intent(in) :: wminf ! minimum updraft velocity for integration (m/s) + real(r8), intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) + real(r8), intent(in) :: tair ! air temperature (K) + real(r8), intent(in) :: rhoair ! air density (kg/m3) + real(r8), intent(in) :: na(:) ! aerosol number concentration (/m3) + integer, intent(in) :: nbins ! number of aerosol bins + real(r8), intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) + real(r8), intent(in) :: hygro(:) ! hygroscopicity of aerosol mode + + class(aerosol_properties), intent(in) :: aero_props + + ! output + + real(r8), intent(out) :: fn(:) ! number fraction of aerosols activated + real(r8), intent(out) :: fm(:) ! mass fraction of aerosols activated + real(r8), intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) + real(r8), intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) + real(r8), intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) + ! rce-comment + ! used for consistency check -- this should match (ekd(k)*zs(k)) + ! also, fluxm/flux_fullact gives fraction of aerosol mass flux + ! that is activated + + ! host physical constants (from physconst) + error handling + real(r8), intent(in) :: pi ! pi + real(r8), intent(in) :: rhoh2o ! density of liquid water (kg/m3) + real(r8), intent(in) :: rh2o ! water vapor gas constant (J/K/kg) + real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) + real(r8), intent(in) :: latvap ! latent heat of vaporization (J/kg) + real(r8), intent(in) :: cpair ! specific heat of dry air (J/K/kg) + real(r8), intent(in) :: rair ! dry air gas constant (J/K/kg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! optional + real(r8), optional, intent(in) :: smax_prescribed ! prescribed max. supersaturation for secondary activation + logical, optional, intent(in) :: in_cloud_in ! switch to modify calculations when above cloud base + real(r8), optional, intent(in) :: smax_f ! droplet and rain size distr factor in the smax calculation + ! used when in_cloud=.true. + + ! local + + integer, parameter:: nx=200 + real(r8) integ,integf + real(r8), parameter :: p0 = 1013.25e2_r8 ! reference pressure (Pa) + real(r8) pres ! pressure (Pa) + real(r8) diff0,conduct0 + real(r8) es ! saturation vapor pressure + real(r8) qs ! water vapor saturation mixing ratio + real(r8) dqsdt ! change in qs with temperature + real(r8) g ! thermodynamic function (m2/s) + real(r8) zeta(nbins), eta(nbins) + real(r8) alpha + real(r8) gamma + real(r8) beta + real(r8) sqrtg + real(r8) :: amcube(nbins) ! cube of dry bin radius (m) + real(r8) smc(nbins) ! critical supersaturation for number bin radius + real(r8) sumflx_fullact + real(r8) sumflxn(nbins) + real(r8) sumflxm(nbins) + real(r8) sumfn(nbins) + real(r8) sumfm(nbins) + real(r8) fnold(nbins) ! number fraction activated + real(r8) fmold(nbins) ! mass fraction activated + real(r8) wold,gold + real(r8) wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb + real(r8) dfmin,dfmax,fnew,fold,fnmin,fnbar,fmbar + real(r8) alw,sqrtalw + real(r8) smax + real(r8) z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf + real(r8) etafactor1,etafactor2(nbins),etafactor2max + real(r8) grow + character(len=*), parameter :: subname='activate_aerosol' + + logical :: in_cloud + integer m,n + ! numerical integration parameters + real(r8), parameter :: eps=0.3_r8,fmax=0.99_r8,sds=3._r8 + + real(r8), parameter :: namin=1.e6_r8 ! minimum aerosol number concentration (/m3) + + errmsg = '' + errflg = 0 + + if (present(in_cloud_in)) then + if (.not. present(smax_f)) then + errmsg = subname//' error: smax_f must be supplied when in_cloud is used' + errflg = 1 + return + end if + in_cloud = in_cloud_in + else + in_cloud = .false. + end if + + fn(:)=0._r8 + fm(:)=0._r8 + fluxn(:)=0._r8 + fluxm(:)=0._r8 + flux_fullact=0._r8 + + if(nbins.eq.1.and.na(1).lt.1.e-20_r8)return + + if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return + + if ( present( smax_prescribed ) ) then + if (smax_prescribed <= 0.0_r8) return + end if + + pres=rair*rhoair*tair + diff0=0.211e-4_r8*(p0/pres)*(tair/tmelt)**1.94_r8 + conduct0=(5.69_r8+0.017_r8*(tair-tmelt))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg + call qsat(tair, pres, es, qs) + dqsdt=latvap/(rh2o*tair*tair)*qs + alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) + gamma=(1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) + etafactor2max=1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. + + grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) & + + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) + sqrtg = sqrt(grow) + beta = 2._r8*pi*rhoh2o*grow*gamma + + do m=1,nbins + + if(volume(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then + ! number mode radius (m) + amcube(m)=aero_props%amcube(m, volume(m),na(m)) + ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 + ! should depend on mean radius of mode to account for gas kinetic effects + ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 + ! for approriate size to use for effective diffusivity. + etafactor2(m)=1._r8/(na(m)*beta*sqrtg) + if(hygro(m).gt.1.e-10_r8)then + smc(m)=2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist + else + smc(m)=100._r8 + endif + else + smc(m)=1._r8 + etafactor2(m)=etafactor2max ! this should make eta big if na is very small. + endif + + enddo + + if(sigw.gt.1.e-5_r8)then ! spectrum of updrafts + + wmax=min(wmaxf,wbar+sds*sigw) + wmin=max(wminf,-wdiab) + wmin=max(wmin,wbar-sds*sigw) + w=wmin + dwmax=eps*sigw + dw=dwmax + dfmax=0.2_r8 + dfmin=0.1_r8 + if (wmax <= w) return + do m=1,nbins + sumflxn(m)=0._r8 + sumfn(m)=0._r8 + fnold(m)=0._r8 + sumflxm(m)=0._r8 + sumfm(m)=0._r8 + fmold(m)=0._r8 + enddo + sumflx_fullact=0._r8 + + fold=0._r8 + wold=0._r8 + gold=0._r8 + + dwmin = min( dwmax, 0.01_r8 ) + do n = 1, nx + +100 wnuc=w+wdiab + ! write(iulog,*)'wnuc=',wnuc + alw=alpha*wnuc + sqrtalw=sqrt(alw) + etafactor1=alw*sqrtalw + + do m=1,nbins + eta(m)=etafactor1*etafactor2(m) + zeta(m)=twothird*sqrtalw*aten/sqrtg + enddo + + if ( present( smax_prescribed ) ) then + smax = smax_prescribed + else + smax = aero_props%maxsat(zeta,eta,smc) + endif + + call aero_props%actfracs( nbins, smc(nbins), smax, fnew, fm(nbins) ) + + dwnew = dw + if(fnew-fold.gt.dfmax.and.n.gt.1)then + ! reduce updraft increment for greater accuracy in integration + if (dw .gt. 1.01_r8*dwmin) then + dw=0.7_r8*dw + dw=max(dw,dwmin) + w=wold+dw + go to 100 + else + dwnew = dwmin + endif + endif + + if(fnew-fold.lt.dfmin)then + ! increase updraft increment to accelerate integration + dwnew=min(1.5_r8*dw,dwmax) + endif + fold=fnew + + z=(w-wbar)/(sigw*sq2) + g=exp(-z*z) + fnmin=1._r8 + + do m=1,nbins + ! modal + call aero_props%actfracs( m, smc(m), smax, fn(m), fm(m) ) + fnmin=min(fn(m),fnmin) + ! integration is second order accurate + ! assumes linear variation of f*g with w + fnbar=(fn(m)*g+fnold(m)*gold) + fmbar=(fm(m)*g+fmold(m)*gold) + wb=(w+wold) + if(w.gt.0._r8)then + sumflxn(m)=sumflxn(m)+sixth*(wb*fnbar & + +(fn(m)*g*w+fnold(m)*gold*wold))*dw + sumflxm(m)=sumflxm(m)+sixth*(wb*fmbar & + +(fm(m)*g*w+fmold(m)*gold*wold))*dw + endif + sumfn(m)=sumfn(m)+0.5_r8*fnbar*dw + fnold(m)=fn(m) + sumfm(m)=sumfm(m)+0.5_r8*fmbar*dw + fmold(m)=fm(m) + enddo + ! same form as sumflxm but replace the fm with 1.0 + sumflx_fullact = sumflx_fullact & + + sixth*(wb*(g+gold) + (g*w+gold*wold))*dw + gold=g + wold=w + dw=dwnew + if (n > 1 .and. (w > wmax .or. fnmin > fmax)) exit + w=w+dw + if (n == nx) then + errmsg = subname//' -- do loop is too short in activate' + errflg = 1 + return + end if + + enddo + + if(w.lt.wmaxf)then + + ! contribution from all updrafts stronger than wmax + ! assuming constant f (close to fmax) + wnuc=w+wdiab + + z1=(w-wbar)/(sigw*sq2) + z2=(wmaxf-wbar)/(sigw*sq2) + g=exp(-z1*z1) + integ=sigw*0.5_r8*sq2*sqpi*(erf(z2)-erf(z1)) + ! consider only upward flow into cloud base when estimating flux + wf1=max(w,zero) + zf1=(wf1-wbar)/(sigw*sq2) + gf1=exp(-zf1*zf1) + wf2=max(wmaxf,zero) + zf2=(wf2-wbar)/(sigw*sq2) + gf2=exp(-zf2*zf2) + gf=(gf1-gf2) + integf=wbar*sigw*0.5_r8*sq2*sqpi*(erf(zf2)-erf(zf1))+sigw*sigw*gf + + do m=1,nbins + sumflxn(m)=sumflxn(m)+integf*fn(m) + sumfn(m)=sumfn(m)+fn(m)*integ + sumflxm(m)=sumflxm(m)+integf*fm(m) + sumfm(m)=sumfm(m)+fm(m)*integ + enddo + ! same form as sumflxm but replace the fm with 1.0 + sumflx_fullact = sumflx_fullact + integf + ! sumg=sumg+integ + endif + + + do m=1,nbins + fn(m)=sumfn(m)/(sq2*sqpi*sigw) + ! fn(m)=sumfn(m)/(sumg) + if(fn(m).gt.1.01_r8)then + errmsg = 'activate -- fn > 1' + errflg = 1 + return + endif + fluxn(m)=sumflxn(m)/(sq2*sqpi*sigw) + fm(m)=sumfm(m)/(sq2*sqpi*sigw) + ! fm(m)=sumfm(m)/(sumg) + fluxm(m)=sumflxm(m)/(sq2*sqpi*sigw) + enddo + ! same form as fluxm + flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) + + else + + ! single updraft + wnuc=wbar+wdiab + + if(wnuc.gt.0._r8)then + + w=wbar + + if(in_cloud) then + + if (smax_f > 0._r8) then + smax = alpha*w/(2.0_r8*pi*rhoh2o*grow*gamma*smax_f) + else + smax = 1.e-20_r8 + end if + + else ! at cloud base + alw = alpha*wnuc + sqrtalw = sqrt(alw) + etafactor1 = alw*sqrtalw + + do m = 1, nbins + eta(m) = etafactor1*etafactor2(m) + zeta(m) = twothird*sqrtalw*aten/sqrtg + end do + if ( present(smax_prescribed) ) then + smax = smax_prescribed + else + smax = aero_props%maxsat(zeta,eta,smc) + end if + end if + + do m=1,nbins + + call aero_props%actfracs( m, smc(m), smax, fn(m), fm(m) ) + + if(wbar.gt.0._r8)then + fluxn(m)=fn(m)*w + fluxm(m)=fm(m)*w + endif + enddo + flux_fullact = w + endif + + endif + +end subroutine activate_aerosol + +end module aero_activate diff --git a/src/physics/cam/aerosol_mmr_host.F90 b/src/physics/cam/aerosol_mmr_host.F90 index d403f02c1e..8d72396071 100644 --- a/src/physics/cam/aerosol_mmr_host.F90 +++ b/src/physics/cam/aerosol_mmr_host.F90 @@ -9,6 +9,9 @@ module aerosol_mmr_host ! referencing host-model data structures directly, making them portable. ! 2) rad_cnst_get_aer_mmr, rad_cnst_get_mode_num, bin_num, bin_mmr ! subroutines to retrieve data given the above host handle. +! 3) get_mode_dry_diameter, get_mode_wet_diameter, get_mode_aer_water +! accessors for the climate-list mode diagnostics computed by the +! calcsize/wateruptake calculations. use shr_kind_mod, only: r8 => shr_kind_r8 use physics_types, only: physics_state @@ -59,6 +62,9 @@ module aerosol_mmr_host public :: aero_host_binding_t public :: aero_host_binding ! build a handle from host data structures +public :: get_mode_dry_diameter ! dry number mode diameters of the climate list +public :: get_mode_wet_diameter ! wet number mode diameters of the climate list +public :: get_mode_aer_water ! aerosol water of the climate list modes public :: aerosol_mmr_init ! allocate zero_cols public :: get_host_idx public :: resolve_mode_idx @@ -107,6 +113,57 @@ end function aero_host_binding !================================================================================================ +subroutine get_mode_dry_diameter(host, dgnum) + + ! Return the dry number mode diameters (all modes) of the climate list, + ! computed by the modal_aero_calcsize calculation. + ! CAM: the DGNUM pbuf field. + + use physics_buffer, only: pbuf_get_field, pbuf_get_index + + type(aero_host_binding_t), intent(in) :: host + real(r8), pointer :: dgnum(:,:,:) + + call pbuf_get_field(host%pbuf, pbuf_get_index('DGNUM'), dgnum) + +end subroutine get_mode_dry_diameter + +!================================================================================================ + +subroutine get_mode_wet_diameter(host, dgnumwet) + + ! Return the wet number mode diameters (all modes) of the climate list, + ! computed by the modal_aero_wateruptake calculation. + ! CAM: the DGNUMWET pbuf field. + + use physics_buffer, only: pbuf_get_field, pbuf_get_index + + type(aero_host_binding_t), intent(in) :: host + real(r8), pointer :: dgnumwet(:,:,:) + + call pbuf_get_field(host%pbuf, pbuf_get_index('DGNUMWET'), dgnumwet) + +end subroutine get_mode_wet_diameter + +!================================================================================================ + +subroutine get_mode_aer_water(host, qaerwat) + + ! Return the aerosol water (all modes) of the climate list, + ! computed by the modal_aero_wateruptake calculation. + ! CAM: the QAERWAT pbuf field. + + use physics_buffer, only: pbuf_get_field, pbuf_get_index + + type(aero_host_binding_t), intent(in) :: host + real(r8), pointer :: qaerwat(:,:,:) + + call pbuf_get_field(host%pbuf, pbuf_get_index('QAERWAT'), qaerwat) + +end subroutine get_mode_aer_water + +!================================================================================================ + integer function get_host_idx(source, name, routine) ! get index of name in internal CAM array; either the constituent array diff --git a/src/physics/cam/aerosol_optics_cam.F90 b/src/physics/cam/aerosol_optics_cam.F90 index 025ed48974..ca244f16a6 100644 --- a/src/physics/cam/aerosol_optics_cam.F90 +++ b/src/physics/cam/aerosol_optics_cam.F90 @@ -6,7 +6,7 @@ module aerosol_optics_cam use radconstants, only: get_lw_spectral_boundaries use phys_prop, only: ot_length, numrh=>nrh use physics_types,only: physics_state - use physics_buffer,only: physics_buffer_desc, pbuf_get_field, pbuf_get_index + use physics_buffer,only: physics_buffer_desc, pbuf_get_field, pbuf_get_index, pbuf_old_tim_idx use ppgrid, only: pcols, pver use physconst, only: rga, rair use cam_abortutils, only: endrun @@ -481,6 +481,9 @@ subroutine aerosol_optics_cam_sw(list_idx, state, pbuf, nnite, idxnite, tauxar, integer :: icol integer :: lchnk, ncol integer :: num_aero_models + integer :: itim_old + + real(r8), pointer :: cldn(:,:) ! layer cloud fraction (0-1) character(len=aero_name_len) :: modetype logical :: coarse_dust_mode ! coarse dust mode for different MAM versions @@ -648,6 +651,10 @@ subroutine aerosol_optics_cam_sw(list_idx, state, pbuf, nnite, idxnite, tauxar, relh(:ncol,:) = state%q(1:ncol,:,1) / satq(:ncol,:) relh(:ncol,:) = max(1.e-20_r8,relh(:ncol,:)) + ! layer cloud fraction, for the water uptake recompute of diagnostic lists + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, pbuf_get_index('CLD'), cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + bam_cnt = 0 aeromodel: do iaermod = 1,num_aero_models @@ -699,7 +706,9 @@ subroutine aerosol_optics_cam_sw(list_idx, state, pbuf, nnite, idxnite, tauxar, call aerosol_optics_sw_bin(aeroprops, aerostate, ibin, & ncol, pver, top_lev, nswbands, nlwbands, numrh, & idx_sw_diag, & - relh(:ncol,:), sulfwtpct(:ncol,:), mass(:ncol,:), crefwsw, crefwlw, & + relh(:ncol,:), sulfwtpct(:ncol,:), & + state%t(:ncol,:), state%pmid(:ncol,:), state%q(:ncol,:,1), cldn(:ncol,:), & + mass(:ncol,:), crefwsw, crefwlw, & geometric_radius=geometric_radius, & tau_bin=tau_bin(:ncol,:,:), ssa_bin=ssa_bin(:ncol,:,:), asm_bin=asm_bin(:ncol,:,:), & pabs_vis=pabs_vis(:ncol,:), dopaer0_vis=dopaer0_vis(:ncol,:), & @@ -730,8 +739,10 @@ subroutine aerosol_optics_cam_sw(list_idx, state, pbuf, nnite, idxnite, tauxar, ! CAM diagnostics: ! Get wet/water volumes for diagnostic species partitioning - wetvol(:ncol,:pver) = aerostate%wet_volume(aeroprops, ibin, ncol, pver) - watervol(:ncol,:pver) = aerostate%water_volume(aeroprops, ibin, ncol, pver) + wetvol(:ncol,:pver) = aerostate%wet_volume(aeroprops, ibin, ncol, pver, top_lev, & + state%t(:ncol,:), state%pmid(:ncol,:), state%q(:ncol,:,1), cldn(:ncol,:)) + watervol(:ncol,:pver) = aerostate%water_volume(aeroprops, ibin, ncol, pver, top_lev, & + state%t(:ncol,:), state%pmid(:ncol,:), state%q(:ncol,:,1), cldn(:ncol,:)) ! Diagnostic accumulation using tau_bin (asphericity already applied by core) do iwav = 1, nswbands @@ -1129,6 +1140,9 @@ subroutine aerosol_optics_cam_lw(list_idx, state, pbuf, tauxar) integer :: iwav, ilev integer :: ncol, icol integer :: num_aero_models + integer :: itim_old + + real(r8), pointer :: cldn(:,:) ! layer cloud fraction (0-1) class(aerosol_state), pointer :: aerostate class(aerosol_properties), pointer :: aeroprops @@ -1168,6 +1182,10 @@ subroutine aerosol_optics_cam_lw(list_idx, state, pbuf, tauxar) relh(:ncol,:) = state%q(1:ncol,:,1) / satq(:ncol,:) relh(:ncol,:) = max(1.e-20_r8,relh(:ncol,:)) + ! layer cloud fraction, for the water uptake recompute of diagnostic lists + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, pbuf_get_index('CLD'), cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + aeromodel: do iaermod = 1,num_aero_models aeroprops => aerosol_instances_get_props(iaermod, list_idx) @@ -1198,8 +1216,10 @@ subroutine aerosol_optics_cam_lw(list_idx, state, pbuf, tauxar) ! geometric_radius is a null pointer for non-volcanic types; ! the optional pointer dummy checks associated() internally. call aerosol_optics_lw_bin(aeroprops, aerostate, ibin, & - ncol, pver, nswbands, nlwbands, numrh, & - relh(:ncol,:), sulfwtpct(:ncol,:), mass(:ncol,:), crefwsw, crefwlw, & + ncol, pver, top_lev, nswbands, nlwbands, numrh, & + relh(:ncol,:), sulfwtpct(:ncol,:), & + state%t(:ncol,:), state%pmid(:ncol,:), state%q(:ncol,:,1), cldn(:ncol,:), & + mass(:ncol,:), crefwsw, crefwlw, & geometric_radius=geometric_radius, & tau_lw_bin=tau_lw_bin(:ncol,:,:), absorp_bin=absorp_bin(:ncol,:,:), & errmsg=errmsg, errflg=errflg) diff --git a/src/physics/cam/microp_aero.F90 b/src/physics/cam/microp_aero.F90 index ccc6383f63..35986213a7 100644 --- a/src/physics/cam/microp_aero.F90 +++ b/src/physics/cam/microp_aero.F90 @@ -25,9 +25,9 @@ module microp_aero use spmd_utils, only: masterproc use ppgrid, only: pcols, pver, pverp use ref_pres, only: top_lev => trop_cloud_top_lev -use physconst, only: rair, gravit, tmelt, cpair, rh2o, rhoh2o, latvap, & +use physconst, only: pi, rair, gravit, tmelt, cpair, rh2o, rhoh2o, latvap, & r_universal, mwh2o -use constituents, only: cnst_get_ind +use constituents, only: pcnst, cnst_get_ind use physics_types, only: physics_state, physics_ptend, physics_ptend_init, physics_ptend_sum, & physics_state_copy, physics_update use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field @@ -43,8 +43,7 @@ module microp_aero nucleate_ice_cam_init, nucleate_ice_cam_calc use ndrop, only: ndrop_init, dropmixnuc -use ndrop_bam, only: ndrop_bam_init, ndrop_bam_calc, & - aername, psat, ccn_name +use ndrop_bam, only: ndrop_bam_init, ndrop_bam_calc, aername use hetfrz_classnuc_cam, only: hetfrz_classnuc_cam_readnl, hetfrz_classnuc_cam_register, hetfrz_classnuc_cam_init, & hetfrz_classnuc_cam_calc @@ -54,7 +53,7 @@ module microp_aero compute_subgrid_vertical_velocity_clubb_run use scale_subgrid_vertical_velocity, only: scale_subgrid_vertical_velocity_run -use cam_history, only: addfld, add_default, outfld +use cam_history, only: addfld, add_default, horiz_only, fieldname_len, outfld use cam_logfile, only: iulog use cam_abortutils, only: endrun @@ -128,6 +127,26 @@ module microp_aero integer :: naer_all = 0 integer :: npccn_idx, rndst_idx, nacon_idx +! dropmixnuc CAM interface data (moved from ndrop) +! psat/ccn_name serve the CCN diagnostics of both the modal (dropmixnuc) and +! bulk (ndrop_bam) paths; the values match the psat/supersat conventions of both. +integer, parameter :: psat = 6 ! number of supersaturations used to calc ccn concentration +character(len=8) :: ccn_name(psat)= & + (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6'/) + +logical :: history_aerosol ! Output the aerosol tendencies +character(len=fieldname_len), allocatable :: fieldname(:) ! names for drop nuc tendency output fields +character(len=fieldname_len), allocatable :: fieldname_cw(:) ! names for drop nuc tendency output fields + +! Indices for aerosol species in the ptend%q array. +integer, allocatable :: aer_cnst_idx(:,:) + +logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies + ! in the ptend object + +! true for aerosol elements resolving to advected constituents (dropmixnuc tendency-return) +logical, allocatable :: dotend(:) + logical :: separate_dust = .false. class(aerosol_properties), pointer :: aero_props_obj=>null() @@ -178,10 +197,16 @@ subroutine microp_aero_init(phys_state,pbuf2d) integer :: iaer integer :: m, n, nspec integer :: iaermod + integer :: l, mm + integer :: idxtmp = -1 character(len=32) :: str32 character(len=*), parameter :: routine = 'microp_aero_init' logical :: history_amwg + character(len=32) :: tmpname + character(len=32) :: tmpname_cw + character(len=128) :: long_name + character(len=8) :: unit character(len=512) :: errmsg integer :: errflg @@ -192,7 +217,8 @@ subroutine microp_aero_init(phys_state,pbuf2d) ! Query the PBL eddy scheme call phys_getopts(eddy_scheme_out = eddy_scheme, & - history_amwg_out = history_amwg ) + history_amwg_out = history_amwg, & + history_aerosol_out = history_aerosol ) ! Access the physical properties of the aerosols that are affecting the climate ! by using routines from the rad_constituents module. @@ -233,7 +259,85 @@ subroutine microp_aero_init(phys_state,pbuf2d) end if end if end do - call ndrop_init(aero_props_obj) + call ndrop_init(aero_props_obj, pi, rhoh2o, mwh2o, r_universal, & + rh2o, gravit, latvap, cpair, rair) + + ! dropmixnuc CAM interface init (moved from ndrop_init). + ! dropmixnuc needs kvh from pbuf regardless of the eddy scheme. + kvh_idx = pbuf_get_index('kvh') + + allocate( & + aer_cnst_idx(aero_props_obj%nbins(),0:maxval(aero_props_obj%nmasses())), & + fieldname(aero_props_obj%ncnst_tot()), & + fieldname_cw(aero_props_obj%ncnst_tot()), & + dotend(aero_props_obj%ncnst_tot()) ) + + ! Add dropmixnuc tendencies for all modal aerosol species + + do m = 1, aero_props_obj%nbins() + do l = 0, aero_props_obj%nmasses(m) + + mm = aero_props_obj%indexer(m,l) + + unit = 'kg/m2/s' + if (l == 0) then ! number + unit = '#/m2/s' + end if + + if (l == 0) then ! number + call aero_props_obj%num_names( m, tmpname, tmpname_cw) + else + call aero_props_obj%mmr_names( m,l, tmpname, tmpname_cw) + end if + + fieldname(mm) = trim(tmpname) // '_mixnuc1' + fieldname_cw(mm) = trim(tmpname_cw) // '_mixnuc1' + + ! To set tendencies in the ptend object need to get the constituent indices + ! for the prognostic species + + call cnst_get_ind(tmpname, idxtmp, abort=.false.) + aer_cnst_idx(m,l) = idxtmp + dotend(mm) = idxtmp > 0 + + if (idxtmp>0) then + lq(idxtmp) = .true. + end if + + ! Add tendency fields to the history only when prognostic MAM is enabled. + long_name = trim(tmpname) // ' dropmixnuc mixnuc column tendency' + call addfld(fieldname(mm), horiz_only, 'A', unit, long_name, sampled_on_subcycle=.true.) + + long_name = trim(tmpname_cw) // ' dropmixnuc mixnuc column tendency' + call addfld(fieldname_cw(mm), horiz_only, 'A', unit, long_name, sampled_on_subcycle=.true.) + + if (history_aerosol) then + call add_default(fieldname(mm), 1, ' ') + call add_default(fieldname_cw(mm), 1, ' ') + end if + + end do + end do + + call addfld('CCN1',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.02%', sampled_on_subcycle=.true.) + call addfld('CCN2',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.05%', sampled_on_subcycle=.true.) + call addfld('CCN3',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.1%', sampled_on_subcycle=.true.) + call addfld('CCN4',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.2%', sampled_on_subcycle=.true.) + call addfld('CCN5',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.5%', sampled_on_subcycle=.true.) + call addfld('CCN6',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=1.0%', sampled_on_subcycle=.true.) + + + call addfld('WTKE', (/ 'lev' /), 'A', 'm/s', 'Standard deviation of updraft velocity', sampled_on_subcycle=.true.) + call addfld('NDROPMIX', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number mixing', sampled_on_subcycle=.true.) + call addfld('NDROPSRC', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number source', sampled_on_subcycle=.true.) + call addfld('NDROPSNK', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number loss by microphysics', sampled_on_subcycle=.true.) + call addfld('NDROPCOL', horiz_only, 'A', '#/m2', 'Column droplet number', sampled_on_subcycle=.true.) + + ! set the add_default fields + if (history_amwg) then + call add_default('CCN3', 1, ' ') + call add_default('CCN4', 1, ' ') + endif end if if (clim_modal_aero) then @@ -554,6 +658,17 @@ subroutine microp_aero_run ( & real(r8), allocatable :: factnum(:,:,:) ! activation fraction for aerosol number + ! dropmixnuc work arrays and diagnostics (CAM marshal, moved from ndrop) + real(r8), allocatable :: raertend_out(:,:,:) ! tendency of interstitial aerosol mass, number mixing ratios + real(r8), allocatable :: coltend(:,:) ! column tendency for diagnostic output + real(r8), allocatable :: coltend_cw(:,:) ! column tendency + real(r8) :: wtke(pcols,pver) ! turbulent vertical velocity at base of layer k (m/s) + real(r8) :: nsource(pcols,pver) ! droplet number source (#/kg/s) + real(r8) :: ndropmix(pcols,pver) ! droplet number mixing (#/kg/s) + real(r8) :: ndropcol(pcols) ! column droplet number (#/m2) + real(r8) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat + integer :: mm, lptr + class(aerosol_state), pointer :: aero_state1_obj type(aero_state_entry_t), allocatable :: aero_states1(:) integer :: nstates1, iaermod @@ -739,21 +854,140 @@ subroutine microp_aero_run ( & if (astat/=0) then call endrun('microp_aero_run: not able to allocate factnum') endif + allocate(raertend_out(pcols,pver,aero_props_obj%ncnst_tot()), & + coltend(pcols,aero_props_obj%ncnst_tot()), & + coltend_cw(pcols,aero_props_obj%ncnst_tot()),stat=astat) + if (astat/=0) then + call endrun('microp_aero_run: not able to allocate dropmixnuc work arrays') + endif + + ! dropmixnuc CAM marshaling (moved from ndrop): kvh from pbuf, ptend + ! initialized with the aerosol lq mask. + call pbuf_get_field(pbuf, kvh_idx, kvh) + + ! initialize aerosol tendencies + call physics_ptend_init(ptend_loc, state1%psetcols, 'ndrop', lq=lq) + + !REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + nctend_mixnuc(:,:) = 0._r8 + factnum(:,:,:) = 0._r8 + raertend_out(:,:,:) = 0._r8 + wtke(:,:) = 0._r8 + nsource(:,:) = 0._r8 + ndropmix(:,:) = 0._r8 + ndropcol(:) = 0._r8 + ccn(:,:,:) = 0._r8 + coltend(:,:) = 0._r8 + coltend_cw(:,:) = 0._r8 + !REMOVECAM_END ! If not using preexsiting ice, then only use cloudbourne aerosol for the ! liquid clouds. This is the same behavior as CAM5. - ! - ! ptend_loc is initialized inside dropmixnuc if (use_preexisting_ice) then - call dropmixnuc( aero_props_obj, aero_state1_obj, & - state1, ptend_loc, deltatin, pbuf, wsub, wsub_min_asf, & - cldn, cldo, cldliqf, nctend_mixnuc, factnum) + call dropmixnuc( & + aero_props = aero_props_obj, & + aero_state = aero_state1_obj, & + ncol = ncol, & + pver = pver, & + top_lev = top_lev, & + dtmicro = deltatin, & + temp = state1%t(1:ncol,:), & + pmid = state1%pmid(1:ncol,:), & + pint = state1%pint(1:ncol,:), & + pdel = state1%pdel(1:ncol,:), & + rpdel = state1%rpdel(1:ncol,:), & + zm = state1%zm(1:ncol,:), & + kvh = kvh(1:ncol,:), & + ncldwtr = state1%q(1:ncol,:,numliq_idx), & + wsub = wsub(1:ncol,:), & + wmixmin = wsub_min_asf, & + cldn = cldn(1:ncol,:), & + cldo = cldo(1:ncol,:), & + cldliqf = cldliqf(1:ncol,:), & + dotend = dotend, & + raertend_out = raertend_out(1:ncol,:,:), & + tendnd = nctend_mixnuc(1:ncol,:), & + factnum = factnum(1:ncol,:,:), & + wtke = wtke(1:ncol,:), & + nsource = nsource(1:ncol,:), & + ndropmix = ndropmix(1:ncol,:), & + ndropcol = ndropcol(1:ncol), & + ccn = ccn(1:ncol,:,:), & + coltend = coltend(1:ncol,:), & + coltend_cw = coltend_cw(1:ncol,:), & + errmsg = errmsg, & + errflg = errflg) else cldliqf = 1._r8 - call dropmixnuc( aero_props_obj, aero_state1_obj, & - state1, ptend_loc, deltatin, pbuf, wsub, wsub_min_asf, & - lcldn, lcldo, cldliqf, nctend_mixnuc, factnum) + call dropmixnuc( & + aero_props = aero_props_obj, & + aero_state = aero_state1_obj, & + ncol = ncol, & + pver = pver, & + top_lev = top_lev, & + dtmicro = deltatin, & + temp = state1%t(1:ncol,:), & + pmid = state1%pmid(1:ncol,:), & + pint = state1%pint(1:ncol,:), & + pdel = state1%pdel(1:ncol,:), & + rpdel = state1%rpdel(1:ncol,:), & + zm = state1%zm(1:ncol,:), & + kvh = kvh(1:ncol,:), & + ncldwtr = state1%q(1:ncol,:,numliq_idx), & + wsub = wsub(1:ncol,:), & + wmixmin = wsub_min_asf, & + cldn = lcldn(1:ncol,:), & + cldo = lcldo(1:ncol,:), & + cldliqf = cldliqf(1:ncol,:), & + dotend = dotend, & + raertend_out = raertend_out(1:ncol,:,:), & + tendnd = nctend_mixnuc(1:ncol,:), & + factnum = factnum(1:ncol,:,:), & + wtke = wtke(1:ncol,:), & + nsource = nsource(1:ncol,:), & + ndropmix = ndropmix(1:ncol,:), & + ndropcol = ndropcol(1:ncol), & + ccn = ccn(1:ncol,:,:), & + coltend = coltend(1:ncol,:), & + coltend_cw = coltend_cw(1:ncol,:), & + errmsg = errmsg, & + errflg = errflg) end if + if (errflg /= 0) then + call endrun('microp_aero_run: dropmixnuc: '//trim(errmsg)) + end if + + ! set ptend tendencies for the advected interstitial aerosol elements + ! (non-advected interstitial elements and cloud-borne aerosol were + ! updated in place by dropmixnuc through the aero_state pointers) + do m = 1, aero_props_obj%nbins() + do l = 0, aero_props_obj%nmasses(m) + mm = aero_props_obj%indexer(m,l) + lptr = aer_cnst_idx(m,l) + if (lptr > 0) then ! advected aerosol parts + ptend_loc%q(1:ncol,:,lptr) = raertend_out(1:ncol,:,mm) + end if + end do + end do + + ! dropmixnuc history output (moved from ndrop) + call outfld('NDROPCOL', ndropcol, pcols, lchnk) + call outfld('NDROPSRC', nsource, pcols, lchnk) + call outfld('NDROPMIX', ndropmix, pcols, lchnk) + call outfld('WTKE ', wtke, pcols, lchnk) + + do l = 1, psat + call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) + enddo + + ! do column tendencies + do m = 1, aero_props_obj%nbins() + do l = 0, aero_props_obj%nmasses(m) + mm = aero_props_obj%indexer(m,l) + call outfld(fieldname(mm), coltend(:,mm), pcols, lchnk) + call outfld(fieldname_cw(mm), coltend_cw(:,mm), pcols, lchnk) + end do + end do npccn(:ncol,:) = nctend_mixnuc(:ncol,:) @@ -896,7 +1130,7 @@ subroutine microp_aero_run ( & end if if (clim_modal_aero.or.clim_carma_aero) then - deallocate(factnum) + deallocate(factnum, raertend_out, coltend, coltend_cw) end if ! destroy all aerosol state objects created for this chunk diff --git a/src/physics/cam/ndrop.F90 b/src/physics/cam/ndrop.F90 index ab5925b4d0..f53d431af3 100644 --- a/src/physics/cam/ndrop.F90 +++ b/src/physics/cam/ndrop.F90 @@ -2,7 +2,11 @@ module ndrop !--------------------------------------------------------------------------------- ! Purpose: -! CAM Interface for droplet activation by modal aerosols +! Droplet activation and vertical mixing by modal (or bin) aerosols +! (dropmixnuc). Portable science routines split from the CAM interface, +! which now lives in microp_aero.F90. Aerosol access is polymorphic through +! aerosol_properties/aerosol_state; host physical constants are provided by +! ndrop_init; array sizing is by runtime ncol/pver. ! ! ***N.B.*** This module is currently hardcoded to recognize only the modes that ! affect the climate calculation. This is implemented by using list @@ -10,63 +14,44 @@ module ndrop !--------------------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8, shr_kind_cs -use ppgrid, only: pcols, pver -use physconst, only: pi, rhoh2o, mwh2o, r_universal, rh2o, & - gravit, latvap, cpair, rair -use constituents, only: pcnst, cnst_get_ind, cnst_name, cnst_spec_class_gas, cnst_species_class -use physics_types, only: physics_state, physics_ptend, physics_ptend_init -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field - -use wv_saturation, only: qsat -use phys_control, only: phys_getopts -use ref_pres, only: top_lev => trop_cloud_top_lev use shr_spfn_mod, only: erf => shr_spfn_erf -use cam_history, only: addfld, add_default, horiz_only, fieldname_len, outfld -use cam_abortutils, only: endrun -use cam_logfile, only: iulog use aerosol_properties_mod, only: aerosol_properties use aerosol_state_mod, only: aerosol_state, ptr2d_t +use aero_activate, only: aero_activate_init, activate_aerosol + implicit none private save -public ndrop_init, dropmixnuc, activate_aerosol +public ndrop_init, dropmixnuc +public psat ! needed by the CAM interface to size the ccn diagnostic ! mathematical constants real(r8), parameter :: zero = 0._r8 real(r8), parameter :: third = 1._r8/3._r8 real(r8), parameter :: twothird = 2._r8*third -real(r8), parameter :: sixth = 1._r8/6._r8 real(r8), parameter :: sq2 = sqrt(2._r8) -real(r8), parameter :: sq2pi = sqrt(2._r8*pi) -real(r8), parameter :: sqpi = sqrt(pi) real(r8), parameter :: surften = 0.076_r8 -real(r8), parameter :: tmelt = 273._r8 - -real(r8) :: aten ! CCN diagnostic fields integer, parameter :: psat=6 ! number of supersaturations to calc ccn concentration real(r8), parameter :: supersat(psat)= & ! supersaturation (%) to determine ccn concentration (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) -character(len=8) :: ccn_name(psat)= & - (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6'/) - -! indices in state and pbuf structures -integer :: numliq_idx = -1 -integer :: kvh_idx = -1 - -logical :: history_aerosol ! Output the aerosol tendencies -character(len=fieldname_len), allocatable :: fieldname(:) ! names for drop nuc tendency output fields -character(len=fieldname_len), allocatable :: fieldname_cw(:) ! names for drop nuc tendency output fields -! Indices for aerosol species in the ptend%q array. -integer, allocatable :: aer_cnst_idx(:,:) +! host physical constants (set by ndrop_init) +real(r8) :: pi ! pi +real(r8) :: rhoh2o ! density of liquid water (kg/m3) +real(r8) :: mwh2o ! molecular weight of water (kg/kmol) +real(r8) :: r_universal ! universal gas constant (J/K/kmol) +real(r8) :: rh2o ! water vapor gas constant (J/K/kg) +real(r8) :: gravit ! gravitational acceleration (m/s2) +real(r8) :: latvap ! latent heat of vaporization (J/kg) +real(r8) :: cpair ! specific heat of dry air (J/K/kg) +real(r8) :: rair ! dry air gas constant (J/K/kg) -logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies - ! in the ptend object +real(r8) :: sq2pi ! sqrt(2*pi), derived from host pi by ndrop_init integer :: nbin ! number of bins @@ -74,152 +59,101 @@ module ndrop contains !=============================================================================== -subroutine ndrop_init(aero_props) +subroutine ndrop_init(aero_props, pi_in, rhoh2o_in, mwh2o_in, r_universal_in, & + rh2o_in, gravit_in, latvap_in, cpair_in, rair_in) class(aerosol_properties), intent(in) :: aero_props - integer :: l, m, mm - integer :: idxtmp = -1 - character(len=32) :: tmpname - character(len=32) :: tmpname_cw - character(len=128) :: long_name - character(len=8) :: unit - logical :: history_amwg ! output the variables used by the AMWG diag package + ! host physical constants + real(r8), intent(in) :: pi_in ! pi + real(r8), intent(in) :: rhoh2o_in ! density of liquid water (kg/m3) + real(r8), intent(in) :: mwh2o_in ! molecular weight of water (kg/kmol) + real(r8), intent(in) :: r_universal_in ! universal gas constant (J/K/kmol) + real(r8), intent(in) :: rh2o_in ! water vapor gas constant (J/K/kg) + real(r8), intent(in) :: gravit_in ! gravitational acceleration (m/s2) + real(r8), intent(in) :: latvap_in ! latent heat of vaporization (J/kg) + real(r8), intent(in) :: cpair_in ! specific heat of dry air (J/K/kg) + real(r8), intent(in) :: rair_in ! dry air gas constant (J/K/kg) !------------------------------------------------------------------------------- - ! get indices into state%q and pbuf structures - call cnst_get_ind('NUMLIQ', numliq_idx) + pi = pi_in + rhoh2o = rhoh2o_in + mwh2o = mwh2o_in + r_universal = r_universal_in + rh2o = rh2o_in + gravit = gravit_in + latvap = latvap_in + cpair = cpair_in + rair = rair_in - kvh_idx = pbuf_get_index('kvh') + sq2pi = sqrt(2._r8*pi) - aten = 2._r8*mwh2o*surften/(r_universal*tmelt*rhoh2o) + call aero_activate_init(mwh2o, r_universal, rhoh2o, pi) nbin = aero_props%nbins() - allocate( & - aer_cnst_idx(aero_props%nbins(),0:maxval(aero_props%nmasses())), & - fieldname(aero_props%ncnst_tot()), & - fieldname_cw(aero_props%ncnst_tot()) ) - - ! Add dropmixnuc tendencies for all modal aerosol species - - call phys_getopts(history_amwg_out = history_amwg, & - history_aerosol_out = history_aerosol) - - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - - mm = aero_props%indexer(m,l) - - unit = 'kg/m2/s' - if (l == 0) then ! number - unit = '#/m2/s' - end if - - if (l == 0) then ! number - call aero_props%num_names( m, tmpname, tmpname_cw) - else - call aero_props%mmr_names( m,l, tmpname, tmpname_cw) - end if - - fieldname(mm) = trim(tmpname) // '_mixnuc1' - fieldname_cw(mm) = trim(tmpname_cw) // '_mixnuc1' - - ! To set tendencies in the ptend object need to get the constituent indices - ! for the prognostic species - - call cnst_get_ind(tmpname, idxtmp, abort=.false.) - aer_cnst_idx(m,l) = idxtmp - - if (idxtmp>0) then - lq(idxtmp) = .true. - end if - - ! Add tendency fields to the history only when prognostic MAM is enabled. - long_name = trim(tmpname) // ' dropmixnuc mixnuc column tendency' - call addfld(fieldname(mm), horiz_only, 'A', unit, long_name, sampled_on_subcycle=.true.) - - long_name = trim(tmpname_cw) // ' dropmixnuc mixnuc column tendency' - call addfld(fieldname_cw(mm), horiz_only, 'A', unit, long_name, sampled_on_subcycle=.true.) - - if (history_aerosol) then - call add_default(fieldname(mm), 1, ' ') - call add_default(fieldname_cw(mm), 1, ' ') - end if - - end do - end do - - call addfld('CCN1',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.02%', sampled_on_subcycle=.true.) - call addfld('CCN2',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.05%', sampled_on_subcycle=.true.) - call addfld('CCN3',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.1%', sampled_on_subcycle=.true.) - call addfld('CCN4',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.2%', sampled_on_subcycle=.true.) - call addfld('CCN5',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.5%', sampled_on_subcycle=.true.) - call addfld('CCN6',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=1.0%', sampled_on_subcycle=.true.) - - - call addfld('WTKE', (/ 'lev' /), 'A', 'm/s', 'Standard deviation of updraft velocity', sampled_on_subcycle=.true.) - call addfld('NDROPMIX', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number mixing', sampled_on_subcycle=.true.) - call addfld('NDROPSRC', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number source', sampled_on_subcycle=.true.) - call addfld('NDROPSNK', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number loss by microphysics', sampled_on_subcycle=.true.) - call addfld('NDROPCOL', horiz_only, 'A', '#/m2', 'Column droplet number', sampled_on_subcycle=.true.) - - ! set the add_default fields - if (history_amwg) then - call add_default('CCN3', 1, ' ') - call add_default('CCN4', 1, ' ') - endif - end subroutine ndrop_init !=============================================================================== subroutine dropmixnuc( aero_props, aero_state, & - state, ptend, dtmicro, pbuf, wsub, wmixmin, & - cldn, cldo, cldliqf, tendnd, factnum) + ncol, pver, top_lev, dtmicro, & + temp, pmid, pint, pdel, rpdel, zm, kvh, ncldwtr, & + wsub, wmixmin, cldn, cldo, cldliqf, & + dotend, raertend_out, tendnd, factnum, & + wtke, nsource, ndropmix, ndropcol, & + ccn, coltend, coltend_cw, & + errmsg, errflg) ! vertical diffusion and nucleation of cloud droplets ! assume cloud presence controlled by cloud fraction ! doesn't distinguish between warm, cold clouds ! arguments - type(physics_state), target, intent(in) :: state - type(physics_ptend), intent(out) :: ptend - real(r8), intent(in) :: dtmicro ! time step for microphysics (s) - real(r8), intent(in) :: wmixmin ! minimum turbulence vertical velocity (m/s) - - type(physics_buffer_desc), pointer :: pbuf(:) - class(aerosol_properties), intent(in) :: aero_props class(aerosol_state), intent(in) :: aero_state - ! arguments - real(r8), intent(in) :: wsub(pcols,pver) ! subgrid vertical velocity - real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction - real(r8), intent(in) :: cldo(pcols,pver) ! cloud fraction on previous time step - real(r8), intent(in) :: cldliqf(pcols,pver) ! liquid cloud fraction (liquid / (liquid + ice)) + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: pver ! number of vertical layers + integer, intent(in) :: top_lev ! top level for cloud physics + real(r8), intent(in) :: dtmicro ! time step for microphysics (s) + real(r8), intent(in) :: temp(:,:) ! temperature (K) + real(r8), intent(in) :: pmid(:,:) ! mid-level pressure (Pa) + real(r8), intent(in) :: pint(:,:) ! pressure at layer interfaces (Pa) + real(r8), intent(in) :: pdel(:,:) ! pressure thickess of layer (Pa) + real(r8), intent(in) :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) + real(r8), intent(in) :: zm(:,:) ! geopotential height of level (m) + real(r8), intent(in) :: kvh(:,:) ! vertical diffusivity (m2/s), interfaces + real(r8), intent(in) :: ncldwtr(:,:)! droplet number concentration (#/kg) + real(r8), intent(in) :: wsub(:,:) ! subgrid vertical velocity + real(r8), intent(in) :: wmixmin ! minimum turbulence vertical velocity (m/s) + real(r8), intent(in) :: cldn(:,:) ! cloud fraction + real(r8), intent(in) :: cldo(:,:) ! cloud fraction on previous time step + real(r8), intent(in) :: cldliqf(:,:)! liquid cloud fraction (liquid / (liquid + ice)) + logical, intent(in) :: dotend(:) ! (nele_tot) true for aerosol elements resolving to + ! advected constituents: tendency returned in raertend_out. + ! false elements are updated in place through the + ! aero_state interstitial pointers. ! output arguments - real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) + real(r8), intent(out) :: raertend_out(:,:,:) ! (ncol,pver,nele_tot) tendency of interstitial aerosol + ! mass, number mixing ratios, only where dotend is true + real(r8), intent(out) :: tendnd(:,:) ! change in droplet number concentration (#/kg/s) real(r8), intent(out) :: factnum(:,:,:) ! activation fraction for aerosol number + real(r8), intent(out) :: wtke(:,:) ! turbulent vertical velocity at base of layer k (m/s) + real(r8), intent(out) :: nsource(:,:) ! droplet number source (#/kg/s) + real(r8), intent(out) :: ndropmix(:,:) ! droplet number mixing (#/kg/s) + real(r8), intent(out) :: ndropcol(:) ! column droplet number (#/m2) + real(r8), intent(out) :: ccn(:,:,:) ! (ncol,pver,psat) number conc of aerosols activated at supersat (#/cm3) + real(r8), intent(out) :: coltend(:,:) ! (ncol,nele_tot) column tendency for diagnostic output + real(r8), intent(out) :: coltend_cw(:,:) ! (ncol,nele_tot) column tendency + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !--------------------Local storage------------------------------------- - integer :: lchnk ! chunk identifier - integer :: ncol ! number of columns integer :: nele_tot ! total number of aerosol elements - real(r8), pointer :: ncldwtr(:,:) ! droplet number concentration (#/kg) - real(r8), pointer :: temp(:,:) ! temperature (K) - real(r8), pointer :: pmid(:,:) ! mid-level pressure (Pa) - real(r8), pointer :: pint(:,:) ! pressure at layer interfaces (Pa) - real(r8), pointer :: pdel(:,:) ! pressure thickess of layer (Pa) - real(r8), pointer :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) - real(r8), pointer :: zm(:,:) ! geopotential height of level (m) - - real(r8), pointer :: kvh(:,:) ! vertical diffusivity (m2/s) - type(ptr2d_t), allocatable :: raer(:) ! aerosol mass, number mixing ratios type(ptr2d_t), allocatable :: qqcw(:) real(r8) :: raertend(pver) ! tendency of aerosol mass, number mixing ratios @@ -229,28 +163,27 @@ subroutine dropmixnuc( aero_props, aero_state, & integer :: i, k, l, m, mm, n integer :: km1, kp1 integer :: nnew, nsav, ntemp - integer :: lptr integer :: nsubmix, nsubmix_bnd integer, save :: count_submix(100) integer :: phase ! phase of aerosol real(r8) :: arg real(r8) :: dtinv + real(r8) :: dtmin, tinv, dtt - real(r8) :: lcldn(pcols,pver) - real(r8) :: lcldo(pcols,pver) + real(r8) :: lcldn(ncol,pver) + real(r8) :: lcldo(ncol,pver) real(r8) :: zs(pver) ! inverse of distance between levels (m) real(r8) :: qcld(pver) ! cloud droplet number mixing ratio (#/kg) real(r8) :: qncld(pver) ! droplet number nucleated on cloud boundaries real(r8) :: srcn(pver) ! droplet source rate (/s) - real(r8) :: cs(pcols,pver) ! air density (kg/m3) + real(r8) :: cs(ncol,pver) ! air density (kg/m3) real(r8) :: csbot(pver) ! air density at bottom (interface) of layer (kg/m3) real(r8) :: csbot_cscen(pver) ! csbot(i)/cs(i,k) - real(r8) :: dz(pcols,pver) ! geometric thickness of layers (m) + real(r8) :: dz(ncol,pver) ! geometric thickness of layers (m) - real(r8) :: wtke(pcols,pver) ! turbulent vertical velocity at base of layer k (m/s) - real(r8) :: wtke_cen(pcols,pver) ! turbulent vertical velocity at center of layer k (m/s) + real(r8) :: wtke_cen(ncol,pver) ! turbulent vertical velocity at center of layer k (m/s) real(r8) :: wbar, wmix, wmin, wmax real(r8) :: zn(pver) ! g/pdel (m2/g) for layer @@ -270,9 +203,6 @@ subroutine dropmixnuc( aero_props, aero_state, & real(r8) :: alogarg real(r8) :: overlapp(pver), overlapm(pver) ! cloud overlap - real(r8) :: nsource(pcols,pver) ! droplet number source (#/kg/s) - real(r8) :: ndropmix(pcols,pver) ! droplet number mixing (#/kg/s) - real(r8) :: ndropcol(pcols) ! column droplet number (#/m2) real(r8) :: cldo_tmp, cldn_tmp real(r8) :: tau_cld_regenerate real(r8) :: taumix_internal_pver_inv ! 1/(internal mixing time scale for k=pver) (1/s) @@ -285,7 +215,7 @@ subroutine dropmixnuc( aero_props, aero_state, & real(r8), allocatable :: raercol_cw(:,:,:) ! same as raercol but for cloud-borne phase - real(r8) :: na(pcols,pver,nbin), va(pcols,pver,nbin), hy(pcols,pver,nbin) + real(r8) :: na(ncol,pver,nbin), va(ncol,pver,nbin), hy(ncol,pver,nbin) real(r8), allocatable :: naermod(:) ! (1/m3) real(r8), allocatable :: hygro(:) ! hygroscopicity of aerosol mode real(r8), allocatable :: vaerosol(:) ! interstit+activated aerosol volume conc (cm3/cm3) @@ -303,34 +233,14 @@ subroutine dropmixnuc( aero_props, aero_state, & ! / [aero. number conc. in updraft, just below cloudbase (#/cm3)] - real(r8), allocatable :: coltend(:,:) ! column tendency for diagnostic output - real(r8), allocatable :: coltend_cw(:,:) ! column tendency - real(r8) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat - - !for gas species turbulent mixing - real(r8), pointer :: rgas(:, :, :) - real(r8), allocatable :: rgascol(:, :, :) - real(r8), allocatable :: coltendgas(:) - real(r8) :: zerogas(pver) - character*200 fieldnamegas - integer :: errnum character(len=shr_kind_cs) :: errstr !------------------------------------------------------------------------------- - lchnk = state%lchnk - ncol = state%ncol - nele_tot = aero_props%ncnst_tot() - - ncldwtr => state%q(:,:,numliq_idx) - temp => state%t - pmid => state%pmid - pint => state%pint - pdel => state%pdel - rpdel => state%rpdel - zm => state%zm + errmsg = '' + errflg = 0 - call pbuf_get_field(pbuf, kvh_idx, kvh) + nele_tot = aero_props%ncnst_tot() ! Create the liquid weighted cloud fractions that were passsed in ! before. This doesn't seem like the best variable, since the cloud could @@ -342,14 +252,15 @@ subroutine dropmixnuc( aero_props, aero_state, & arg = 1.0_r8 if (abs(0.8427_r8 - erf(arg))/0.8427_r8 > 0.001_r8) then - write(iulog,*) 'erf(1.0) = ',ERF(arg) - call endrun('dropmixnuc: Error function error') + write(errmsg,*) 'dropmixnuc: Error function error, erf(1.0) = ',ERF(arg) + errflg = 1 + return endif arg = 0.0_r8 if (erf(arg) /= 0.0_r8) then - write(iulog,*) 'erf(0.0) = ',erf(arg) - write(iulog,*) 'dropmixnuc: Error function error' - call endrun('dropmixnuc: Error function error') + write(errmsg,*) 'dropmixnuc: Error function error, erf(0.0) = ',erf(arg) + errflg = 1 + return endif dtinv = 1._r8/dtmicro @@ -361,8 +272,6 @@ subroutine dropmixnuc( aero_props, aero_state, & qqcw(nele_tot), & raercol(pver,nele_tot,2), & raercol_cw(pver,nele_tot,2), & - coltend(pcols,nele_tot), & - coltend_cw(pcols,nele_tot), & naermod(nbin), & hygro(nbin), & vaerosol(nbin), & @@ -381,9 +290,7 @@ subroutine dropmixnuc( aero_props, aero_state, & ndropmix = 0._r8 ndropcol = 0._r8 tendnd = 0._r8 - - ! initialize aerosol tendencies - call physics_ptend_init(ptend, state%psetcols, 'ndrop', lq=lq) + raertend_out = 0._r8 ! air density (kg/m3) cs(:ncol,:) = pmid(:ncol,:)/(rair*temp(:ncol,:)) @@ -395,7 +302,9 @@ subroutine dropmixnuc( aero_props, aero_state, & m, cs, phase, na(:,:,m), va(:,:,m), & hy(:,:,m), errnum, errstr) if (errnum/=0) then - call endrun('dropmixnuc : '//trim(errstr)) + errmsg = 'dropmixnuc : '//trim(errstr) + errflg = 1 + return end if end do @@ -546,7 +455,10 @@ subroutine dropmixnuc( aero_props, aero_state, & wbar, wmix, wdiab, wmin, wmax, & temp(i,k), cs(i,k), naermod, nbin, & vaerosol, hygro, aero_props, fn, fm, fluxn, & - fluxm,flux_fullact(k)) + fluxm,flux_fullact(k), & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & + errmsg, errflg) + if (errflg /= 0) return factnum(i,k,:) = fn @@ -629,7 +541,10 @@ subroutine dropmixnuc( aero_props, aero_state, & wbar, wmix, wdiab, wmin, wmax, & temp(i,k), cs(i,k), naermod, nbin, & vaerosol, hygro, aero_props, fn, fm, fluxn, & - fluxm, flux_fullact(k)) + fluxm, flux_fullact(k), & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & + errmsg, errflg) + if (errflg /= 0) return factnum(i,k,:) = fn @@ -834,7 +749,7 @@ subroutine dropmixnuc( aero_props, aero_state, & call explmix( & qcld, srcn, ekkp, ekkm, overlapp, & overlapm, qncld, zero, zero, pver, & - dtmix, .false.) + top_lev, dtmix, .false.) ! rce-comment ! the interstitial particle mixratio is different in clear/cloudy portions @@ -858,12 +773,12 @@ subroutine dropmixnuc( aero_props, aero_state, & call explmix( & raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & - dtmix, .false.) + top_lev, dtmix, .false.) call explmix( & raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw(:,mm,nsav)) + top_lev, dtmix, .true., raercol_cw(:,mm,nsav)) do l = 1,aero_props%nmasses(m) mm = aero_props%indexer(m,l) @@ -880,12 +795,12 @@ subroutine dropmixnuc( aero_props, aero_state, & call explmix( & raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & - dtmix, .false.) + top_lev, dtmix, .false.) call explmix( & raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw(:,mm,nsav)) + top_lev, dtmix, .true., raercol_cw(:,mm,nsav)) end do end do @@ -925,7 +840,6 @@ subroutine dropmixnuc( aero_props, aero_state, & do l = 0, aero_props%nmasses(m) mm = aero_props%indexer(m,l) - lptr = aer_cnst_idx(m,l) raertend(top_lev:pver) = (raercol(top_lev:pver,mm,nnew) - raer(mm)%fld(i,top_lev:pver))*dtinv qqcwtend(top_lev:pver) = (raercol_cw(top_lev:pver,mm,nnew) - qqcw(mm)%fld(i,top_lev:pver))*dtinv @@ -934,9 +848,9 @@ subroutine dropmixnuc( aero_props, aero_state, & coltend_cw(i,mm) = sum( pdel(i,:)*qqcwtend )/gravit ! check for advected aerosol constituents - if (lptr>0) then ! advected aerosol parts - ptend%q(i,:,lptr) = 0.0_r8 - ptend%q(i,top_lev:pver,lptr) = raertend(top_lev:pver) ! set tendencies for interstitial aerosol + if (dotend(mm)) then ! advected aerosol parts + raertend_out(i,:,mm) = 0.0_r8 + raertend_out(i,top_lev:pver,mm) = raertend(top_lev:pver) ! set tendencies for interstitial aerosol else raer(mm)%fld(i,:) = 0.0_r8 raer(mm)%fld(i,top_lev:pver) = raercol(top_lev:pver,mm,nnew) ! update non-advected interstitial aerosol (pbuf) @@ -951,24 +865,8 @@ subroutine dropmixnuc( aero_props, aero_state, & end do ! overall_main_i_loop ! end of main loop over i/longitude .................................... - call outfld('NDROPCOL', ndropcol, pcols, lchnk) - call outfld('NDROPSRC', nsource, pcols, lchnk) - call outfld('NDROPMIX', ndropmix, pcols, lchnk) - call outfld('WTKE ', wtke, pcols, lchnk) - - call ccncalc(aero_state, aero_props, state, cs, ccn) - do l = 1, psat - call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) - enddo - - ! do column tendencies - do m = 1, nbin - do l = 0,aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - call outfld(fieldname(mm), coltend(:,mm), pcols, lchnk) - call outfld(fieldname_cw(mm), coltend_cw(:,mm), pcols, lchnk) - end do - end do + call ccncalc(aero_state, aero_props, ncol, pver, top_lev, temp, cs, ccn, errmsg, errflg) + if (errflg /= 0) return deallocate( & nact, & @@ -977,8 +875,6 @@ subroutine dropmixnuc( aero_props, aero_state, & qqcw, & raercol, & raercol_cw, & - coltend, & - coltend_cw, & naermod, & hygro, & vaerosol, & @@ -992,13 +888,14 @@ end subroutine dropmixnuc !=============================================================================== subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & - qold, surfrate, flxconv, pver, dt, is_unact, qactold ) + qold, surfrate, flxconv, pver, top_lev, dt, is_unact, qactold ) ! explicit integration of droplet/aerosol mixing ! with source due to activation/nucleation integer, intent(in) :: pver ! number of levels + integer, intent(in) :: top_lev ! top level for cloud physics real(r8), intent(out) :: q(pver) ! mixing ratio to be updated real(r8), intent(in) :: qold(pver) ! mixing ratio from previous time step real(r8), intent(in) :: src(pver) ! source due to activation/nucleation (/s) @@ -1067,380 +964,7 @@ end subroutine explmix !=============================================================================== -subroutine activate_aerosol(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & - na, nbins, volume, hygro, aero_props, & - fn, fm, fluxn, fluxm, flux_fullact, smax_prescribed, in_cloud_in, smax_f) - - ! calculates number, surface, and mass fraction of aerosols activated as CCN - ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud - ! assumes an internal mixture within each of up to nbin multiple aerosol bins - ! a gaussiam spectrum of updrafts can be treated. - - ! mks units - - ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. - ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - ! input - - real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) - real(r8), intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) - real(r8), intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) - real(r8), intent(in) :: wminf ! minimum updraft velocity for integration (m/s) - real(r8), intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) - real(r8), intent(in) :: tair ! air temperature (K) - real(r8), intent(in) :: rhoair ! air density (kg/m3) - real(r8), intent(in) :: na(:) ! aerosol number concentration (/m3) - integer, intent(in) :: nbins ! number of aerosol bins - real(r8), intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) - real(r8), intent(in) :: hygro(:) ! hygroscopicity of aerosol mode - - class(aerosol_properties), intent(in) :: aero_props - - ! output - - real(r8), intent(out) :: fn(:) ! number fraction of aerosols activated - real(r8), intent(out) :: fm(:) ! mass fraction of aerosols activated - real(r8), intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) - real(r8), intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) - real(r8), intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) - ! rce-comment - ! used for consistency check -- this should match (ekd(k)*zs(k)) - ! also, fluxm/flux_fullact gives fraction of aerosol mass flux - ! that is activated - - ! optional - real(r8), optional, intent(in) :: smax_prescribed ! prescribed max. supersaturation for secondary activation - logical, optional, intent(in) :: in_cloud_in ! switch to modify calculations when above cloud base - real(r8), optional, intent(in) :: smax_f ! droplet and rain size distr factor in the smax calculation - ! used when in_cloud=.true. - - ! local - - integer, parameter:: nx=200 - real(r8) integ,integf - real(r8), parameter :: p0 = 1013.25e2_r8 ! reference pressure (Pa) - real(r8) pres ! pressure (Pa) - real(r8) diff0,conduct0 - real(r8) es ! saturation vapor pressure - real(r8) qs ! water vapor saturation mixing ratio - real(r8) dqsdt ! change in qs with temperature - real(r8) g ! thermodynamic function (m2/s) - real(r8) zeta(nbins), eta(nbins) - real(r8) alpha - real(r8) gamma - real(r8) beta - real(r8) sqrtg - real(r8) :: amcube(nbins) ! cube of dry bin radius (m) - real(r8) smc(nbins) ! critical supersaturation for number bin radius - real(r8) sumflx_fullact - real(r8) sumflxn(nbins) - real(r8) sumflxm(nbins) - real(r8) sumfn(nbins) - real(r8) sumfm(nbins) - real(r8) fnold(nbins) ! number fraction activated - real(r8) fmold(nbins) ! mass fraction activated - real(r8) wold,gold - real(r8) wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb - real(r8) dfmin,dfmax,fnew,fold,fnmin,fnbar,fmbar - real(r8) alw,sqrtalw - real(r8) smax - real(r8) z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf - real(r8) etafactor1,etafactor2(nbins),etafactor2max - real(r8) grow - character(len=*), parameter :: subname='activate_aerosol' - - logical :: in_cloud - integer m,n - ! numerical integration parameters - real(r8), parameter :: eps=0.3_r8,fmax=0.99_r8,sds=3._r8 - - real(r8), parameter :: namin=1.e6_r8 ! minimum aerosol number concentration (/m3) - - integer ndist(nx) ! accumulates frequency distribution of integration bins required - data ndist/nx*0/ - save ndist - - if (present(in_cloud_in)) then - if (.not. present(smax_f)) call endrun(subname//' error: smax_f must be supplied when in_cloud is used') - in_cloud = in_cloud_in - else - in_cloud = .false. - end if - - fn(:)=0._r8 - fm(:)=0._r8 - fluxn(:)=0._r8 - fluxm(:)=0._r8 - flux_fullact=0._r8 - - if(nbins.eq.1.and.na(1).lt.1.e-20_r8)return - - if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return - - if ( present( smax_prescribed ) ) then - if (smax_prescribed <= 0.0_r8) return - end if - - pres=rair*rhoair*tair - diff0=0.211e-4_r8*(p0/pres)*(tair/tmelt)**1.94_r8 - conduct0=(5.69_r8+0.017_r8*(tair-tmelt))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg - call qsat(tair, pres, es, qs) - dqsdt=latvap/(rh2o*tair*tair)*qs - alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) - gamma=(1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) - etafactor2max=1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. - - grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) & - + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) - sqrtg = sqrt(grow) - beta = 2._r8*pi*rhoh2o*grow*gamma - - do m=1,nbins - - if(volume(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then - ! number mode radius (m) - amcube(m)=aero_props%amcube(m, volume(m),na(m)) - ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 - ! should depend on mean radius of mode to account for gas kinetic effects - ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 - ! for approriate size to use for effective diffusivity. - etafactor2(m)=1._r8/(na(m)*beta*sqrtg) - if(hygro(m).gt.1.e-10_r8)then - smc(m)=2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist - else - smc(m)=100._r8 - endif - else - smc(m)=1._r8 - etafactor2(m)=etafactor2max ! this should make eta big if na is very small. - endif - - enddo - - if(sigw.gt.1.e-5_r8)then ! spectrum of updrafts - - wmax=min(wmaxf,wbar+sds*sigw) - wmin=max(wminf,-wdiab) - wmin=max(wmin,wbar-sds*sigw) - w=wmin - dwmax=eps*sigw - dw=dwmax - dfmax=0.2_r8 - dfmin=0.1_r8 - if (wmax <= w) return - do m=1,nbins - sumflxn(m)=0._r8 - sumfn(m)=0._r8 - fnold(m)=0._r8 - sumflxm(m)=0._r8 - sumfm(m)=0._r8 - fmold(m)=0._r8 - enddo - sumflx_fullact=0._r8 - - fold=0._r8 - wold=0._r8 - gold=0._r8 - - dwmin = min( dwmax, 0.01_r8 ) - do n = 1, nx - -100 wnuc=w+wdiab - ! write(iulog,*)'wnuc=',wnuc - alw=alpha*wnuc - sqrtalw=sqrt(alw) - etafactor1=alw*sqrtalw - - do m=1,nbins - eta(m)=etafactor1*etafactor2(m) - zeta(m)=twothird*sqrtalw*aten/sqrtg - enddo - - if ( present( smax_prescribed ) ) then - smax = smax_prescribed - else - smax = aero_props%maxsat(zeta,eta,smc) - endif - - call aero_props%actfracs( nbins, smc(nbins), smax, fnew, fm(nbins) ) - - dwnew = dw - if(fnew-fold.gt.dfmax.and.n.gt.1)then - ! reduce updraft increment for greater accuracy in integration - if (dw .gt. 1.01_r8*dwmin) then - dw=0.7_r8*dw - dw=max(dw,dwmin) - w=wold+dw - go to 100 - else - dwnew = dwmin - endif - endif - - if(fnew-fold.lt.dfmin)then - ! increase updraft increment to accelerate integration - dwnew=min(1.5_r8*dw,dwmax) - endif - fold=fnew - - z=(w-wbar)/(sigw*sq2) - g=exp(-z*z) - fnmin=1._r8 - - do m=1,nbins - ! modal - call aero_props%actfracs( m, smc(m), smax, fn(m), fm(m) ) - fnmin=min(fn(m),fnmin) - ! integration is second order accurate - ! assumes linear variation of f*g with w - fnbar=(fn(m)*g+fnold(m)*gold) - fmbar=(fm(m)*g+fmold(m)*gold) - wb=(w+wold) - if(w.gt.0._r8)then - sumflxn(m)=sumflxn(m)+sixth*(wb*fnbar & - +(fn(m)*g*w+fnold(m)*gold*wold))*dw - sumflxm(m)=sumflxm(m)+sixth*(wb*fmbar & - +(fm(m)*g*w+fmold(m)*gold*wold))*dw - endif - sumfn(m)=sumfn(m)+0.5_r8*fnbar*dw - fnold(m)=fn(m) - sumfm(m)=sumfm(m)+0.5_r8*fmbar*dw - fmold(m)=fm(m) - enddo - ! same form as sumflxm but replace the fm with 1.0 - sumflx_fullact = sumflx_fullact & - + sixth*(wb*(g+gold) + (g*w+gold*wold))*dw - gold=g - wold=w - dw=dwnew - if (n > 1 .and. (w > wmax .or. fnmin > fmax)) exit - w=w+dw - if (n == nx) then - write(iulog,*)'do loop is too short in activate' - write(iulog,*)'wmin=',wmin,' w=',w,' wmax=',wmax,' dw=',dw - write(iulog,*)'wbar=',wbar,' sigw=',sigw,' wdiab=',wdiab - write(iulog,*)'wnuc=',wnuc - write(iulog,*)'na=',(na(m),m=1,nbins) - write(iulog,*)'fn=',(fn(m),m=1,nbins) - ! dump all subr parameters to allow testing with standalone code - ! (build a driver that will read input and call activate) - write(iulog,*)'wbar,sigw,wdiab,tair,rhoair,nbins=' - write(iulog,*) wbar,sigw,wdiab,tair,rhoair,nbins - write(iulog,*)'na=',na - write(iulog,*)'volume=', (volume(m),m=1,nbins) - write(iulog,*)'hygro=' - write(iulog,*) hygro - call endrun(subname) - end if - - enddo - - ndist(n)=ndist(n)+1 - if(w.lt.wmaxf)then - - ! contribution from all updrafts stronger than wmax - ! assuming constant f (close to fmax) - wnuc=w+wdiab - - z1=(w-wbar)/(sigw*sq2) - z2=(wmaxf-wbar)/(sigw*sq2) - g=exp(-z1*z1) - integ=sigw*0.5_r8*sq2*sqpi*(erf(z2)-erf(z1)) - ! consider only upward flow into cloud base when estimating flux - wf1=max(w,zero) - zf1=(wf1-wbar)/(sigw*sq2) - gf1=exp(-zf1*zf1) - wf2=max(wmaxf,zero) - zf2=(wf2-wbar)/(sigw*sq2) - gf2=exp(-zf2*zf2) - gf=(gf1-gf2) - integf=wbar*sigw*0.5_r8*sq2*sqpi*(erf(zf2)-erf(zf1))+sigw*sigw*gf - - do m=1,nbins - sumflxn(m)=sumflxn(m)+integf*fn(m) - sumfn(m)=sumfn(m)+fn(m)*integ - sumflxm(m)=sumflxm(m)+integf*fm(m) - sumfm(m)=sumfm(m)+fm(m)*integ - enddo - ! same form as sumflxm but replace the fm with 1.0 - sumflx_fullact = sumflx_fullact + integf - ! sumg=sumg+integ - endif - - - do m=1,nbins - fn(m)=sumfn(m)/(sq2*sqpi*sigw) - ! fn(m)=sumfn(m)/(sumg) - if(fn(m).gt.1.01_r8)then - write(iulog,*)'fn=',fn(m),' > 1 in activate' - write(iulog,*)'w,m,na,amcube=',w,m,na(m),amcube(m) - write(iulog,*)'integ,sumfn,sigw=',integ,sumfn(m),sigw - call endrun('activate') - endif - fluxn(m)=sumflxn(m)/(sq2*sqpi*sigw) - fm(m)=sumfm(m)/(sq2*sqpi*sigw) - ! fm(m)=sumfm(m)/(sumg) - if(fm(m).gt.1.01_r8)then - write(iulog,*)'fm=',fm(m),' > 1 in activate' - endif - fluxm(m)=sumflxm(m)/(sq2*sqpi*sigw) - enddo - ! same form as fluxm - flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) - - else - - ! single updraft - wnuc=wbar+wdiab - - if(wnuc.gt.0._r8)then - - w=wbar - - if(in_cloud) then - - if (smax_f > 0._r8) then - smax = alpha*w/(2.0_r8*pi*rhoh2o*grow*gamma*smax_f) - else - smax = 1.e-20_r8 - end if - - else ! at cloud base - alw = alpha*wnuc - sqrtalw = sqrt(alw) - etafactor1 = alw*sqrtalw - - do m = 1, nbins - eta(m) = etafactor1*etafactor2(m) - zeta(m) = twothird*sqrtalw*aten/sqrtg - end do - if ( present(smax_prescribed) ) then - smax = smax_prescribed - else - smax = aero_props%maxsat(zeta,eta,smc) - end if - end if - - do m=1,nbins - - call aero_props%actfracs( m, smc(m), smax, fn(m), fm(m) ) - - if(wbar.gt.0._r8)then - fluxn(m)=fn(m)*w - fluxm(m)=fm(m)*w - endif - enddo - flux_fullact = w - endif - - endif - -end subroutine activate_aerosol - -!=============================================================================== - -subroutine ccncalc(aero_state, aero_props, state, cs, ccn) +subroutine ccncalc(aero_state, aero_props, ncol, pver, top_lev, tair, cs, ccn, errmsg, errflg) ! calculates number concentration of aerosols activated as CCN at ! supersaturation supersat. @@ -1453,28 +977,29 @@ subroutine ccncalc(aero_state, aero_props, state, cs, ccn) class(aerosol_state), intent(in) :: aero_state class(aerosol_properties), intent(in) :: aero_props - type(physics_state), target, intent(in) :: state - - real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) - real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: pver ! number of vertical layers + integer, intent(in) :: top_lev ! top level for cloud physics + real(r8), intent(in) :: tair(:,:) ! air temperature (K) + real(r8), intent(in) :: cs(:,:) ! air density (kg/m3) + real(r8), intent(out) :: ccn(:,:,:) ! (ncol,pver,psat) number conc of aerosols activated at supersat (#/m3) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! local - integer :: ncol ! number of columns - real(r8), pointer :: tair(:,:) ! air temperature (K) - - real(r8) naerosol(pcols,pver,nbin) ! interstit+activated aerosol number conc (/m3) - real(r8) vaerosol(pcols,pver,nbin) ! interstit+activated aerosol volume conc (m3/m3) + real(r8) naerosol(ncol,pver,nbin) ! interstit+activated aerosol number conc (/m3) + real(r8) vaerosol(ncol,pver,nbin) ! interstit+activated aerosol volume conc (m3/m3) - real(r8) amcube(pcols) + real(r8) amcube(ncol) real(r8), allocatable :: argfactor(:) real(r8) surften_coef - real(r8) a(pcols) ! surface tension parameter - real(r8) hygro(pcols,pver,nbin) ! aerosol hygroscopicity - real(r8) sm(pcols) ! critical supersaturation at mode radius - real(r8) arg(pcols) + real(r8) a(ncol) ! surface tension parameter + real(r8) hygro(ncol,pver,nbin) ! aerosol hygroscopicity + real(r8) sm(ncol) ! critical supersaturation at mode radius + real(r8) arg(ncol) integer l,m,i,k, astat - real(r8) smcoef(pcols) + real(r8) smcoef(ncol) integer phase ! phase of aerosol integer :: errnum @@ -1486,12 +1011,14 @@ subroutine ccncalc(aero_state, aero_props, state, cs, ccn) !------------------------------------------------------------------------------- - ncol = state%ncol - tair => state%t + errmsg = '' + errflg = 0 allocate( argfactor(nbin), stat=astat ) if (astat/=0) then - call endrun('ndrop::ccncalc : not able to allocate argfactor') + errmsg = 'ndrop::ccncalc : not able to allocate argfactor' + errflg = 1 + return end if surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) @@ -1508,7 +1035,9 @@ subroutine ccncalc(aero_state, aero_props, state, cs, ccn) m, cs, phase, naerosol(:,:,m), vaerosol(:,:,m), & hygro(:,:,m), errnum, errstr) if (errnum/=0) then - call endrun('ccncalc : '//trim(errstr)) + errmsg = 'ccncalc : '//trim(errstr) + errflg = 1 + return end if end do diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index 28a9714c9c..732d362cdc 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -34,9 +34,9 @@ module physpkg use phys_control, only: use_hemco ! Use Harmonized Emissions Component (HEMCO) - use modal_aero_calcsize, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg - use modal_aero_calcsize, only: modal_aero_calcsize_sub - use modal_aero_wateruptake, only: modal_aero_wateruptake_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg + use modal_aero_calcsize_cam, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg + use modal_aero_calcsize_cam, only: modal_aero_calcsize_sub + use modal_aero_wateruptake_cam, only: modal_aero_wateruptake_cam_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg use carma_diags_mod, only: carma_diags_t @@ -978,7 +978,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) call modal_aero_calcsize_init(pbuf2d) endif - call modal_aero_wateruptake_init(pbuf2d) + call modal_aero_wateruptake_cam_init(pbuf2d) end if diff --git a/src/physics/cam7/physpkg.F90 b/src/physics/cam7/physpkg.F90 index d00643c8d0..91e7dd4794 100644 --- a/src/physics/cam7/physpkg.F90 +++ b/src/physics/cam7/physpkg.F90 @@ -31,9 +31,9 @@ module physpkg use cam_logfile, only: iulog use camsrfexch, only: cam_export - use modal_aero_calcsize, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg - use modal_aero_calcsize, only: modal_aero_calcsize_sub - use modal_aero_wateruptake, only: modal_aero_wateruptake_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg + use modal_aero_calcsize_cam, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg + use modal_aero_calcsize_cam, only: modal_aero_calcsize_sub + use modal_aero_wateruptake_cam, only: modal_aero_wateruptake_cam_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg use offline_driver, only: offline_driver_dorun @@ -973,7 +973,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) call modal_aero_calcsize_init(pbuf2d) endif - call modal_aero_wateruptake_init(pbuf2d) + call modal_aero_wateruptake_cam_init(pbuf2d) end if diff --git a/src/physics/carma/cam/carma_intr.F90 b/src/physics/carma/cam/carma_intr.F90 index 8a5e402767..29c8acf7a4 100644 --- a/src/physics/carma/cam/carma_intr.F90 +++ b/src/physics/carma/cam/carma_intr.F90 @@ -2054,7 +2054,7 @@ subroutine carma_wetdep_tend(state, ptend, dt, pbuf, dlf, cam_out) use phys_control, only: cam_physpkg_is use wetdep, only: clddiag, wetdepa_v1, wetdepa_v2 use camsrfexch, only: cam_out_t - use physconst, only: gravit + use physconst, only: gravit, tmelt, rair implicit none @@ -2086,6 +2086,8 @@ subroutine carma_wetdep_tend(state, ptend, dt, pbuf, dlf, cam_out) real(r8) :: totcond(pcols, pver) ! total condensate real(r8) :: solfac(pcols, pver) ! solubility factor real(r8) :: solfac_in ! solubility factor + character(len=512) :: errmsg ! error handling for the portable wetdepa + integer :: errflg real(r8) :: scavcoef ! scavenging Coefficient logical :: do_wetdep integer :: ncol ! number of columns @@ -2100,7 +2102,6 @@ subroutine carma_wetdep_tend(state, ptend, dt, pbuf, dlf, cam_out) ! physics buffer integer itim_old real(r8), pointer, dimension(:,:) :: cldn ! cloud fraction - real(r8), pointer, dimension(:,:) :: cme real(r8), pointer, dimension(:,:) :: prain real(r8), pointer, dimension(:,:) :: evapr real(r8), pointer, dimension(:,:) :: icwmrdp ! in cloud water mixing ratio, deep convection @@ -2129,7 +2130,6 @@ subroutine carma_wetdep_tend(state, ptend, dt, pbuf, dlf, cam_out) itim_old = pbuf_old_tim_idx() call pbuf_get_field(pbuf, pbuf_get_index('CLD'), cldn, (/1,1,itim_old/),(/pcols,pver,1/)) - call pbuf_get_field(pbuf, pbuf_get_index('QME'), cme ) call pbuf_get_field(pbuf, pbuf_get_index('PRAIN'), prain ) call pbuf_get_field(pbuf, pbuf_get_index('NEVAPR'), evapr ) call pbuf_get_field(pbuf, pbuf_get_index('FRACIS'), fracis ) @@ -2155,8 +2155,8 @@ subroutine carma_wetdep_tend(state, ptend, dt, pbuf, dlf, cam_out) cmfdqr(:ncol,:) = rprddp(:ncol,:) + rprdsh(:ncol,:) ! fields needed for wet scavenging - call clddiag( state%t, state%pmid, state%pdel, cmfdqr, evapc, cldn, cldc, clds, cme, evapr, prain, & - cldv, cldvcu, cldvst, rainmr, ncol ) + call clddiag( state%t, state%pmid, state%pdel, cmfdqr, evapc, cldn, cldc, clds, evapr, prain, & + cldv, cldvcu, cldvst, rainmr, ncol, pver, gravit, tmelt, rair ) call cnst_get_ind('CLDICE', ixcldice) call cnst_get_ind('CLDLIQ', ixcldliq) @@ -2198,8 +2198,6 @@ subroutine carma_wetdep_tend(state, ptend, dt, pbuf, dlf, cam_out) if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then call wetdepa_v2( & - state%pmid, & - state%q, & state%pdel, & cldn, & cldc, & @@ -2207,7 +2205,6 @@ subroutine carma_wetdep_tend(state, ptend, dt, pbuf, dlf, cam_out) evapc, & conicw, & prain, & - cme, & evapr, & totcond, & state%q(:, :, icnst), & @@ -2218,22 +2215,19 @@ subroutine carma_wetdep_tend(state, ptend, dt, pbuf, dlf, cam_out) cldvst, & dlf, & fracis(:, :, icnst), & - solfac, & + solfac(:ncol,:), & ncol, & - z_scavcoef) + z_scavcoef, gravit, pver, errmsg, errflg) + if (errflg /= 0) call endrun(trim(errmsg)) else if (cam_physpkg_is('cam4')) then call wetdepa_v1(state%t, & - state%pmid, & - state%q, & state%pdel, & cldn, & - cldc, & cmfdqr, & conicw, & prain, & - cme, & evapr, & totcond, & state%q(:, :, icnst), & @@ -2244,7 +2238,8 @@ subroutine carma_wetdep_tend(state, ptend, dt, pbuf, dlf, cam_out) fracis(:, :, icnst), & solfac_in, & ncol, & - z_scavcoef) + z_scavcoef, tmelt, gravit, pver, errmsg, errflg) + if (errflg /= 0) call endrun(trim(errmsg)) else call endrun('carma_wetdep_tend:: No wet deposition routine is available for this configuration.') From 14e0acd4084fe84284574394db8370024e676f6b Mon Sep 17 00:00:00 2001 From: Haipeng Lin Date: Wed, 22 Jul 2026 21:48:49 -0400 Subject: [PATCH 2/6] Move MAM portable science to the atmos_phys external --- bld/configure | 1 + src/chemistry/aerosol/aero_convproc.F90 | 1698 ----------- src/chemistry/aerosol/aero_drydep_core.F90 | 319 -- src/chemistry/aerosol/cldaero_mod.F90 | 153 - src/chemistry/aerosol/dust_common.F90 | 264 -- src/chemistry/aerosol/dust_sediment_mod.F90 | 468 --- src/chemistry/aerosol/mo_setsox.F90 | 876 ------ src/chemistry/aerosol/sox_cldaero_mod.F90 | 494 --- src/chemistry/aerosol/sslt_sections.F90 | 120 - src/chemistry/aerosol/wetdep.F90 | 1277 -------- src/chemistry/modal_aero/modal_aero_coag.F90 | 2686 ----------------- .../modal_aero/modal_aero_gasaerexch.F90 | 1440 --------- .../modal_aero/modal_aero_newnuc.F90 | 1631 ---------- .../modal_aero/modal_aero_rename.F90 | 1400 --------- .../modal_aero/modal_dust_emissions.F90 | 138 - .../modal_aero/modal_seasalt_emissions.F90 | 98 - src/chemistry/utils/modal_aero_calcsize.F90 | 1134 ------- .../utils/modal_aero_wateruptake.F90 | 1011 ------- src/physics/cam/aero_activate.F90 | 429 --- src/physics/cam/ndrop.F90 | 1075 ------- 20 files changed, 1 insertion(+), 16711 deletions(-) delete mode 100644 src/chemistry/aerosol/aero_convproc.F90 delete mode 100644 src/chemistry/aerosol/aero_drydep_core.F90 delete mode 100644 src/chemistry/aerosol/cldaero_mod.F90 delete mode 100644 src/chemistry/aerosol/dust_common.F90 delete mode 100644 src/chemistry/aerosol/dust_sediment_mod.F90 delete mode 100644 src/chemistry/aerosol/mo_setsox.F90 delete mode 100644 src/chemistry/aerosol/sox_cldaero_mod.F90 delete mode 100644 src/chemistry/aerosol/sslt_sections.F90 delete mode 100644 src/chemistry/aerosol/wetdep.F90 delete mode 100644 src/chemistry/modal_aero/modal_aero_coag.F90 delete mode 100644 src/chemistry/modal_aero/modal_aero_gasaerexch.F90 delete mode 100644 src/chemistry/modal_aero/modal_aero_newnuc.F90 delete mode 100644 src/chemistry/modal_aero/modal_aero_rename.F90 delete mode 100644 src/chemistry/modal_aero/modal_dust_emissions.F90 delete mode 100644 src/chemistry/modal_aero/modal_seasalt_emissions.F90 delete mode 100644 src/chemistry/utils/modal_aero_calcsize.F90 delete mode 100644 src/chemistry/utils/modal_aero_wateruptake.F90 delete mode 100644 src/physics/cam/aero_activate.F90 delete mode 100644 src/physics/cam/ndrop.F90 diff --git a/bld/configure b/bld/configure index d89a353e7f..1cbda13bc5 100755 --- a/bld/configure +++ b/bld/configure @@ -2099,6 +2099,7 @@ sub write_filepath print $fh "$camsrcdir/src/chemistry/bulk_aero\n"; } print $fh "$camsrcdir/src/chemistry/aerosol\n"; + print $fh "$camsrcdir/src/atmos_phys/schemes/modal_aero\n"; if ($waccmx) { print $fh "$camsrcdir/src/physics/waccmx\n"; diff --git a/src/chemistry/aerosol/aero_convproc.F90 b/src/chemistry/aerosol/aero_convproc.F90 deleted file mode 100644 index d7fa640a39..0000000000 --- a/src/chemistry/aerosol/aero_convproc.F90 +++ /dev/null @@ -1,1698 +0,0 @@ -module aero_convproc -!--------------------------------------------------------------------------------- -! Purpose: -! -! Portable aerosol/trace-gas convective cloud processing scheme -! -! currently these routines assume stratiform and convective clouds only interact -! through the detrainment of convective cloudborne material into stratiform clouds -! -! thus the stratiform-cloudborne aerosols (in the qqcw array) are not processed -! by the convective up/downdrafts, but are affected by the detrainment -! -! Author: R. C. Easter -! -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8=>shr_kind_r8 - -use aerosol_properties_mod, only: aerosol_properties - -implicit none -private - -public :: aero_convproc_run - -logical, parameter, public :: use_cwaer_for_activate_maxsat = .false. - -! method1_activate_nlayers = number of layers (including cloud base) where activation is applied -integer, parameter, public :: method1_activate_nlayers = 2 -! method2_activate_smaxmax = the uniform or peak supersat value (as 0-1 fraction = percent*0.01) -real(r8), parameter, public :: method2_activate_smaxmax = 0.003_r8 - -! method_reduce_actfrac = 1 -- multiply activation fractions by factor_reduce_actfrac -! (this works ok with convproc_method_activate = 1 but not for ... = 2) -! = 2 -- do 2 iterations to get an overall reduction by factor_reduce_actfrac -! (this works ok with convproc_method_activate = 1 or 2) -! = other -- do nothing involving reduce_actfrac -integer, parameter, public :: method_reduce_actfrac = 0 -real(r8), parameter, public :: factor_reduce_actfrac = 0.5_r8 - -! convproc_method_activate - 1=apply abdulrazzak-ghan to entrained aerosols for lowest nlayers -! 2=do secondary activation with prescribed supersat -integer, parameter, public :: convproc_method_activate = 2 - -contains - -subroutine aero_convproc_run( aero_props, convtype, lchnk, dt, & - t, pmid, q, du, eu, & - ed, dp, dpdry, jt, & - mx, ideep, il1g, il2g, & - cldfrac, icwmr, rprd, evapc, & - fracice, dqdt, nsrflx, qsrflx, & - xx_mfup_max, xx_wcldbase, xx_kcldbase, & - dcondt_resusp3d, conu2, dcondt2, & - ncol, pver, ncnstaer, nbins, & - pi, rhoh2o, rh2o, gravit, & - latvap, cpair, rair, & - convproc_do_evaprain_atonce, & - convproc_pom_spechygro, & - errmsg, errflg ) - -!----------------------------------------------------------------------- -! -! Purpose: -! Convective transport of trace species. -! The trace species need not be conservative, and source/sink terms for -! activation, resuspension, aqueous chemistry and gas uptake, and -! wet removal are all applied. -! Currently this works with the ZM deep convection, but we should be able -! to adapt it for both Hack and McCaa shallow convection -! -! Compare to subr convproc which does conservative trace species. -! -! Method: -! Computes tracer mixing ratios in updraft and downdraft "cells" in a -! Lagrangian manner, with source/sinks applied in the updraft other. -! Then computes grid-cell-mean tendencies by considering -! updraft and downdraft fluxes across layer boundaries -! environment subsidence/lifting fluxes across layer boundaries -! sources and sinks in the updraft -! resuspension of activated species in the grid-cell as a whole -! -! Note1: A better estimate or calculation of either the updraft velocity -! or fractional area is needed. -! Note2: If updraft area is a small fraction of over cloud area, -! then aqueous chemistry is underestimated. These are both -! research areas. -! -! Authors: O. Seland and R. Easter, based on convtran by P. Rasch -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! -! Input arguments -! - class(aerosol_properties), intent(in) :: aero_props - - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: pver ! number of vertical layers - integer, intent(in) :: ncnstaer ! number of aerosol constituents (extended, = 2*ncnst) - integer, intent(in) :: nbins ! number of aerosol bins/modes - real(r8), intent(in) :: pi ! ratio of circle circumference to diameter - real(r8), intent(in) :: rhoh2o ! density of liquid water (STP) (kg/m3) - real(r8), intent(in) :: rh2o ! gas constant for water vapor (J/K/kg) - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - real(r8), intent(in) :: latvap ! latent heat of vaporization (J/kg) - real(r8), intent(in) :: cpair ! specific heat of dry air (J/K/kg) - real(r8), intent(in) :: rair ! dry air gas constant (J/K/kg) - logical, intent(in) :: convproc_do_evaprain_atonce ! resuspend only when rain fully evaporates in a layer - real(r8), intent(in) :: convproc_pom_spechygro ! prescribed p-organic hygroscopicity (<0 = use default) - - character(len=*), intent(in) :: convtype ! identifies the type of - ! convection ("deep", "shcu") - integer, intent(in) :: lchnk ! chunk identifier - real(r8), intent(in) :: dt ! Model timestep - real(r8), intent(in) :: t(:,:) ! Temperature - real(r8), intent(in) :: pmid(:,:) ! Pressure at model levels - real(r8), intent(in) :: q(:,:,:) ! Tracer array including moisture - - real(r8), intent(in) :: du(:,:) ! Mass detrain rate from updraft - real(r8), intent(in) :: eu(:,:) ! Mass entrain rate into updraft - real(r8), intent(in) :: ed(:,:) ! Mass entrain rate into downdraft -! *** note1 - mu, md, eu, ed, du, dp, dpdry are GATHERED ARRAYS *** -! *** note2 - mu and md units are (mb/s), which is used in the zm_conv code -! - eventually these should be changed to (kg/m2/s) -! *** note3 - eu, ed, du are "d(massflux)/dp" (with dp units = mb), and are all >= 0 - - real(r8), intent(in) :: dp(:,:) ! Delta pressure between interfaces (mb) - real(r8), intent(in) :: dpdry(:,:) ! Delta dry-pressure (mb) - integer, intent(in) :: jt(:) ! Index of cloud top for each column - integer, intent(in) :: mx(:) ! Index of cloud bottom for each column - integer, intent(in) :: ideep(:) ! Gathering array indices - integer, intent(in) :: il1g ! Gathered min lon indices over which to operate - integer, intent(in) :: il2g ! Gathered max lon indices over which to operate -! *** note4 -- for il1g <= i <= il2g, icol = ideep(i) is the "normal" chunk column index - - real(r8), intent(in) :: cldfrac(:,:) ! Convective cloud fractional area - real(r8), intent(in) :: icwmr(:,:) ! Convective cloud water from zhang - real(r8), intent(in) :: rprd(:,:) ! Convective precipitation formation rate - real(r8), intent(in) :: evapc(:,:) ! Convective precipitation evaporation rate - real(r8), intent(in) :: fracice(:,:) ! Ice fraction of cloud droplets - - real(r8), intent(out):: dqdt(:,:,:) ! Tracer tendency array - integer, intent(in) :: nsrflx ! last dimension of qsrflx - real(r8), intent(out):: qsrflx(:,:,:) - ! process-specific column tracer tendencies - ! (1=activation, 2=resuspension, 3=aqueous rxn, - ! 4=wet removal, 5=renaming) - real(r8), intent(out) :: xx_mfup_max(:) - real(r8), intent(out) :: xx_wcldbase(:) - real(r8), intent(out) :: xx_kcldbase(:) - real(r8), intent(inout) :: dcondt_resusp3d(:,:,:) - real(r8), intent(out) :: conu2(:,:,:,:) ! updraft interface TMR diagnostic (WETC/CONU history) - real(r8), intent(out) :: dcondt2(:,:,:,:) ! wet-deposition TMR tendency diagnostic (WETC/CONU history) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -!--------------------------Local Variables------------------------------ - -! cloudborne aerosol, so the arrays are dimensioned with pcnst_extd = pcnst*2 - - integer :: i, icol ! Work index - integer :: iconvtype ! 1=deep, 2=uw shallow - integer :: iflux_method ! 1=as in convtran (deep), 2=simpler - integer :: ipass_calc_updraft - integer :: jtsub ! Work index - integer :: k ! Work index - integer :: kactcnt ! Counter for no. of levels having activation - 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 - 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 - ! updraft starts below the cloud base - integer :: km1, km1x ! Work index - integer :: kp1, kp1x ! Work index - integer :: l, mm ! Work index - integer :: m, n ! Work index - integer :: nerr ! number of errors for entire run - integer :: nerrmax ! maximum number of errors to report - integer :: npass_calc_updraft - integer :: ntsub ! - - logical do_act_this_lev ! flag for doing activation at current level - - real(r8) aqfrac(2,ncnstaer) ! aqueous fraction of constituent in updraft - real(r8) cldfrac_i(pver) ! cldfrac at current i (with adjustments) - - real(r8) chat(2,ncnstaer,pver+1) ! mix ratio in env at interfaces - real(r8) cond(2,ncnstaer,pver+1) ! mix ratio in downdraft at interfaces - real(r8) const(2,ncnstaer,pver) ! gathered tracer array - real(r8) conu(2,ncnstaer,pver+1) ! mix ratio in updraft at interfaces - - real(r8) dcondt(2,ncnstaer,pver) ! grid-average TMR tendency for current column - real(r8) dcondt_prevap(2,ncnstaer,pver) ! portion of dcondt from precip evaporation - real(r8) dcondt_resusp(2,ncnstaer,pver) ! portion of dcondt from resuspension - - real(r8) dcondt_wetdep(2,ncnstaer,pver) ! portion of dcondt from wet deposition - real(r8) dconudt_activa(2,ncnstaer,pver+1) ! d(conu)/dt by activation - real(r8) dconudt_aqchem(2,ncnstaer,pver+1) ! d(conu)/dt by aqueous chem - real(r8) dconudt_wetdep(2,ncnstaer,pver+1) ! d(conu)/dt by wet removal - - real(r8) maxflux(2,ncnstaer) ! maximum (over layers) of fluxin and fluxout - real(r8) maxflux2(2,ncnstaer) ! ditto but computed using method-2 fluxes - real(r8) maxprevap(2,ncnstaer) ! maximum (over layers) of dcondt_prevap*dp - real(r8) maxresusp(2,ncnstaer) ! maximum (over layers) of dcondt_resusp*dp - real(r8) maxsrce(2,ncnstaer) ! maximum (over layers) of netsrce - - real(r8) sumflux(2,ncnstaer) ! sum (over layers) of netflux - real(r8) sumflux2(2,ncnstaer) ! ditto but computed using method-2 fluxes - real(r8) sumsrce(2,ncnstaer) ! sum (over layers) of dp*netsrce - real(r8) sumchng(2,ncnstaer) ! sum (over layers) of dp*dcondt - real(r8) sumchng3(2,ncnstaer) ! ditto but after call to resusp_conv - real(r8) sumprevap(2,ncnstaer) ! sum (over layers) of dp*dcondt_prevap - real(r8) sumwetdep(2,ncnstaer) ! sum (over layers) of dp*dconudt_wetdep - - real(r8) cabv ! mix ratio of constituent above - real(r8) cbel ! mix ratio of constituent below - real(r8) cdifr ! normalized diff between cabv and cbel - real(r8) cdt(pver) ! (in-updraft first order wet removal rate) * dt - real(r8) clw_cut ! threshold clw value for doing updraft - ! transformation and removal - real(r8) courantmax ! maximum courant no. - real(r8) dddp(pver) ! dd(i,k)*dp(i,k) at current i - real(r8) dp_i(pver) ! dp(i,k) at current i - real(r8) dt_u(pver) ! lagrangian transport time in the updraft - real(r8) dudp(pver) ! du(i,k)*dp(i,k) at current i - real(r8) dqdt_i(pver,ncnstaer) ! dqdt(i,k,m) at current i - real(r8) dtsub ! dt/ntsub - real(r8) dz ! working layer thickness (m) - real(r8) eddp(pver) ! ed(i,k)*dp(i,k) at current i - real(r8) eudp(pver) ! eu(i,k)*dp(i,k) at current i - real(r8) expcdtm1 ! a work variable - real(r8) fa_u(pver) ! fractional area of in the updraft - real(r8) fa_u_dp ! current fa_u(k)*dp_i(k) - real(r8) f_ent ! fraction of the "before-detrainment" updraft - ! massflux at k/k-1 interface resulting from - ! entrainment of level k air - real(r8) fluxin ! a work variable - real(r8) fluxout ! a work variable - real(r8) maxc ! a work variable - real(r8) mbsth ! Threshold for mass fluxes - real(r8) minc ! a work variable - real(r8) md_m_eddp ! a work variable - real(r8) md_i(pver+1) ! md(i,k) at current i (note pverp dimension) - real(r8) md_x(pver+1) ! md(i,k) at current i (note pverp dimension) - real(r8) mu_i(pver+1) ! mu(i,k) at current i (note pverp dimension) - real(r8) mu_x(pver+1) ! mu(i,k) at current i (note pverp dimension) - ! md_i, md_x, mu_i, mu_x are all "dry" mass fluxes - ! the mu_x/md_x are initially calculated from the incoming mu/md by applying dp/dpdry - ! the mu_i/md_i are next calculated by applying the mbsth threshold - real(r8) mu_p_eudp(pver) ! = mu_i(kp1) + eudp(k) - real(r8) netflux ! a work variable - real(r8) netsrce ! a work variable - real(r8) q_i(pver,ncnstaer) ! q(i,k,m) at current i - real(r8) qsrflx_i(ncnstaer,nsrflx) ! qsrflx(i,m,n) at current i - real(r8) rhoair_i(pver) ! air density at current i - real(r8) small ! a small number - real(r8) tmpa ! work variables - real(r8) tmpf ! work variables - real(r8) xinv_ntsub ! 1.0/ntsub - real(r8) wup(pver) ! working updraft velocity (m/s) - real(r8) hund_ovr_g ! = 100.0_r8/gravit -! used with zm_conv mass fluxes and delta-p -! for mu = [mbar/s], mu*hund_ovr_g = [kg/m2/s] -! for dp = [mbar] and q = [kg/kg], q*dp*hund_ovr_g = [kg/m2] - - !Fractional area of ensemble mean updrafts in ZM scheme set to 0.01 - !Chosen to reproduce vertical velocities in GATEIII GIGALES (Khairoutdinov etal 2009, JAMES) - real(r8), parameter :: zm_areafrac = 0.01_r8 - -!----------------------------------------------------------------------- -! - errmsg = '' - errflg = 0 - - hund_ovr_g = 100.0_r8/gravit - - iconvtype = -1 - iflux_method = -1 - - if (convtype == 'deep') then - iconvtype = 1 - iflux_method = 1 - else if (convtype == 'uwsh') then - iconvtype = 2 - iflux_method = 2 - else - errmsg = '*** aero_convproc_run -- convtype is not |deep| or |uwsh|' - errflg = 1 - return - end if - - nerr = 0 - nerrmax = 99 - - dcondt_resusp3d(:,:,:) = 0._r8 - - small = 1.e-36_r8 -! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s) - mbsth = 1.e-15_r8 - - qsrflx(:,:,:) = 0.0_r8 - dqdt(:,:,:) = 0.0_r8 - xx_mfup_max(:) = 0.0_r8 - xx_wcldbase(:) = 0.0_r8 - xx_kcldbase(:) = 0.0_r8 - - wup(:) = 0.0_r8 - - dcondt2 = 0.0_r8 - conu2 = 0.0_r8 - aqfrac = 0.0_r8 - -! inititialize aqfrac to 1.0 for activated aerosol species, 0.0 otherwise - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - aqfrac(2,mm) = 1.0_r8 - enddo - enddo - -! Loop ever each column that has convection -! *** i is index to gathered arrays; ideep(i) is index to "normal" chunk arrays -i_loop_main_aa: & - do i = il1g, il2g - icol = ideep(i) - - - if ( (jt(i) <= 0) .and. (mx(i) <= 0) .and. (iconvtype /= 1) ) then -! shallow conv case with jt,mx <= 0, which means there is no shallow conv -! in this column -- skip this column - cycle i_loop_main_aa - - else if ( (jt(i) < 1) .or. (mx(i) > pver) .or. (jt(i) > mx(i)) ) then -! invalid cloudtop and cloudbase indices -- skip this column - write(*,9010) 'illegal jt, mx', convtype, lchnk, icol, i, & - jt(i), mx(i) -9010 format( '*** aero_convproc_run error -- ', a, 5x, 'convtype = ', a / & - '*** lchnk, icol, il, jt, mx = ', 5(1x,i10) ) - cycle i_loop_main_aa - - else if (jt(i) == mx(i)) then -! cloudtop = cloudbase (1 layer cloud) -- skip this column - write(*,9010) 'jt == mx', convtype, lchnk, icol, i, jt(i), mx(i) - cycle i_loop_main_aa - - end if - - -! -! cloudtop and cloudbase indices are valid so proceed with calculations -! - -! Load dp_i and cldfrac_i, and calc rhoair_i - do k = 1, pver - dp_i(k) = dpdry(i,k) - cldfrac_i(k) = cldfrac(icol,k) - rhoair_i(k) = pmid(icol,k)/(rair*t(icol,k)) - end do - -! Calc dry mass fluxes -! This is approximate because the updraft air is has different temp and qv than -! the grid mean, but the whole convective parameterization is highly approximate - mu_x(:) = 0.0_r8 - md_x(:) = 0.0_r8 -! (eu-du) = d(mu)/dp -- integrate upwards, multiplying by dpdry - do k = pver, 1, -1 - mu_x(k) = mu_x(k+1) + (eu(i,k)-du(i,k))*dp_i(k) - xx_mfup_max(icol) = max( xx_mfup_max(icol), mu_x(k) ) - end do -! (ed) = d(md)/dp -- integrate downwards, multiplying by dpdry - do k = 2, pver - md_x(k) = md_x(k-1) - ed(i,k-1)*dp_i(k-1) - end do - -! Load mass fluxes over cloud layers -! (Note - use of arrays dimensioned k=1,pver+1 simplifies later coding) -! Zero out values below threshold -! Zero out values at "top of cloudtop", "base of cloudbase" - ktop = jt(i) - kbot = mx(i) -! 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 - kbot_prevap = pver - mu_i(:) = 0.0_r8 - md_i(:) = 0.0_r8 - do k = ktop+1, kbot - mu_i(k) = mu_x(k) - if (mu_i(k) <= mbsth) mu_i(k) = 0.0_r8 - md_i(k) = md_x(k) - if (md_i(k) >= -mbsth) md_i(k) = 0.0_r8 - end do - mu_i(ktop) = 0.0_r8 - md_i(ktop) = 0.0_r8 - mu_i(kbot+1) = 0.0_r8 - md_i(kbot+1) = 0.0_r8 - -! Compute updraft and downdraft "entrainment*dp" from eu and ed -! Compute "detrainment*dp" from mass conservation - eudp(:) = 0.0_r8 - dudp(:) = 0.0_r8 - eddp(:) = 0.0_r8 - dddp(:) = 0.0_r8 - courantmax = 0.0_r8 - do k = ktop, kbot - if ((mu_i(k) > 0) .or. (mu_i(k+1) > 0)) then - if (du(i,k) <= 0.0_r8) then - eudp(k) = mu_i(k) - mu_i(k+1) - else - eudp(k) = max( eu(i,k)*dp_i(k), 0.0_r8 ) - dudp(k) = (mu_i(k+1) + eudp(k)) - mu_i(k) - if (dudp(k) < 1.0e-12_r8*eudp(k)) then - eudp(k) = mu_i(k) - mu_i(k+1) - dudp(k) = 0.0_r8 - end if - end if - end if - if ((md_i(k) < 0) .or. (md_i(k+1) < 0)) then - eddp(k) = max( ed(i,k)*dp_i(k), 0.0_r8 ) - dddp(k) = (md_i(k+1) + eddp(k)) - md_i(k) - if (dddp(k) < 1.0e-12_r8*eddp(k)) then - eddp(k) = md_i(k) - md_i(k+1) - dddp(k) = 0.0_r8 - end if - end if - courantmax = max( courantmax, ( mu_i(k+1)+eudp(k)-md_i(k)+eddp(k) )*dt/dp_i(k) ) - end do ! k - -! number of time substeps needed to maintain "courant number" <= 1 - ntsub = 1 - if (courantmax > (1.0_r8 + 1.0e-6_r8)) then - ntsub = 1 + int( courantmax ) - end if - xinv_ntsub = 1.0_r8/ntsub - dtsub = dt*xinv_ntsub - courantmax = courantmax*xinv_ntsub - -! load tracer mixing ratio array, which will be updated at the end of each jtsub interation - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - q_i(1:pver,mm) = q(icol,1:pver,mm) - conu2(icol,1:pver,1,mm) = q(icol,1:pver,mm) - end do - end do - -! -! when method_reduce_actfrac = 2, need to do the updraft calc twice -! (1st to get non-adjusted activation amount, 2nd to apply reduction factor) - npass_calc_updraft = 1 - if ( (method_reduce_actfrac == 2) .and. & - (factor_reduce_actfrac >= 0.0_r8) .and. & - (factor_reduce_actfrac <= 1.0_r8) ) npass_calc_updraft = 2 - - -jtsub_loop_main_aa: & - do jtsub = 1, ntsub - - -ipass_calc_updraft_loop: & - do ipass_calc_updraft = 1, npass_calc_updraft - - qsrflx_i(:,:) = 0.0_r8 - dqdt_i(:,:) = 0.0_r8 - - const = 0.0_r8 ! zero cloud-phase species - chat = 0.0_r8 ! zero cloud-phase species - conu = 0.0_r8 - cond = 0.0_r8 - - dcondt = 0.0_r8 - dcondt_resusp = 0.0_r8 - dcondt_wetdep = 0.0_r8 - dcondt_prevap = 0.0_r8 - dconudt_aqchem = 0.0_r8 - dconudt_wetdep = 0.0_r8 - -! only initialize the activation tendency on ipass=1 - if (ipass_calc_updraft == 1) dconudt_activa = 0.0_r8 - - ! initialize mixing ratio arrays (chat, const, conu, cond) - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - - const(1,mm,:) = q_i(:,mm) - - ! From now on work only with gathered data - ! Interpolate environment tracer values to interfaces - do k = 1,pver - km1 = max(1,k-1) - minc = min(const(1,mm,km1),const(1,mm,k)) - maxc = max(const(1,mm,km1),const(1,mm,k)) - if (minc < 0) then - cdifr = 0._r8 - else - cdifr = abs(const(1,mm,k)-const(1,mm,km1))/max(maxc,small) - endif - - ! If the two layers differ significantly use a geometric averaging procedure - ! But only do that for deep convection. For shallow, use the simple - ! averaging which is used in subr cmfmca - if (iconvtype /= 1) then - chat(1,mm,k) = 0.5_r8* (const(1,mm,k)+const(1,mm,km1)) - else if (cdifr > 1.E-6_r8) then - cabv = max(const(1,mm,km1),maxc*1.e-12_r8) - cbel = max(const(1,mm,k),maxc*1.e-12_r8) - chat(1,mm,k) = log(cabv/cbel)/(cabv-cbel)*cabv*cbel - else ! Small diff, so just arithmetic mean - chat(1,mm,k) = 0.5_r8* (const(1,mm,k)+const(1,mm,km1)) - end if - - ! Set provisional up and down draft values, and tendencies - conu(1,mm,k) = chat(1,mm,k) - cond(1,mm,k) = chat(1,mm,k) - end do ! k - - ! Values at surface inferface == values in lowest layer - chat(1,mm,pver+1) = const(1,mm,pver) - conu(1,mm,pver+1) = const(1,mm,pver) - cond(1,mm,pver+1) = const(1,mm,pver) - end do ! l - end do ! m - - - -! Compute updraft mixing ratios from cloudbase to cloudtop -! No special treatment is needed at k=pver because arrays -! are dimensioned 1:pver+1 -! A time-split approach is used. First, entrainment is applied to produce -! an initial conu(m,k) from conu(m,k+1). Next, chemistry/physics are -! applied to the initial conu(m,k) to produce a final conu(m,k). -! Detrainment from the updraft uses this final conu(m,k). -! Note that different time-split approaches would give somewhat different -! results - kactcnt = 0 ; kactcntb = 0 ; kactfirst = 1 -k_loop_main_bb: & - do k = kbot, ktop, -1 - kp1 = k+1 - -! cldfrac = conv cloud fractional area. This could represent anvil cirrus area, -! and may not useful for aqueous chem and wet removal calculations - cldfrac_i(k) = max( cldfrac_i(k), 0.005_r8 ) -! mu_p_eudp(k) = updraft massflux at k, without detrainment between kp1,k - mu_p_eudp(k) = mu_i(kp1) + eudp(k) - - fa_u(k) = 0.0_r8 !BSINGH(10/15/2014): Initialized so that it has a value if the following "if" check yeilds .false. - if (mu_p_eudp(k) > mbsth) then -! if (mu_p_eudp(k) <= mbsth) the updraft mass flux is negligible at base and top -! of current layer, -! so current layer is a "gap" between two unconnected updrafts, -! so essentially skip all the updraft calculations for this layer - -! First apply changes from entrainment - f_ent = eudp(k)/mu_p_eudp(k) - f_ent = max( 0.0_r8, min( 1.0_r8, f_ent ) ) - tmpa = 1.0_r8 - f_ent - do n = 1,2 ! phase - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - conu(n,mm,k) = tmpa*conu(n,mm,kp1) + f_ent*const(n,mm,k) - end do - end do - end do - -! estimate updraft velocity (wup) - if (iconvtype /= 1) then -! shallow - wup = (mup in kg/m2/s) / [rhoair * (updraft area)] - wup(k) = (mu_i(kp1) + mu_i(k))*0.5_r8*hund_ovr_g & - / (rhoair_i(k) * (cldfrac_i(k)*0.5_r8)) - else -! deep - as in shallow, but assumed constant updraft_area with height zm_areafrac - wup(k) = (mu_i(kp1) + mu_i(k))*0.5_r8*hund_ovr_g & - / (rhoair_i(k) * zm_areafrac) - end if - -! compute lagrangian transport time (dt_u) and updraft fractional area (fa_u) -! *** these must obey dt_u(k)*mu_p_eudp(k) = dp_i(k)*fa_u(k) - dz = dp_i(k)*hund_ovr_g/rhoair_i(k) - dt_u(k) = dz/wup(k) - dt_u(k) = min( dt_u(k), dt ) - fa_u(k) = dt_u(k)*(mu_p_eudp(k)/dp_i(k)) - - -! Now apply transformation and removal changes -! Skip levels where icwmr(icol,k) <= clw_cut (= 1.0e-6) to eliminate -! occasional very small icwmr values from the ZM module - clw_cut = 1.0e-6_r8 - - - if (convproc_method_activate <= 1) then -! aerosol activation - method 1 -! skip levels that are completely glaciated (fracice(icol,k) == 1.0) -! when kactcnt=1 (first/lowest layer with cloud water) apply -! activatation to the entire updraft -! when kactcnt>1 apply activatation to the amount entrained at this level - if ((icwmr(icol,k) > clw_cut) .and. (fracice(icol,k) < 1.0_r8)) then - kactcnt = kactcnt + 1 - - if ((kactcnt == 1) .or. (f_ent > 0.0_r8)) then - kactcntb = kactcntb + 1 - end if - - if (kactcnt == 1) then - ! diagnostic fields - ! xx_wcldbase = w at first cloudy layer, estimated from mu and cldfrac - xx_wcldbase(icol) = (mu_i(kp1) + mu_i(k))*0.5_r8*hund_ovr_g & - / (rhoair_i(k) * (cldfrac_i(k)*0.5_r8)) - xx_kcldbase(icol) = k - - kactfirst = k - tmpa = 1.0_r8 - call activate_convproc( aero_props, & - conu(:,:,k), dconudt_activa(:,:,k), conu(:,:,k), & - tmpa, dt_u(k), wup(k), & - t(icol,k), rhoair_i(k), ipass_calc_updraft, & - ncnstaer, nbins, & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & - errmsg, errflg ) - if (errflg /= 0) return - else if (f_ent > 0.0_r8) then - ! current layer is above cloud base (=first layer with activation) - ! only allow activation at k = kactfirst thru kactfirst-(method1_activate_nlayers-1) - if (k >= kactfirst-(method1_activate_nlayers-1)) then - call activate_convproc( aero_props, & - conu(:,:,k), dconudt_activa(:,:,k), const(:,:,k), & - f_ent, dt_u(k), wup(k), & - t(icol,k), rhoair_i(k), ipass_calc_updraft, & - ncnstaer, nbins, & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & - errmsg, errflg ) - if (errflg /= 0) return - end if - end if -! the following was for cam2 shallow convection (hack), -! but is not appropriate for cam5 (uwshcu) -! else if ((kactcnt > 0) .and. (iconvtype /= 1)) then -! ! for shallow conv, when you move from activation occuring to -! ! not occuring, reset kactcnt=0, because the hack scheme can -! ! produce multiple "1.5 layer clouds" separated by clear air -! kactcnt = 0 -! end if - end if ! ((icwmr(icol,k) > clw_cut) .and. (fracice(icol,k) < 1.0)) then - - else ! (convproc_method_activate >= 2) -! aerosol activation - method 2 -! skip levels that are completely glaciated (fracice(icol,k) == 1.0) -! when kactcnt=1 (first/lowest layer with cloud water) -! apply "primary" activatation to the entire updraft -! when kactcnt>1 -! apply secondary activatation to the entire updraft -! do this for all levels above cloud base (even if completely glaciated) -! (this is something for sensitivity testing) - do_act_this_lev = .false. - if (kactcnt <= 0) then - if (icwmr(icol,k) > clw_cut) then - do_act_this_lev = .true. - kactcnt = 1 - kactfirst = k - ! diagnostic fields - ! xx_wcldbase = w at first cloudy layer, estimated from mu and cldfrac - xx_wcldbase(icol) = (mu_i(kp1) + mu_i(k))*0.5_r8*hund_ovr_g & - / (rhoair_i(k) * (cldfrac_i(k)*0.5_r8)) - xx_kcldbase(icol) = k - end if - else -! if ((icwmr(icol,k) > clw_cut) .and. (fracice(icol,k) < 1.0)) then - do_act_this_lev = .true. - kactcnt = kactcnt + 1 -! end if - end if - - if ( do_act_this_lev ) then - kactcntb = kactcntb + 1 - - call activate_convproc_method2( aero_props, & - conu(:,:,k), dconudt_activa(:,:,k), & - f_ent, dt_u(k), wup(k), & - t(icol,k), rhoair_i(k), k, & - kactfirst, ipass_calc_updraft, & - ncnstaer, nbins, convproc_pom_spechygro, & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & - errmsg, errflg ) - if (errflg /= 0) return - - end if - conu2(icol,k,:,:) = conu(:,:,k) - - end if ! (convproc_method_activate <= 1) - -! aqueous chemistry -! do glaciated levels as aqchem_conv will eventually do acid vapor uptake -! to ice, and aqchem_conv module checks fracice before doing liquid wtr stuff -! if (icwmr(icol,k) > clw_cut) then -! call aqchem_conv( conu(1,k), dconudt_aqchem(1,k), aqfrac, & -! t(icol,k), fracice(icol,k), icwmr(icol,k), rhoair_i(k), & -! lh2o2(icol,k), lo3(icol,k), dt_u(k) ) -! end if - -! wet removal -! -! mirage2 -! rprd = precip formation as a grid-cell average (kgW/kgA/s) -! icwmr = cloud water MR within updraft area (kgW/kgA) -! fupdr = updraft fractional area (--) -! A = rprd/fupdr = precip formation rate within updraft area (kgW/kgA/s) -! B = A/icwmr = rprd/(icwmr*fupdr) -! = first-order removal rate (1/s) -! C = dp/(mup/fupdr) = updraft air residence time in the layer (s) -! -! fraction removed = (1.0 - exp(-cdt)) where -! cdt = B*C = (dp/mup)*rprd/icwmr -! -! Note1: fupdr cancels out in cdt, so need not be specified -! Note2: dp & mup units need only be consistent (e.g., mb & mb/s) -! Note3: for shallow conv, cdt = 1-beta (beta defined in Hack scheme) -! Note4: the "dp" in C above and code below should be the moist dp -! -! cam5 -! clw_preloss = cloud water MR before loss to precip -! = icwmr + dt*(rprd/fupdr) -! B = A/clw_preloss = (rprd/fupdr)/(icwmr + dt*rprd/fupdr) -! = rprd/(fupdr*icwmr + dt*rprd) -! = first-order removal rate (1/s) -! -! fraction removed = (1.0 - exp(-cdt)) where -! cdt = B*C = (fupdr*dp/mup)*[rprd/(fupdr*icwmr + dt*rprd)] -! -! Note1: *** cdt is now sensitive to fupdr, which we do not really know, -! and is not the same as the convective cloud fraction -! Note2: dt is appropriate in the above cdt expression, not dtsub -! -! Apply wet removal at levels where -! icwmr(icol,k) > clw_cut AND rprd(icol,k) > 0.0 -! as wet removal occurs in both liquid and ice clouds -! - cdt(k) = 0.0_r8 - if ((icwmr(icol,k) > clw_cut) .and. (rprd(icol,k) > 0.0_r8)) then -! if (iconvtype == 1) then - tmpf = 0.5_r8*cldfrac_i(k) - cdt(k) = (tmpf*dp(i,k)/mu_p_eudp(k)) * rprd(icol,k) / & - (tmpf*icwmr(icol,k) + dt*rprd(icol,k)) -! else if (k < pver) then -! if (eudp(k+1) > 0) cdt(k) = & -! rprd(icol,k)*dp(i,k)/(icwmr(icol,k)*eudp(k+1)) -! end if - end if - if (cdt(k) > 0.0_r8) then - expcdtm1 = exp(-cdt(k)) - 1.0_r8 - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - do n = 1,2 - dconudt_wetdep(n,mm,k) = conu(n,mm,k)*aqfrac(n,mm)*expcdtm1 - conu(n,mm,k) = conu(n,mm,k) + dconudt_wetdep(n,mm,k) - dconudt_wetdep(n,mm,k) = dconudt_wetdep(n,mm,k) / dt_u(k) - conu2(icol,k,n,mm) = conu(n,mm,k) - enddo - enddo - enddo - - end if - - end if ! "(mu_p_eudp(k) > mbsth)" - end do k_loop_main_bb ! "k = kbot, ktop, -1" - -! when doing updraft calcs twice, only need to go this far on the first pass - if ( (ipass_calc_updraft == 1) .and. & - (npass_calc_updraft == 2) ) cycle ipass_calc_updraft_loop - - -! Compute downdraft mixing ratios from cloudtop to cloudbase -! No special treatment is needed at k=2 -! No transformation or removal is applied in the downdraft - do k = ktop, kbot - kp1 = k + 1 -! md_m_eddp = downdraft massflux at kp1, without detrainment between k,kp1 - md_m_eddp = md_i(k) - eddp(k) - if (md_m_eddp < -mbsth) then - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - do n = 1,2 - cond(n,mm,kp1) = ( md_i(k)*cond(n,mm,k) & - - eddp(k)*const(n,mm,k) ) / md_m_eddp - end do - end do - end do - end if - end do ! k - - -! Now computes fluxes and tendencies -! NOTE: The approach used in convtran applies to inert tracers and -! must be modified to include source and sink terms - sumflux = 0.0_r8 - sumflux2 = 0.0_r8 - sumsrce = 0.0_r8 - sumchng = 0.0_r8 - sumchng3 = 0.0_r8 - sumwetdep = 0.0_r8 - sumprevap = 0.0_r8 - - maxflux = 0.0_r8 - maxflux2 = 0.0_r8 - maxresusp = 0.0_r8 - maxsrce = 0.0_r8 - maxprevap = 0.0_r8 - -k_loop_main_cc: & - do k = ktop, kbot - kp1 = k+1 - km1 = k-1 - kp1x = min( kp1, pver ) - km1x = max( km1, 1 ) - fa_u_dp = fa_u(k)*dp_i(k) - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - do n = 1,2 - - ! First compute fluxes using environment subsidence/lifting and - ! entrainment/detrainment into up/downdrafts, - ! to provide an additional mass balance check - ! (this could be deleted after the code is well tested) - fluxin = mu_i(k)*min(chat(n,mm,k),const(n,mm,km1x)) & - - md_i(kp1)*min(chat(n,mm,kp1),const(n,mm,kp1x)) & - + dudp(k)*conu(n,mm,k) + dddp(k)*cond(n,mm,kp1) - fluxout = mu_i(kp1)*min(chat(n,mm,kp1),const(n,mm,k)) & - - md_i(k)*min(chat(n,mm,k),const(n,mm,k)) & - + (eudp(k) + eddp(k))*const(n,mm,k) - - netflux = fluxin - fluxout - - sumflux2(n,mm) = sumflux2(n,mm) + netflux - maxflux2(n,mm) = max( maxflux2(n,mm), abs(fluxin), abs(fluxout) ) - - ! Now compute fluxes as in convtran, and also source/sink terms - ! (version 3 limit fluxes outside convection to mass in appropriate layer - ! (these limiters are probably only safe for positive definite quantitities - ! (it assumes that mu and md already satify a courant number limit of 1) - if (iflux_method /= 2) then - fluxin = mu_i(kp1)*conu(n,mm,kp1) & - + mu_i(k )*min(chat(n,mm,k ),const(n,mm,km1x)) & - - ( md_i(k )*cond(n,mm,k) & - + md_i(kp1)*min(chat(n,mm,kp1),const(n,mm,kp1x)) ) - fluxout = mu_i(k )*conu(n,mm,k) & - + mu_i(kp1)*min(chat(n,mm,kp1),const(n,mm,k )) & - - ( md_i(kp1)*cond(n,mm,kp1) & - + md_i(k )*min(chat(n,mm,k ),const(n,mm,k )) ) - else - fluxin = mu_i(kp1)*conu(n,mm,kp1) & - - ( md_i(k )*cond(n,mm,k) ) - fluxout = mu_i(k )*conu(n,mm,k) & - - ( md_i(kp1)*cond(n,mm,kp1) ) - - ! new method -- simple upstream method for the env subsidence - ! tmpa = net env mass flux (positive up) at top of layer k - tmpa = -( mu_i(k ) + md_i(k ) ) - if (tmpa <= 0.0_r8) then - fluxin = fluxin - tmpa*const(n,mm,km1x) - else - fluxout = fluxout + tmpa*const(n,mm,k ) - end if - ! tmpa = net env mass flux (positive up) at base of layer k - tmpa = -( mu_i(kp1) + md_i(kp1) ) - if (tmpa >= 0.0_r8) then - fluxin = fluxin + tmpa*const(n,mm,kp1x) - else - fluxout = fluxout - tmpa*const(n,mm,k ) - end if - end if - - netflux = fluxin - fluxout - netsrce = fa_u_dp*(dconudt_aqchem(n,mm,k) + & - dconudt_activa(n,mm,k) + dconudt_wetdep(n,mm,k)) - dcondt(n,mm,k) = (netflux+netsrce)/dp_i(k) - - dcondt_wetdep(n,mm,k) = fa_u_dp*dconudt_wetdep(n,mm,k)/dp_i(k) - sumwetdep(n,mm) = sumwetdep(n,mm) + fa_u_dp*dconudt_wetdep(n,mm,k) - - dcondt2(icol,k,n,mm) = dcondt(n,mm,k) - - end do - end do - - end do - end do k_loop_main_cc ! "k = ktop, kbot" - -! calculate effects of precipitation evaporation - call precpevap_convproc( aero_props, dcondt, dcondt_wetdep, dcondt_prevap, & - rprd, evapc, dp_i, & - icol, ktop, pver, ncnstaer, & - convproc_do_evaprain_atonce ) - -! make adjustments to dcondt for activated & unactivated aerosol species -! pairs to account any (or total) resuspension of convective-cloudborne aerosol - call resuspend_convproc( aero_props, dcondt, dcondt_resusp, ktop, kbot_prevap, & - pver, ncnstaer, convproc_do_evaprain_atonce ) - - ! Do resuspension of aerosols from rain only when the rain has - ! totally evaporated. - if (convproc_do_evaprain_atonce) then - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - dcondt_resusp3d(mm,icol,:) = dcondt_resusp(2,mm,:) - end do - end do - - dcondt_resusp(2,:,:) = 0._r8 - end if - -! calculate new column-tendency variables - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - do n = 1,2 - do k = ktop, kbot_prevap - sumprevap(n,mm) = sumprevap(n,mm) + dcondt_prevap(n,mm,k)*dp_i(k) - end do - end do - end do - end do - -! -! note again the aero_convproc_run does not apply convective cloud processing -! to the stratiform-cloudborne aerosol -! within this routine, cloudborne aerosols are convective-cloudborne -! -! before tendencies (dcondt, which is loaded into dqdt) are returned, -! the convective-cloudborne aerosol tendencies must be combined -! with the interstitial tendencies -! resuspend_convproc has already done this for the dcondt -! -! the individual process column tendencies (sumwetdep, sumprevap, ...) -! are just diagnostic fields that can be written to history -! tendencies for interstitial and convective-cloudborne aerosol could -! both be passed back and output, if desired -! currently, however, the interstitial and convective-cloudborne tendencies -! are combined (in the next code block) before being passed back (in qsrflx) -! - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - sumwetdep(1,mm) = sumwetdep(1,mm) + sumwetdep(2,mm) - sumprevap(1,mm) = sumprevap(1,mm) + sumprevap(2,mm) - enddo - enddo - -! -! scatter overall tendency back to full array -! - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - do k = ktop, kbot_prevap - dqdt_i(k,mm) = dcondt(1,mm,k) - dqdt(icol,k,mm) = dqdt(icol,k,mm) + dqdt_i(k,mm)*xinv_ntsub - end do - - end do - end do ! m - -! scatter column burden tendencies for various processes to qsrflx - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - qsrflx_i(mm,4) = sumwetdep(1,mm)*hund_ovr_g - qsrflx_i(mm,5) = sumprevap(1,mm)*hund_ovr_g - qsrflx(icol,mm,1:5) = qsrflx(icol,mm,1:5) + qsrflx_i(mm,1:5)*xinv_ntsub - end do - end do - - if (jtsub < ntsub) then - ! update the q_i for the next interation of the jtsub loop - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - do k = ktop, kbot_prevap - q_i(k,mm) = max( (q_i(k,mm) + dqdt_i(k,mm)*dtsub), 0.0_r8 ) - end do - end do - end do - end if - - end do ipass_calc_updraft_loop - - end do jtsub_loop_main_aa ! of the main "do jtsub = 1, ntsub" loop - - - end do i_loop_main_aa ! of the main "do i = il1g, il2g" loop - -! conu2/dcondt2 are returned as out-args; the WETC/CONU history diagnostics -! are written by the CAM host layer (aero_convproc_cam) - -end subroutine aero_convproc_run - -!========================================================================================= - subroutine precpevap_convproc( aero_props, & - dcondt, dcondt_wetdep, dcondt_prevap, & - rprd, evapc, dp_i, & - icol, ktop, pver, ncnstaer, & - convproc_do_evaprain_atonce ) -!----------------------------------------------------------------------- -! -! Purpose: -! Calculate resuspension of wet-removed aerosol species resulting -! from precip evaporation -! -! Author: R. Easter -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! arguments -! (note: TMR = tracer mixing ratio) - - class(aerosol_properties), intent(in) :: aero_props - integer, intent(in) :: pver ! number of vertical layers - integer, intent(in) :: ncnstaer ! number of aerosol constituents (extended) - logical, intent(in) :: convproc_do_evaprain_atonce - real(r8), intent(inout) :: dcondt(2,ncnstaer,pver) - ! overall TMR tendency from convection - real(r8), intent(in) :: dcondt_wetdep(2,ncnstaer,pver) - ! portion of TMR tendency due to wet removal - real(r8), intent(inout) :: dcondt_prevap(2,ncnstaer,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(in) :: rprd(:,:) ! conv precip production rate (gathered) - real(r8), intent(in) :: evapc(:,:) ! 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 - -!----------------------------------------------------------------------- -! local variables - integer :: k, l, m, mm, n - 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) :: tmpdp ! delta-pressure (mb) - real(r8) :: wd_flux(2,ncnstaer) ! tracer wet deposition flux at base of current layer [(kg/kg/s)*mb] -!----------------------------------------------------------------------- - - pr_flux = 0.0_r8 - wd_flux = 0.0_r8 - - do k = ktop, pver - tmpdp = dp_i(k) - - 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)) ) - - ! Do resuspension of aerosols from rain only when the rain has - ! totally evaporated in one layer. - if (convproc_do_evaprain_atonce .and. & - (del_pr_flux_evap.ne.pr_flux)) del_pr_flux_evap = 0._r8 - - fdel_pr_flux_evap = del_pr_flux_evap / max(pr_flux, 1.0e-35_r8) - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - do n = 1,2 - - ! use -dcondt_wetdep(m,k) as it is negative (or zero) - wd_flux(n,mm) = wd_flux(n,mm) + tmpdp*max(0.0_r8, -dcondt_wetdep(n,mm,k)) - del_wd_flux_evap = wd_flux(n,mm)*fdel_pr_flux_evap - - dcondt_prevap(n,mm,k) = del_wd_flux_evap/tmpdp - - end do - end do - end do - - ! resuspension --> create larger aerosols - if (convproc_do_evaprain_atonce) then - call aero_props%resuspension_resize( dcondt_prevap(1,:,k) ) - endif - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - do n = 1,2 - dcondt(n,mm,k) = dcondt(n,mm,k) + dcondt_prevap(n,mm,k) - end do - end do - end do - - pr_flux = max( 0.0_r8, pr_flux-del_pr_flux_evap ) - - end do ! k - - end subroutine precpevap_convproc - -!========================================================================================= - subroutine activate_convproc( aero_props, & - conu, dconudt, conent, & - f_ent, dt_u, wup, & - tair, rhoair, ipass_calc_updraft, & - ncnstaer, nbins, & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & - errmsg, errflg ) -!----------------------------------------------------------------------- -! -! Purpose: -! Calculate activation of aerosol species in convective updraft -! for a single column and level -! -! Method: -! conu(l) = Updraft TMR (tracer mixing ratio) at k/k-1 interface -! conent(l) = TMR of air that is entrained into the updraft from level k -! f_ent = Fraction of the "before-detrainment" updraft massflux at -! k/k-1 interface" resulting from entrainment of level k air -! (where k is the current level in subr aero_convproc_run) -! -! On entry to this routine, the conu(l) represents the updraft TMR -! after entrainment, but before chemistry/physics and detrainment, -! and is equal to -! conu(l) = f_ent*conent(l) + (1.0-f_ent)*conu_below(l) -! where -! conu_below(l) = updraft TMR at the k+1/k interface, and -! f_ent = (eudp/mu_p_eudp) is the fraction of the updraft massflux -! from level k entrainment -! -! This routine applies aerosol activation to the entrained tracer, -! then adjusts the conu so that on exit, -! conu(la) = conu_incoming(la) - f_ent*conent(la)*f_act(la) -! conu(lc) = conu_incoming(lc) + f_ent*conent(la)*f_act(la) -! where -! la, lc = indices for an unactivated/activated aerosol component pair -! f_act = fraction of conent(la) that is activated. The f_act are -! calculated with the Razzak-Ghan activation parameterization. -! The f_act differ for each mode, and for number/surface/mass. -! -! Note: At the lowest layer with cloud water, subr convproc calls this -! routine with conent==conu and f_ent==1.0, with the result that -! activation is applied to the entire updraft tracer flux -! -! *** The updraft velocity used for activation calculations is rather -! uncertain and needs more work. However, an updraft of 1-3 m/s -! will activate essentially all of accumulation and coarse mode particles. -! -! Author: R. Easter -! -!----------------------------------------------------------------------- - - use aero_activate, only: activate_aerosol - -!----------------------------------------------------------------------- -! arguments (note: TMR = tracer mixing ratio) - - class(aerosol_properties), intent(in) :: aero_props - - integer, intent(in) :: ncnstaer ! number of aerosol constituents (extended) - integer, intent(in) :: nbins ! number of aerosol bins/modes - real(r8), intent(in) :: pi ! ratio of circle circumference to diameter - real(r8), intent(in) :: rhoh2o ! density of liquid water (STP) (kg/m3) - real(r8), intent(in) :: rh2o ! gas constant for water vapor (J/K/kg) - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - real(r8), intent(in) :: latvap ! latent heat of vaporization (J/kg) - real(r8), intent(in) :: cpair ! specific heat of dry air (J/K/kg) - real(r8), intent(in) :: rair ! dry air gas constant (J/K/kg) - - ! conu = tracer mixing ratios in updraft at top of this (current) level - ! The conu are changed by activation - real(r8), intent(inout) :: conu(2,ncnstaer) - ! conent = TMRs in the entrained air at this level - real(r8), intent(in) :: conent(2,ncnstaer) - real(r8), intent(inout) :: dconudt(2,ncnstaer) ! TMR tendencies due to activation - - real(r8), intent(in) :: f_ent ! fraction of updraft massflux that was - ! entrained across this layer == eudp/mu_p_eudp - real(r8), intent(in) :: dt_u ! lagrangian transport time (s) in the - ! updraft at current level - real(r8), intent(in) :: wup ! mean updraft vertical velocity (m/s) - ! at current level updraft - - real(r8), intent(in) :: tair ! Temperature in Kelvin - real(r8), intent(in) :: rhoair ! air density (kg/m3) - - integer, intent(in) :: ipass_calc_updraft - -!----------------------------------------------------------------------- -! local variables - integer :: l, m, mm - - real(r8) :: delact ! working variable - real(r8) :: dt_u_inv ! 1.0/dt_u - real(r8) :: fluxm(nbins) ! to understand this, see subr activate_aerosol - real(r8) :: fluxn(nbins) ! to understand this, see subr activate_aerosol - real(r8) :: flux_fullact ! to understand this, see subr activate_aerosol - real(r8) :: fm(nbins) ! mass fraction of aerosols activated - real(r8) :: fn(nbins) ! number fraction of aerosols activated - real(r8) :: hygro(nbins) ! current hygroscopicity for int+act - real(r8) :: naerosol(nbins) ! interstitial+activated number conc (#/m3) - real(r8) :: sigw ! standard deviation of updraft velocity (cm/s) - real(r8) :: tmp_fact ! working variable - real(r8) :: vaerosol(nbins) ! int+act volume (m3/m3) - real(r8) :: wbar ! mean updraft velocity (cm/s) - real(r8) :: wdiab ! diabatic vertical velocity (cm/s) - real(r8) :: wminf, wmaxf ! limits for integration over updraft spectrum (cm/s) - - real(r8) :: spec_hygro - real(r8) :: spec_dens - character(len=32) :: spec_type - - real(r8) :: tmpa, tmpb, tmpc ! working variable - real(r8) :: naerosol_a(1,1) ! number conc (1/m3) - real(r8) :: vaerosol_a(1,1) ! volume conc (m3/m3) - - character(len=*), intent(out) :: errmsg ! error message from activate_aerosol - integer, intent(out) :: errflg ! error flag from activate_aerosol - -!----------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - -! when ipass_calc_updraft == 2, apply the activation tendencies -! from pass 1, but multiplied by factor_reduce_actfrac -! (can only have ipass_calc_updraft == 2 when method_reduce_actfrac = 2) - if (ipass_calc_updraft == 2) then - - dt_u_inv = 1.0_r8/dt_u - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - - delact = dconudt(2,mm)*dt_u * factor_reduce_actfrac - delact = min( delact, conu(1,mm) ) - delact = max( delact, 0.0_r8 ) - conu(1,mm) = conu(1,mm) - delact - conu(2,mm) = conu(2,mm) + delact - dconudt(1,mm) = -delact*dt_u_inv - dconudt(2,mm) = delact*dt_u_inv - - end do - end do - - return - - end if ! (ipass_calc_updraft == 2) - -! check f_ent > 0 - if (f_ent <= 0.0_r8) return - - hygro = 0.0_r8 - vaerosol = 0.0_r8 - naerosol = 0.0_r8 - - do m = 1, nbins -! compute a (or a+cw) volume and hygroscopicity - tmpa = 0.0_r8 - tmpb = 0.0_r8 - do l = 1, aero_props%nmasses(m) - - mm = aero_props%indexer(m,l) - - call aero_props%get(m, l, spectype=spec_type, density=spec_dens, hygro=spec_hygro) - - tmpc = max( conent(1,mm), 0.0_r8 ) - if ( use_cwaer_for_activate_maxsat ) & - tmpc = tmpc + max( conent(2,mm), 0.0_r8 ) - tmpc = tmpc / spec_dens - tmpa = tmpa + tmpc - tmpb = tmpb + tmpc * spec_hygro - end do - vaerosol(m) = tmpa * rhoair - if (tmpa < 1.0e-35_r8) then - hygro(m) = 0.2_r8 - else - hygro(m) = tmpb/tmpa - end if - -! load a (or a+cw) number and bound it - tmpa = max( conent(1,mm), 0.0_r8 ) - if ( use_cwaer_for_activate_maxsat ) & - tmpa = tmpa + max( conent(2,mm), 0.0_r8 ) - naerosol(m) = tmpa * rhoair - - naerosol_a(1,1) = naerosol(m) - vaerosol_a(1,1) = vaerosol(m) - - call aero_props%apply_number_limits( naerosol_a, vaerosol_a, 1, 1, m ) - - naerosol(m) = naerosol_a(1,1) - end do - -! call Razzak-Ghan activation routine with single updraft - wbar = max( wup, 0.5_r8 ) ! force wbar >= 0.5 m/s for now - sigw = 0.0_r8 - wdiab = 0.0_r8 - wminf = wbar - wmaxf = wbar - - call activate_aerosol( & - wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & - naerosol, nbins, vaerosol, hygro, aero_props, & - fn, fm, fluxn, fluxm, flux_fullact, & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, errmsg, errflg ) - if (errflg /= 0) return - -! apply the activation fractions to the updraft aerosol mixing ratios - dt_u_inv = 1.0_r8/dt_u - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - - if ( (method_reduce_actfrac == 1) .and. & - (factor_reduce_actfrac >= 0.0_r8) .and. & - (factor_reduce_actfrac < 1.0_r8) ) & - tmp_fact = tmp_fact * factor_reduce_actfrac - - delact = min( conent(1,mm)*tmp_fact*f_ent, conu(1,mm) ) - delact = max( delact, 0.0_r8 ) - conu(1,mm) = conu(1,mm) - delact - conu(2,mm) = conu(2,mm) + delact - dconudt(1,mm) = -delact*dt_u_inv - dconudt(2,mm) = delact*dt_u_inv - end do - end do - - end subroutine activate_convproc - -!========================================================================================= - subroutine activate_convproc_method2( aero_props, & - conu, dconudt, & - f_ent, dt_u, wup, & - tair, rhoair, k, & - kactfirst, ipass_calc_updraft, & - ncnstaer, nbins, convproc_pom_spechygro, & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & - errmsg, errflg ) -!----------------------------------------------------------------------- -! -! Purpose: -! Calculate activation of aerosol species in convective updraft -! for a single column and level -! -! Method: -! conu(l) = Updraft TMR (tracer mixing ratio) at k/k-1 interface -! f_ent = Fraction of the "before-detrainment" updraft massflux at -! k/k-1 interface" resulting from entrainment of level k air -! (where k is the current level in subr aero_convproc_run) -! -! On entry to this routine, the conu(l) represents the updraft TMR -! after entrainment, but before chemistry/physics and detrainment. -! -! This routine applies aerosol activation to the conu tracer mixing ratios, -! then adjusts the conu so that on exit, -! conu(la) = conu_incoming(la) - conu(la)*f_act(la) -! conu(lc) = conu_incoming(lc) + conu(la)*f_act(la) -! where -! la, lc = indices for an unactivated/activated aerosol component pair -! f_act = fraction of conu(la) that is activated. The f_act are -! calculated with the Razzak-Ghan activation parameterization. -! The f_act differ for each mode, and for number/surface/mass. -! -! At cloud base (k==kactfirst), primary activation is done using the -! "standard" code in subr activate do diagnose maximum supersaturation. -! Above cloud base, secondary activation is done using a -! prescribed supersaturation. -! -! *** The updraft velocity used for activation calculations is rather -! uncertain and needs more work. However, an updraft of 1-3 m/s -! will activate essentially all of accumulation and coarse mode particles. -! -! Author: R. Easter -! -!----------------------------------------------------------------------- - - use aero_activate, only: activate_aerosol - -!----------------------------------------------------------------------- -! arguments (note: TMR = tracer mixing ratio) - - class(aerosol_properties), intent(in) :: aero_props - - integer, intent(in) :: ncnstaer ! number of aerosol constituents (extended) - integer, intent(in) :: nbins ! number of aerosol bins/modes - real(r8), intent(in) :: convproc_pom_spechygro ! prescribed p-organic hygroscopicity (<0 = use default) - real(r8), intent(in) :: pi ! ratio of circle circumference to diameter - real(r8), intent(in) :: rhoh2o ! density of liquid water (STP) (kg/m3) - real(r8), intent(in) :: rh2o ! gas constant for water vapor (J/K/kg) - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - real(r8), intent(in) :: latvap ! latent heat of vaporization (J/kg) - real(r8), intent(in) :: cpair ! specific heat of dry air (J/K/kg) - real(r8), intent(in) :: rair ! dry air gas constant (J/K/kg) - - ! conu = tracer mixing ratios in updraft at top of this (current) level - ! The conu are changed by activation - real(r8), intent(inout) :: conu(2,ncnstaer) - real(r8), intent(inout) :: dconudt(2,ncnstaer) ! TMR tendencies due to activation - - real(r8), intent(in) :: f_ent ! fraction of updraft massflux that was - ! entrained across this layer == eudp/mu_p_eudp - real(r8), intent(in) :: dt_u ! lagrangian transport time (s) in the - ! updraft at current level - real(r8), intent(in) :: wup ! mean updraft vertical velocity (m/s) - ! at current level updraft - - real(r8), intent(in) :: tair ! Temperature in Kelvin - real(r8), intent(in) :: rhoair ! air density (kg/m3) - ! used as in-cloud wet removal rate - integer, intent(in) :: k ! level index - integer, intent(in) :: kactfirst ! k at cloud base - integer, intent(in) :: ipass_calc_updraft - -!----------------------------------------------------------------------- -! local variables - integer :: l, m, mm - - real(r8) :: delact ! working variable - real(r8) :: dt_u_inv ! 1.0/dt_u - real(r8) :: fluxm(nbins) ! to understand this, see subr activate_aerosol - real(r8) :: fluxn(nbins) ! to understand this, see subr activate_aerosol - real(r8) :: flux_fullact ! to understand this, see subr activate_aerosol - real(r8) :: fm(nbins) ! mass fraction of aerosols activated - real(r8) :: fn(nbins) ! number fraction of aerosols activated - real(r8) :: hygro(nbins) ! current hygroscopicity for int+act - real(r8) :: naerosol(nbins) ! interstitial+activated number conc (#/m3) - real(r8) :: sigw ! standard deviation of updraft velocity (cm/s) - real(r8) :: smax_prescribed ! prescribed supersaturation for secondary activation (0-1 fraction) - real(r8) :: tmp_fact ! working variable - real(r8) :: vaerosol(nbins) ! int+act volume (m3/m3) - real(r8) :: wbar ! mean updraft velocity (cm/s) - real(r8) :: wdiab ! diabatic vertical velocity (cm/s) - real(r8) :: wminf, wmaxf ! limits for integration over updraft spectrum (cm/s) - - real(r8) :: spec_hygro - real(r8) :: spec_dens - character(len=32) :: spec_type - - real(r8) :: tmpa, tmpb, tmpc ! working variable - real(r8) :: naerosol_a(1,1) ! number conc (1/m3) - real(r8) :: vaerosol_a(1,1) ! volume conc (m3/m3) - - character(len=*), intent(out) :: errmsg ! error message from activate_aerosol - integer, intent(out) :: errflg ! error flag from activate_aerosol - -!----------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - -! when ipass_calc_updraft == 2, apply the activation tendencies -! from pass 1, but multiplied by factor_reduce_actfrac -! (can only have ipass_calc_updraft == 2 when method_reduce_actfrac = 2) - - if (ipass_calc_updraft == 2) then - - dt_u_inv = 1.0_r8/dt_u - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - - delact = dconudt(2,mm)*dt_u * factor_reduce_actfrac - delact = min( delact, conu(1,mm) ) - delact = max( delact, 0.0_r8 ) - conu(1,mm) = conu(1,mm) - delact - conu(2,mm) = conu(2,mm) + delact - dconudt(1,mm) = -delact*dt_u_inv - dconudt(2,mm) = delact*dt_u_inv - end do - end do ! "n = 1, ntot_amode" - return - - end if ! (ipass_calc_updraft == 2) - -! check f_ent > 0 - if (f_ent <= 0.0_r8) return - - hygro = 0.0_r8 - vaerosol = 0.0_r8 - naerosol = 0.0_r8 - - do m = 1, nbins -! compute a (or a+cw) volume and hygroscopicity - tmpa = 0.0_r8 - tmpb = 0.0_r8 - do l = 1, aero_props%nspecies(m) - - mm = aero_props%indexer(m,l) - - call aero_props%get(m, l, spectype=spec_type, density=spec_dens, hygro=spec_hygro) - - tmpc = max( conu(1,mm), 0.0_r8 ) - if ( use_cwaer_for_activate_maxsat ) & - tmpc = tmpc + max( conu(2,mm), 0.0_r8 ) - tmpc = tmpc / spec_dens - tmpa = tmpa + tmpc - - ! Change the hygroscopicity of POM based on the discussion with Prof. - ! Xiaohong Liu. Some observational studies found that the primary organic - ! material from biomass burning emission shows very high hygroscopicity. - ! Also, found that BC mass will be overestimated if all the aerosols in - ! the primary mode are free to be removed. Therefore, set the hygroscopicity - ! of POM here as 0.2 to enhance the wet scavenge of primary BC and POM. - - if (spec_type=='p-organic' .and. convproc_pom_spechygro>0._r8) then - tmpb = tmpb + tmpc * convproc_pom_spechygro - else - tmpb = tmpb + tmpc * spec_hygro - end if - end do - vaerosol(m) = tmpa * rhoair - if (tmpa < 1.0e-35_r8) then - hygro(m) = 0.2_r8 - else - hygro(m) = tmpb/tmpa - end if - - mm = aero_props%indexer(m,0) - -! load a (or a+cw) number and bound it - tmpa = max( conu(1,mm), 0.0_r8 ) - if ( use_cwaer_for_activate_maxsat ) & - tmpa = tmpa + max( conu(2,mm), 0.0_r8 ) - naerosol(m) = tmpa * rhoair - - naerosol_a(1,1) = naerosol(m) - vaerosol_a(1,1) = vaerosol(m) - - call aero_props%apply_number_limits( naerosol_a, vaerosol_a, 1, 1, m ) - - naerosol(m) = naerosol_a(1,1) - - end do - -! call Razzak-Ghan activation routine with single updraft - wbar = max( wup, 0.5_r8 ) ! force wbar >= 0.5 m/s for now - sigw = 0.0_r8 - wdiab = 0.0_r8 - wminf = wbar - wmaxf = wbar - - if (k == kactfirst) then - - call activate_aerosol( & - wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & - naerosol, nbins, vaerosol, hygro, aero_props, & - fn, fm, fluxn, fluxm, flux_fullact, & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, errmsg, errflg ) - if (errflg /= 0) return - - else -! above cloud base - do secondary activation with prescribed supersat -! that is constant with height - smax_prescribed = method2_activate_smaxmax - call activate_aerosol( & - wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & - naerosol, nbins, vaerosol, hygro, aero_props, & - fn, fm, fluxn, fluxm, flux_fullact, & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, errmsg, errflg, & - smax_prescribed ) - if (errflg /= 0) return - end if - -! apply the activation fractions to the updraft aerosol mixing ratios - dt_u_inv = 1.0_r8/dt_u - - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - if (l==0) then - tmp_fact = fn(m) - else - tmp_fact = fm(m) - end if - - if ( (method_reduce_actfrac == 1) .and. & - (factor_reduce_actfrac >= 0.0_r8) .and. & - (factor_reduce_actfrac < 1.0_r8) ) & - tmp_fact = tmp_fact * factor_reduce_actfrac - - delact = min( conu(1,mm)*tmp_fact, conu(1,mm) ) - delact = max( delact, 0.0_r8 ) - conu(1,mm) = conu(1,mm) - delact - conu(2,mm) = conu(2,mm) + delact - dconudt(1,mm) = -delact*dt_u_inv - dconudt(2,mm) = delact*dt_u_inv - end do - end do - - end subroutine activate_convproc_method2 - -!========================================================================================= - subroutine resuspend_convproc( aero_props, & - dcondt, dcondt_resusp, ktop, kbot_prevap, & - pver, ncnstaer, convproc_do_evaprain_atonce ) -!----------------------------------------------------------------------- -! -! Purpose: -! Calculate resuspension of activated aerosol species resulting from both -! detrainment from updraft and downdraft into environment -! subsidence and lifting of environment, which may move air from -! levels with large-scale cloud to levels with no large-scale cloud -! -! Method: -! Three possible approaches were considered: -! -! 1. Ad-hoc #1 approach. At each level, adjust dcondt for the activated -! and unactivated portions of a particular aerosol species so that the -! ratio of dcondt (activated/unactivate) is equal to the ratio of the -! mixing ratios before convection. -! THIS WAS IMPLEMENTED IN MIRAGE2 -! -! 2. Ad-hoc #2 approach. At each level, adjust dcondt for the activated -! and unactivated portions of a particular aerosol species so that the -! change to the activated portion is minimized (zero if possible). The -! would minimize effects of convection on the large-scale cloud. -! THIS IS CURRENTLY IMPLEMENTED IN CAM5 where we assume that convective -! clouds have no impact on the stratiform-cloudborne aerosol -! -! 3. Mechanistic approach that treats the details of interactions between -! the large-scale and convective clouds. (Something for the future.) -! -! Author: R. Easter -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! arguments -! (note: TMR = tracer mixing ratio) - - class(aerosol_properties), intent(in) :: aero_props - integer, intent(in) :: pver ! number of vertical layers - integer, intent(in) :: ncnstaer ! number of aerosol constituents (extended) - logical, intent(in) :: convproc_do_evaprain_atonce - real(r8), intent(inout) :: dcondt(2,ncnstaer,pver) - ! overall TMR tendency from convection - real(r8), intent(inout) :: dcondt_resusp(2,ncnstaer,pver) - ! portion of TMR tendency due to resuspension - ! (actually, due to the adjustments made here) - integer, intent(in) :: ktop, kbot_prevap ! indices of top and bottom cloud levels - -!----------------------------------------------------------------------- -! local variables - integer :: k, l, m, mm - real(r8) :: qdota, qdotc, qdotac ! working variables (MR tendencies) - !----------------------------------------------------------------------- - - ! apply adjustments to dcondt for pairs of unactivated and - ! activated aerosol species - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - - do k = ktop, kbot_prevap - if (convproc_do_evaprain_atonce) then - dcondt_resusp(1,mm,k) = dcondt(1,mm,k) - dcondt_resusp(2,mm,k) = dcondt(2,mm,k) - else - qdota = dcondt(1,mm,k) - qdotc = dcondt(2,mm,k) - qdotac = qdota + qdotc - - dcondt(1,mm,k) = qdotac - dcondt(2,mm,k) = 0.0_r8 - - dcondt_resusp(1,mm,k) = (dcondt(1,mm,k) - qdota) - dcondt_resusp(2,mm,k) = (dcondt(2,mm,k) - qdotc) - end if - end do - - end do - end do - - end subroutine resuspend_convproc - -!========================================================================================= - -end module aero_convproc diff --git a/src/chemistry/aerosol/aero_drydep_core.F90 b/src/chemistry/aerosol/aero_drydep_core.F90 deleted file mode 100644 index 0ae24842f7..0000000000 --- a/src/chemistry/aerosol/aero_drydep_core.F90 +++ /dev/null @@ -1,319 +0,0 @@ -!=============================================================================== -! Aerosol dry deposition -! Portable science routines split from modal_aero/aero_model.F90 and -! aer_drydep_mod.F90: surface deposition velocities of particles -! (Zhang et al. 2001) and the aerodynamic resistance / friction velocity -! patch over ocean and sea ice. Host constants and the landuse fractions -! are passed as arguments; array sizing is by ncol/pver runtime arguments. -!=============================================================================== -module aero_drydep_core - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - - public :: modal_aero_depvel_part - public :: calcram - -contains - - !============================================================================= - !============================================================================= - subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc_grv, & - radius_part, density_part, sig_part, moment, & - pver, top_lev, n_land_type, fraction_landuse, & - pi, boltz, gravit, rair, aspherical ) ! dmleung added aspherical flag 20 Oct 2025 - -! calculates surface deposition velocity of particles -! L. Zhang, S. Gong, J. Padro, and L. Barrie -! A size-seggregated particle dry deposition scheme for an atmospheric aerosol module -! Atmospheric Environment, 35, 549-560, 2001. -! -! Authors: X. Liu - - ! !ARGUMENTS: - ! - implicit none - ! - real(r8), intent(in) :: t(:,:) !atm temperature (K) - real(r8), intent(in) :: pmid(:,:) !atm pressure (Pa) - real(r8), intent(in) :: fv(:) !friction velocity (m/s) - real(r8), intent(in) :: ram1(:) !aerodynamical resistance (s/m) - real(r8), intent(in) :: radius_part(:,:) ! mean (volume/number) particle radius (m) - real(r8), intent(in) :: density_part(:,:) ! density of particle material (kg/m3) - real(r8), intent(in) :: sig_part(:,:) ! geometric standard deviation of particles - integer, intent(in) :: moment ! moment of size distribution (0 for number, 2 for surface area, 3 for volume) - integer, intent(in) :: ncol - integer, intent(in) :: pver ! number of vertical levels - integer, intent(in) :: top_lev ! top level for modal aerosols - integer, intent(in) :: n_land_type ! number of land use types - real(r8), intent(in) :: fraction_landuse(:,:) ! land use fractions (ncol, n_land_type) - real(r8), intent(in) :: pi ! host model constants - real(r8), intent(in) :: boltz ! Boltzmann constant (J/K) - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - real(r8), intent(in) :: rair ! gas constant for dry air (J/K/kg) - - real(r8), intent(out) :: vlc_trb(:) !Turbulent deposn velocity (m/s) - real(r8), intent(out) :: vlc_grv(:,:) !grav deposn velocity (m/s) - real(r8), intent(out) :: vlc_dry(:,:) !dry deposn velocity (m/s) - logical, intent(in), OPTIONAL :: aspherical ! dmleung: asphericity is strong for coarse-mode interstitial - ! aerosols only, mostly dust and seasalt. For coarse mode aerosols, asphericity reduces coarse-mode gravitational - ! settling velocity by 20 % following Fig. 4 of Yue Huang et al. (2020). - !------------------------------------------------------------------------ - - !------------------------------------------------------------------------ - ! Local Variables - integer :: m,i,k,ix !indices - real(r8) :: rho !atm density (kg/m**3) - real(r8) :: vsc_dyn_atm(ncol,pver) ![kg m-1 s-1] Dynamic viscosity of air - real(r8) :: vsc_knm_atm(ncol,pver) ![m2 s-1] Kinematic viscosity of atmosphere - real(r8) :: shm_nbr ![frc] Schmidt number - real(r8) :: stk_nbr ![frc] Stokes number - real(r8) :: mfp_atm(ncol,pver) ![m] Mean free path of air - real(r8) :: dff_aer ![m2 s-1] Brownian diffusivity of particle - real(r8) :: slp_crc(ncol,pver) ![frc] Slip correction factor - real(r8) :: rss_trb ![s m-1] Resistance to turbulent deposition - real(r8) :: rss_lmn ![s m-1] Quasi-laminar layer resistance - real(r8) :: brownian ! collection efficiency for Browning diffusion - real(r8) :: impaction ! collection efficiency for impaction - real(r8) :: interception ! collection efficiency for interception - real(r8) :: stickfrac ! fraction of particles sticking to surface - real(r8) :: radius_moment(ncol,pver) ! median radius (m) for moment - real(r8) :: lnsig ! ln(sig_part) - real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity - ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) - - integer :: lt - real(r8) :: lnd_frc - real(r8) :: wrk1, wrk2, wrk3 - - ! constants - - real(r8), parameter :: asphericaldust_drydep = 0.8_r8 ! dmleung added 20 Oct 2025: aspherical dust reduces - ! gravitational settling velocity by 15-20 %. Yue Huang et al. (2020) - ! Climate Models and Remote Sensing Retrievals Neglect Substantial Desert Dust Asphericity - - real(r8) gamma(11) ! exponent of schmidt number -! data gamma/0.54d+00, 0.56d+00, 0.57d+00, 0.54d+00, 0.54d+00, & -! 0.56d+00, 0.54d+00, 0.54d+00, 0.54d+00, 0.56d+00, & -! 0.50d+00/ - data gamma/0.56e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.56e+00_r8, 0.56e+00_r8, & - 0.56e+00_r8, 0.50e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.54e+00_r8, & - 0.54e+00_r8/ - save gamma - - real(r8) alpha(11) ! parameter for impaction -! data alpha/50.00d+00, 0.95d+00, 0.80d+00, 1.20d+00, 1.30d+00, & -! 0.80d+00, 50.00d+00, 50.00d+00, 2.00d+00, 1.50d+00, & -! 100.00d+00/ - data alpha/1.50e+00_r8, 1.20e+00_r8, 1.20e+00_r8, 0.80e+00_r8, 1.00e+00_r8, & - 0.80e+00_r8, 100.00e+00_r8, 50.00e+00_r8, 2.00e+00_r8, 1.20e+00_r8, & - 50.00e+00_r8/ - save alpha - - real(r8) radius_collector(11) ! radius (m) of surface collectors -! data radius_collector/-1.00d+00, 5.10d-03, 3.50d-03, 3.20d-03, 10.00d-03, & -! 5.00d-03, -1.00d+00, -1.00d+00, 10.00d-03, 10.00d-03, & -! -1.00d+00/ - data radius_collector/10.00e-03_r8, 3.50e-03_r8, 3.50e-03_r8, 5.10e-03_r8, 2.00e-03_r8, & - 5.00e-03_r8, -1.00e+00_r8, -1.00e+00_r8, 10.00e-03_r8, 3.50e-03_r8, & - -1.00e+00_r8/ - save radius_collector - - integer :: iwet(11) ! flag for wet surface = 1, otherwise = -1 -! data iwet/1, -1, -1, -1, -1, & -! -1, -1, -1, 1, -1, & -! 1/ - data iwet/-1, -1, -1, -1, -1, & - -1, 1, -1, 1, -1, & - -1/ - save iwet - - - vlc_trb = 0._r8 - vlc_grv = 0._r8 - vlc_dry = 0._r8 - - !------------------------------------------------------------------------ - do k=top_lev,pver ! radius_part is not defined above top_lev - do i=1,ncol - - lnsig = log(sig_part(i,k)) -! use a maximum radius of 50 microns when calculating deposition velocity - radius_moment(i,k) = min(50.0e-6_r8,radius_part(i,k))* & - exp((float(moment)-1.5_r8)*lnsig*lnsig) - dispersion = exp(2._r8*lnsig*lnsig) - - rho=pmid(i,k)/rair/t(i,k) - - ! Quasi-laminar layer resistance: call rss_lmn_get - ! Size-independent thermokinetic properties - vsc_dyn_atm(i,k) = 1.72e-5_r8 * ((t(i,k)/273.0_r8)**1.5_r8) * 393.0_r8 / & - (t(i,k)+120.0_r8) ![kg m-1 s-1] RoY94 p. 102 - mfp_atm(i,k) = 2.0_r8 * vsc_dyn_atm(i,k) / & ![m] SeP97 p. 455 - (pmid(i,k)*sqrt(8.0_r8/(pi*rair*t(i,k)))) - vsc_knm_atm(i,k) = vsc_dyn_atm(i,k) / rho ![m2 s-1] Kinematic viscosity of air - - slp_crc(i,k) = 1.0_r8 + mfp_atm(i,k) * & - (1.257_r8+0.4_r8*exp(-1.1_r8*radius_moment(i,k)/(mfp_atm(i,k)))) / & - radius_moment(i,k) ![frc] Slip correction factor SeP97 p. 464 - vlc_grv(i,k) = (4.0_r8/18.0_r8) * radius_moment(i,k)*radius_moment(i,k)*density_part(i,k)* & - gravit*slp_crc(i,k) / vsc_dyn_atm(i,k) ![m s-1] Stokes' settling velocity SeP97 p. 466 - vlc_grv(i,k) = vlc_grv(i,k) * dispersion - - ! dmleung edited 20 Oct 2025 based on Longlei Li's edits ++ - ! asphericity reduces gravitational settling velocity of coarse-mode aerosols by 20 %. - ! scale flag is only true for coarse mode (m == n_coarse_dust). - if (present(aspherical)) then - if(aspherical) then - vlc_grv(i,k) = vlc_grv(i,k) * asphericaldust_drydep - end if - end if - ! dmleung -- - - vlc_dry(i,k)=vlc_grv(i,k) - enddo - enddo - k=pver ! only look at bottom level for next part - do i=1,ncol - dff_aer = boltz * t(i,k) * slp_crc(i,k) / & ![m2 s-1] - (6.0_r8*pi*vsc_dyn_atm(i,k)*radius_moment(i,k)) !SeP97 p.474 - shm_nbr = vsc_knm_atm(i,k) / dff_aer ![frc] SeP97 p.972 - - wrk2 = 0._r8 - wrk3 = 0._r8 - do lt = 1,n_land_type - lnd_frc = fraction_landuse(i,lt) - if ( lnd_frc /= 0._r8 ) then - brownian = shm_nbr**(-gamma(lt)) - if (radius_collector(lt) > 0.0_r8) then -! vegetated surface - stk_nbr = vlc_grv(i,k) * fv(i) / (gravit*radius_collector(lt)) - interception = 2.0_r8*(radius_moment(i,k)/radius_collector(lt))**2.0_r8 - else -! non-vegetated surface - stk_nbr = vlc_grv(i,k) * fv(i) * fv(i) / (gravit*vsc_knm_atm(i,k)) ![frc] SeP97 p.965 - interception = 0.0_r8 - endif - impaction = (stk_nbr/(alpha(lt)+stk_nbr))**2.0_r8 - - if (iwet(lt) > 0) then - stickfrac = 1.0_r8 - else - stickfrac = exp(-sqrt(stk_nbr)) - if (stickfrac < 1.0e-10_r8) stickfrac = 1.0e-10_r8 - endif - rss_lmn = 1.0_r8 / (3.0_r8 * fv(i) * stickfrac * (brownian+interception+impaction)) - rss_trb = ram1(i) + rss_lmn + ram1(i)*rss_lmn*vlc_grv(i,k) - - wrk1 = 1.0_r8 / rss_trb - wrk2 = wrk2 + lnd_frc*( wrk1 ) - wrk3 = wrk3 + lnd_frc*( wrk1 + vlc_grv(i,k) ) - endif - enddo ! n_land_type - vlc_trb(i) = wrk2 - vlc_dry(i,k) = wrk3 - enddo !ncol - - return - end subroutine modal_aero_depvel_part - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: subroutine Calcram -! -! !INTERFACE: -! - - subroutine calcram(ncol,landfrac,icefrac,ocnfrac,obklen,& - ustar,ram1in,ram1,t,pmid,& - pdel,fvin,fv,rair,gravit) - ! - ! !DESCRIPTION: - ! - ! Calc aerodynamic resistance over oceans and sea ice (comes in from land model) - ! from Seinfeld and Pandis, p.963. - ! - ! Author: Natalie Mahowald - ! - implicit none - integer, intent(in) :: ncol - real(r8),intent(in) :: ram1in(:) !aerodynamical resistance (s/m) - real(r8),intent(in) :: fvin(:) ! sfc frc vel from land - real(r8),intent(out) :: ram1(:) !aerodynamical resistance (s/m) - real(r8),intent(out) :: fv(:) ! sfc frc vel from land - real(r8), intent(in) :: obklen(:) ! obklen - real(r8), intent(in) :: ustar(:) ! sfc fric vel - real(r8), intent(in) :: landfrac(:) ! land fraction - real(r8), intent(in) :: icefrac(:) ! ice fraction - real(r8), intent(in) :: ocnfrac(:) ! ocean fraction - real(r8), intent(in) :: t(:) !atm temperature (K) - real(r8), intent(in) :: pmid(:) !atm pressure (Pa) - real(r8), intent(in) :: pdel(:) !atm pressure (Pa) - real(r8), intent(in) :: rair ! gas constant for dry air (J/K/kg) - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - real(r8), parameter :: zzocen = 0.0001_r8 ! Ocean aerodynamic roughness length - real(r8), parameter :: zzsice = 0.0400_r8 ! Sea ice aerodynamic roughness length - real(r8), parameter :: xkar = 0.4_r8 ! Von Karman constant - - ! local variables - real(r8) :: z,psi,psi0,nu,nu0,temp,ram - integer :: i - ! write(iulog,*) rair,zzsice,zzocen,gravit,xkar - - - do i=1,ncol - z=pdel(i)*rair*t(i)/pmid(i)/gravit/2.0_r8 !use half the layer height like Ganzefeld and Lelieveld, 1995 - if(obklen(i).eq.0) then - psi=0._r8 - psi0=0._r8 - else - psi=min(max(z/obklen(i),-1.0_r8),1.0_r8) - psi0=min(max(zzocen/obklen(i),-1.0_r8),1.0_r8) - endif - temp=z/zzocen - if(icefrac(i) > 0.5_r8) then - if(obklen(i).gt.0) then - psi0=min(max(zzsice/obklen(i),-1.0_r8),1.0_r8) - else - psi0=0.0_r8 - endif - temp=z/zzsice - endif - if(psi> 0._r8) then - ram=1/xkar/ustar(i)*(log(temp)+4.7_r8*(psi-psi0)) - else - nu=(1.00_r8-15.000_r8*psi)**(.25_r8) - nu0=(1.000_r8-15.000_r8*psi0)**(.25_r8) - if(ustar(i).ne.0._r8) then - ram=1/xkar/ustar(i)*(log(temp) & - +log(((nu0**2+1.00_r8)*(nu0+1.0_r8)**2)/((nu**2+1.0_r8)*(nu+1.00_r8)**2)) & - +2.0_r8*(atan(nu)-atan(nu0))) - else - ram=0._r8 - endif - endif - if(landfrac(i) < 0.000000001_r8) then - fv(i)=ustar(i) - ram1(i)=ram - else - fv(i)=fvin(i) - ram1(i)=ram1in(i) - endif - ! write(iulog,*) i,pdel(i),t(i),pmid(i),gravit,obklen(i),psi,psi0,icefrac(i),nu,nu0,ram,ustar(i),& - ! log(((nu0**2+1.00)*(nu0+1.0)**2)/((nu**2+1.0)*(nu+1.00)**2)),2.0*(atan(nu)-atan(nu0)) - - enddo - - ! fvitt -- fv == 0 causes a floating point exception in - ! dry dep of sea salts and dust - where ( fv(:ncol) == 0._r8 ) - fv(:ncol) = 1.e-12_r8 - endwhere - - return - end subroutine calcram - -end module aero_drydep_core diff --git a/src/chemistry/aerosol/cldaero_mod.F90 b/src/chemistry/aerosol/cldaero_mod.F90 deleted file mode 100644 index ca81dc94ed..0000000000 --- a/src/chemistry/aerosol/cldaero_mod.F90 +++ /dev/null @@ -1,153 +0,0 @@ -!---------------------------------------------------------------------------------- -! low level utility module for cloud aerosols -! -! Created by Francis Vitt -! -! Portable (CCPP-ready): array sizes are runtime arguments and host constants -! are passed in; no CAM infrastructure dependencies. -!---------------------------------------------------------------------------------- -module cldaero_mod - - use shr_kind_mod, only : r8 => shr_kind_r8 - - implicit none - private - - public :: cldaero_uptakerate - public :: cldaero_conc_t - public :: cldaero_allocate - public :: cldaero_deallocate - - type cldaero_conc_t - real(r8), pointer :: so4c(:,:) - real(r8), pointer :: nh4c(:,:) - real(r8), pointer :: no3c(:,:) - real(r8), pointer :: xlwc(:,:) - real(r8) :: so4_fact - end type cldaero_conc_t - -contains - -!---------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------- - function cldaero_allocate( ncol, pver ) result( cldconc ) - integer, intent(in) :: ncol ! number of columns in chunk - integer, intent(in) :: pver ! number of vertical levels - - type(cldaero_conc_t), pointer:: cldconc - - allocate( cldconc ) - allocate( cldconc%so4c(ncol,pver) ) - allocate( cldconc%nh4c(ncol,pver) ) - allocate( cldconc%no3c(ncol,pver) ) - allocate( cldconc%xlwc(ncol,pver) ) - - cldconc%so4c(:,:) = 0._r8 - cldconc%nh4c(:,:) = 0._r8 - cldconc%no3c(:,:) = 0._r8 - cldconc%xlwc(:,:) = 0._r8 - cldconc%so4_fact = 2._r8 - - end function cldaero_allocate - -!---------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------- - subroutine cldaero_deallocate( cldconc ) - type(cldaero_conc_t), pointer :: cldconc - - if ( associated(cldconc%so4c) ) then - deallocate(cldconc%so4c) - nullify(cldconc%so4c) - endif - - if ( associated(cldconc%nh4c) ) then - deallocate(cldconc%nh4c) - nullify(cldconc%nh4c) - endif - - if ( associated(cldconc%no3c) ) then - deallocate(cldconc%no3c) - nullify(cldconc%no3c) - endif - - if ( associated(cldconc%xlwc) ) then - deallocate(cldconc%xlwc) - nullify(cldconc%xlwc) - endif - - deallocate( cldconc ) - nullify( cldconc ) - - end subroutine cldaero_deallocate - -!---------------------------------------------------------------------------------- -! utility function for cloud-borne aerosols -!---------------------------------------------------------------------------------- - - function cldaero_uptakerate( xl, cldnum, cfact, cldfrc, tfld, press, pi ) result( uptkrate ) - - real(r8), intent(in) :: xl, cldnum, cfact, cldfrc, tfld, press - real(r8), intent(in) :: pi ! host value of pi (passed for bit-for-bit consistency) - - real(r8) :: uptkrate - - real(r8) :: & - rad_cd, radxnum_cd, num_cd, & - gasdiffus, gasspeed, knudsen, & - fuchs_sutugin, volx34pi_cd - -!----------------------------------------------------------------------- -! compute uptake of h2so4 and msa to cloud water -! -! first-order uptake rate is -! 4*pi*(drop radius)*(drop number conc) -! *(gas diffusivity)*(fuchs sutugin correction) - -! num_cd = (drop number conc in 1/cm^3) - num_cd = 1.0e-3_r8*cldnum*cfact/cldfrc - num_cd = max( num_cd, 0.0_r8 ) - -! rad_cd = (drop radius in cm), computed from liquid water and drop number, -! then bounded by 0.5 and 50.0 micrometers -! radxnum_cd = (drop radius)*(drop number conc) -! volx34pi_cd = (3/4*pi) * (liquid water volume in cm^3/cm^3) - - volx34pi_cd = xl*0.75_r8/pi - -! following holds because volx34pi_cd = num_cd*(rad_cd**3) - radxnum_cd = (volx34pi_cd*num_cd*num_cd)**0.3333333_r8 - -! apply bounds to rad_cd to avoid the occasional unphysical value - if (radxnum_cd .le. volx34pi_cd*4.0e4_r8) then - radxnum_cd = volx34pi_cd*4.0e4_r8 - rad_cd = 50.0e-4_r8 - else if (radxnum_cd .ge. volx34pi_cd*4.0e8_r8) then - radxnum_cd = volx34pi_cd*4.0e8_r8 - rad_cd = 0.5e-4_r8 - else - rad_cd = radxnum_cd/num_cd - end if - -! gasdiffus = h2so4 gas diffusivity from mosaic code (cm^2/s) -! (pmid must be Pa) - gasdiffus = 0.557_r8 * (tfld**1.75_r8) / press - -! gasspeed = h2so4 gas mean molecular speed from mosaic code (cm/s) - gasspeed = 1.455e4_r8 * sqrt(tfld/98.0_r8) - -! knudsen number - knudsen = 3.0_r8*gasdiffus/(gasspeed*rad_cd) - -! following assumes accomodation coefficient = 0.65 -! (Adams & Seinfeld, 2002, JGR, and references therein) -! fuchs_sutugin = (0.75*accom*(1. + knudsen)) / -! (knudsen*(1.0 + knudsen + 0.283*accom) + 0.75*accom) - fuchs_sutugin = (0.4875_r8*(1._r8 + knudsen)) / & - (knudsen*(1.184_r8 + knudsen) + 0.4875_r8) - -! instantaneous uptake rate - uptkrate = 12.56637_r8*radxnum_cd*gasdiffus*fuchs_sutugin - - end function cldaero_uptakerate - -end module cldaero_mod diff --git a/src/chemistry/aerosol/dust_common.F90 b/src/chemistry/aerosol/dust_common.F90 deleted file mode 100644 index 8ffbdb5e0f..0000000000 --- a/src/chemistry/aerosol/dust_common.F90 +++ /dev/null @@ -1,264 +0,0 @@ -!============================================================================= -! Common dust module -! Portable: host constants are passed as arguments; errors are reported -! through errmsg/errflg for the caller to handle. -!============================================================================= -module dust_common - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - - public :: dust_set_params - - ! Dust aerosol material density used by the emissions number/mass flux - ! conversion and the settling parameters below (value from CAM mo_constants). - real(r8), public, parameter :: dust_density = 2.5e+3_r8 ! [kg m-3] - -contains - - !============================================================================= - ! - ! !DESCRIPTION: - ! - ! Compute source efficiency factor from topography - ! Initialize other variables used in subroutine Dust: - ! ovr_src_snk_mss(m,n) and tmp1. - ! Define particle diameter and density needed by atm model - ! as well as by dry dep model - ! Source: Paul Ginoux (for source efficiency factor) - ! Modifications by C. Zender and later by S. Levis - ! Rest of subroutine from C. Zender's dust model - !============================================================================= - subroutine dust_set_params( nbin, dmt_grd, dmt_vwr, stk_crc, pi, rair, gravit, errmsg, errflg ) - - ! - ! !USES - ! - use shr_infnan_mod, only: nan => shr_infnan_nan, assignment(=) - - ! - ! !ARGUMENTS: - ! - integer, intent(in) :: nbin - real(r8),intent(in) :: dmt_grd(:) - real(r8),intent(out) :: dmt_vwr(:) - real(r8),intent(out) :: stk_crc(:) - real(r8),intent(in) :: pi ! host model constants - real(r8),intent(in) :: rair ! gas constant for dry air (J/K/kg) - real(r8),intent(in) :: gravit ! gravitational acceleration (m/s2) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! - ! !REVISION HISTORY - ! Created by Samual Levis - ! Revised for CAM by Natalie Mahowald - !EOP - !------------------------------------------------------------------------ - - !------------------------------------------------------------------------ - !Local Variables - integer, parameter:: dst_src_nbr =3 - integer, parameter:: sz_nbr =200 - - integer :: m,n !indices - real(r8) :: dmt_min(nbin) ![m] Size grid minimum - real(r8) :: dmt_max(nbin) ![m] Size grid maximum - real(r8) :: dmt_ctr(nbin) ![m] Diameter at bin center - real(r8) :: dmt_dlt(nbin) ![m] Width of size bin - real(r8) :: slp_crc(nbin) ![frc] Slip correction factor - real(r8) :: vlm_rsl(nbin) ![m3 m-3] Volume concentration resolved - real(r8) :: vlc_stk(nbin) ![m s-1] Stokes settling velocity - real(r8) :: vlc_grv(nbin) ![m s-1] Settling velocity - real(r8) :: ryn_nbr_grv(nbin) ![frc] Reynolds number at terminal velocity - real(r8) :: cff_drg_grv(nbin) ![frc] Drag coefficient at terminal velocity - real(r8) :: tmp !temporary - real(r8) :: ln_gsd ![frc] ln(gsd) - real(r8) :: gsd_anl ![frc] Geometric standard deviation - real(r8) :: dmt_vma ![m] Mass median diameter analytic She84 p.75 Tabl.1 - real(r8) :: dmt_nma ![m] Number median particle diameter - real(r8) :: lgn_dst !Lognormal distribution at sz_ctr - real(r8) :: eps_max ![frc] Relative accuracy for convergence - real(r8) :: eps_crr ![frc] Current relative accuracy - real(r8) :: itr_idx ![idx] Counting index - real(r8) :: dns_mdp ![kg m-3] Midlayer density - real(r8) :: mfp_atm ![m] Mean free path of air - real(r8) :: vsc_dyn_atm ![kg m-1 s-1] Dynamic viscosity of air - real(r8) :: vsc_knm_atm ![kg m-1 s-1] Kinematic viscosity of air - real(r8) :: vlc_grv_old ![m s-1] Previous gravitational settling velocity - real(r8) :: series_ratio !Factor for logarithmic grid - real(r8) :: lngsdsqrttwopi_rcp !Factor in lognormal distribution - real(r8) :: sz_min(sz_nbr) ![m] Size Bin minima - real(r8) :: sz_max(sz_nbr) ![m] Size Bin maxima - real(r8) :: sz_ctr(sz_nbr) ![m] Size Bin centers - real(r8) :: sz_dlt(sz_nbr) ![m] Size Bin widths - - errmsg = '' - errflg = 0 - - stk_crc(:) = nan - dmt_vwr(:) = nan - - ! Introducing particle diameter. Needed by atm model and by dry dep model. - ! Taken from Charlie Zender's subroutines dst_psd_ini, dst_sz_rsl, - ! grd_mk (dstpsd.F90) and subroutine lgn_evl (psdlgn.F90) - - ! Charlie allows logarithmic or linear option for size distribution - ! however, he hardwires the distribution to logarithmic in his code - ! therefore, I take his logarithmic code only - ! furthermore, if dst_nbr == 4, he overrides the automatic grid calculation - ! he currently works with dst_nbr = 4, so I only take the relevant code - ! if dust_number ever becomes different from 4, must add call grd_mk (dstpsd.F90) - ! as done in subroutine dst_psd_ini - ! note that here dust_number = dst_nbr - - ! Override automatic grid with preset grid if available - do n = 1, nbin - dmt_min(n) = dmt_grd(n) ![m] Max diameter in bin - dmt_max(n) = dmt_grd(n+1) ![m] Min diameter in bin - dmt_ctr(n) = 0.5_r8 * (dmt_min(n)+dmt_max(n)) ![m] Diameter at bin ctr - dmt_dlt(n) = dmt_max(n)-dmt_min(n) ![m] Width of size bin - end do - - ! sets dust_dmt_vwr .... - - ! Bin physical properties - gsd_anl = 2.0_r8 ! [frc] Geometric std dev PaG77 p. 2080 Table1 - ln_gsd = log(gsd_anl) - - ! Set a fundamental statistic for each bin - dmt_vma = 2.524e-6_r8 ! [m] Mass median diameter analytic She84 p.75 Table1 - dmt_vma = 3.5e-6_r8 - ! Compute analytic size statistics - ! Convert mass median diameter to number median diameter (call vma2nma) - dmt_nma = dmt_vma * exp(-3.0_r8*ln_gsd*ln_gsd) ! [m] - ! Compute resolved size statistics for each size distribution - ! In C. Zender's code call dst_sz_rsl - do n = 1, nbin - series_ratio = (dmt_max(n)/dmt_min(n))**(1.0_r8/sz_nbr) - sz_min(1) = dmt_min(n) - do m = 2, sz_nbr ! Loop starts at 2 - sz_min(m) = sz_min(m-1) * series_ratio - end do - - ! Derived grid values - do m = 1, sz_nbr-1 ! Loop ends at sz_nbr-1 - sz_max(m) = sz_min(m+1) ! [m] - end do - sz_max(sz_nbr) = dmt_max(n) ! [m] - - ! Final derived grid values - do m = 1, sz_nbr - sz_ctr(m) = 0.5_r8 * (sz_min(m)+sz_max(m)) - sz_dlt(m) = sz_max(m)-sz_min(m) - end do - lngsdsqrttwopi_rcp = 1.0_r8 / (ln_gsd*sqrt(2.0_r8*pi)) - dmt_vwr(n) = 0.0_r8 ! [m] Mass wgted diameter resolved - vlm_rsl(n) = 0.0_r8 ! [m3 m-3] Volume concentration resolved - do m = 1, sz_nbr - ! Evaluate lognormal distribution for these sizes (call lgn_evl) - tmp = log(sz_ctr(m)/dmt_nma) / ln_gsd - lgn_dst = lngsdsqrttwopi_rcp * exp(-0.5_r8*tmp*tmp) / sz_ctr(m) - ! Integrate moments of size distribution - dmt_vwr(n) = dmt_vwr(n) + sz_ctr(m) * & - pi / 6.0_r8 * (sz_ctr(m)**3.0_r8) * & ![m3] Volume - lgn_dst * sz_dlt(m) ![# m-3] Number concentrn - vlm_rsl(n) = vlm_rsl(n) + & - pi / 6.0_r8 * (sz_ctr(m)**3.0_r8) * & ![m3] Volume - lgn_dst * sz_dlt(m) ![# m-3] Number concentrn - end do - dmt_vwr(n) = dmt_vwr(n) / vlm_rsl(n) ![m] Mass weighted diameter resolved - end do - - ! sets stk_crc ... - - ! calculate correction to Stokes' settling velocity (subroutine stk_crc_get) - eps_max = 1.0e-4_r8 - dns_mdp = 100000._r8 / (295.0_r8*rair) ![kg m-3] const prs_mdp & tpt_vrt - ! Size-independent thermokinetic properties - vsc_dyn_atm = 1.72e-5_r8 * ((295.0_r8/273.0_r8)**1.5_r8) * 393.0_r8 / & - (295.0_r8+120.0_r8) ![kg m-1 s-1] RoY94 p.102 tpt_mdp=295.0 - mfp_atm = 2.0_r8 * vsc_dyn_atm / & !SeP97 p. 455 constant prs_mdp, tpt_mdp - (100000._r8*sqrt(8.0_r8/(pi*rair*295.0_r8))) - vsc_knm_atm = vsc_dyn_atm / dns_mdp ![m2 s-1] Kinematic viscosity of air - - do m = 1, nbin - slp_crc(m) = 1.0_r8 + 2.0_r8 * mfp_atm * & - (1.257_r8+0.4_r8*exp(-1.1_r8*dmt_vwr(m)/(2.0_r8*mfp_atm))) / & - dmt_vwr(m) ! [frc] Slip correction factor SeP97 p.464 - vlc_stk(m) = (1.0_r8/18.0_r8) * dmt_vwr(m) * dmt_vwr(m) * dust_density * & - gravit * slp_crc(m) / vsc_dyn_atm ! [m s-1] SeP97 p.466 - end do - - ! For Reynolds number flows Re < 0.1 Stokes' velocity is valid for - ! vlc_grv SeP97 p. 466 (8.42). For larger Re, inertial effects become - ! important and empirical drag coefficients must be employed - ! Implicit equation for Re, Cd, and Vt is SeP97 p. 467 (8.44) - ! Using Stokes' velocity rather than iterative solution with empirical - ! drag coefficient causes 60% errors for D = 200 um SeP97 p. 468 - - ! Iterative solution for drag coefficient, Reynolds number, and terminal veloc - do m = 1, nbin - - ! Initialize accuracy and counter - eps_crr = eps_max + 1.0_r8 ![frc] Current relative accuracy - itr_idx = 0 ![idx] Counting index - - ! Initial guess for vlc_grv is exact for Re < 0.1 - vlc_grv(m) = vlc_stk(m) ![m s-1] - eps_loop: do while(eps_crr > eps_max) - - ! Save terminal velocity for convergence test - vlc_grv_old = vlc_grv(m) ![m s-1] - ryn_nbr_grv(m) = vlc_grv(m) * dmt_vwr(m) / vsc_knm_atm !SeP97 p.460 - - ! Update drag coefficient based on new Reynolds number - if (ryn_nbr_grv(m) < 0.1_r8) then - cff_drg_grv(m) = 24.0_r8 / ryn_nbr_grv(m) !Stokes' law Sep97 p.463 (8.32) - else if (ryn_nbr_grv(m) < 2.0_r8) then - cff_drg_grv(m) = (24.0_r8/ryn_nbr_grv(m)) * & - (1.0_r8 + 3.0_r8*ryn_nbr_grv(m)/16.0_r8 + & - 9.0_r8*ryn_nbr_grv(m)*ryn_nbr_grv(m)* & - log(2.0_r8*ryn_nbr_grv(m))/160.0_r8) !Sep97 p.463 (8.32) - else if (ryn_nbr_grv(m) < 500.0_r8) then - cff_drg_grv(m) = (24.0_r8/ryn_nbr_grv(m)) * & - (1.0_r8 + 0.15_r8*ryn_nbr_grv(m)**0.687_r8) !Sep97 p.463 (8.32) - else if (ryn_nbr_grv(m) < 2.0e5_r8) then - cff_drg_grv(m) = 0.44_r8 !Sep97 p.463 (8.32) - else - write(errmsg,'(a,es9.2)') & - 'Dustini error: Reynolds number too large in stk_crc_get(): ryn_nbr_grv(m) = ', ryn_nbr_grv(m) - errflg = 1 - return - endif - - ! Update terminal velocity based on new Reynolds number and drag coeff - ! [m s-1] Terminal veloc SeP97 p.467 (8.44) - vlc_grv(m) = sqrt(4.0_r8 * gravit * dmt_vwr(m) * slp_crc(m) * dust_density / & - (3.0_r8*cff_drg_grv(m)*dns_mdp)) - eps_crr = abs((vlc_grv(m)-vlc_grv_old)/vlc_grv(m)) !Relative convergence - if (itr_idx == 12) then - ! Numerical pingpong may occur when Re = 0.1, 2.0, or 500.0 - ! due to discontinuities in derivative of drag coefficient - vlc_grv(m) = 0.5_r8 * (vlc_grv(m)+vlc_grv_old) ! [m s-1] - endif - if (itr_idx > 20) then - ! Dustini error: terminal velocity not converging in stk_crc_get(); - ! break the loop and accept the current value (was an iulog warning) - exit eps_loop - endif - itr_idx = itr_idx + 1 - end do eps_loop !end while - end do !end loop over size - - ! Compute factors to convert Stokes' settling velocities to - ! actual settling velocities - do m = 1, nbin - stk_crc(m) = vlc_grv(m) / vlc_stk(m) - end do - - end subroutine dust_set_params - -end module dust_common diff --git a/src/chemistry/aerosol/dust_sediment_mod.F90 b/src/chemistry/aerosol/dust_sediment_mod.F90 deleted file mode 100644 index 3963035b61..0000000000 --- a/src/chemistry/aerosol/dust_sediment_mod.F90 +++ /dev/null @@ -1,468 +0,0 @@ -module dust_sediment_mod - -!--------------------------------------------------------------------------------- -! Purpose: -! -! Contains routines to compute tendencies from sedimentation of dust -! -! Author: Phil Rasch -! -!--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8=>shr_kind_r8 - - private - public :: dust_sediment_tend - - - real (r8), parameter :: mxsedfac = 0.99_r8 ! maximum sedimentation flux factor - -contains - -!=============================================================================== - subroutine dust_sediment_tend ( & - ncol, dtime, pint, pdel, & - dustmr ,pvdust, dusttend, sfdust, & - pver, gravit, errmsg, errflg ) - -!---------------------------------------------------------------------- -! Apply Particle Gravitational Sedimentation -!---------------------------------------------------------------------- - - implicit none - -! Arguments - integer, intent(in) :: ncol ! number of colums to process - - real(r8), intent(in) :: dtime ! time step - real(r8), intent(in) :: pint (:,:) ! interfaces pressure (Pa) - real(r8), intent(in) :: pdel (:,:) ! pressure diff across layer (Pa) - real(r8), intent(in) :: dustmr(:,:) ! dust (kg/kg) - real(r8), intent(in) :: pvdust (:,:) ! vertical velocity of dust drops (Pa/s) -! -> note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) - - real(r8), intent(out) :: dusttend(:,:) ! dust tend - real(r8), intent(out) :: sfdust (:) ! surface flux of dust (rain, kg/m/s) - - integer, intent(in) :: pver ! number of vertical levels - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! Local variables - real(r8) :: fxdust(ncol,pver+1) ! fluxes at the interfaces, dust (positive = down) - - integer :: i,k -!---------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - -! initialize variables - fxdust (:ncol,:) = 0._r8 ! flux at interfaces (dust) - dusttend(:ncol,:) = 0._r8 ! tend (dust) - sfdust(:ncol) = 0._r8 ! sedimentation flux out bot of column (dust) - -! fluxes at interior points - call getflx(ncol, pint, dustmr, pvdust, dtime, fxdust, pver, errmsg, errflg) - if (errflg /= 0) return - -! calculate fluxes at boundaries - do i = 1,ncol - fxdust(i,1) = 0 -! surface flux by upstream scheme - fxdust(i,pver+1) = dustmr(i,pver) * pvdust(i,pver+1) * dtime - end do - -! filter out any negative fluxes from the getflx routine - do k = 2,pver - fxdust(:ncol,k) = max(0._r8, fxdust(:ncol,k)) - end do - -! Limit the flux out of the bottom of each cell to the water content in each phase. -! Apply mxsedfac to prevent generating very small negative cloud water/ice -! NOTE, REMOVED CLOUD FACTOR FROM AVAILABLE WATER. ALL CLOUD WATER IS IN CLOUDS. -! ***Should we include the flux in the top, to allow for thin surface layers? -! ***Requires simple treatment of cloud overlap, already included below. - do k = 1,pver - do i = 1,ncol - fxdust(i,k+1) = min( fxdust(i,k+1), mxsedfac * dustmr(i,k) * pdel(i,k) ) -!!$ fxdust(i,k+1) = min( fxdust(i,k+1), dustmr(i,k) * pdel(i,k) + fxdust(i,k)) - end do - end do - -! Now calculate the tendencies - do k = 1,pver - do i = 1,ncol -! net flux into cloud changes cloud dust/ice (all flux is out of cloud) - dusttend(i,k) = (fxdust(i,k) - fxdust(i,k+1)) / (dtime * pdel(i,k)) - end do - end do - -! convert flux out the bottom to mass units Pa -> kg/m2/s - sfdust(:ncol) = fxdust(:ncol,pver+1) / (dtime*gravit) - - return - end subroutine dust_sediment_tend - -!=============================================================================== - subroutine getflx(ncol, xw, phi, vel, deltat, flux, pver, errmsg, errflg) - -!.....xw1.......xw2.......xw3.......xw4.......xw5.......xw6 -!....psiw1.....psiw2.....psiw3.....psiw4.....psiw5.....psiw6 -!....velw1.....velw2.....velw3.....velw4.....velw5.....velw6 -!.........phi1......phi2.......phi3.....phi4.......phi5....... - - - implicit none - - integer ncol ! number of colums to process - - integer i - integer k - - real (r8) vel(:,:) - real (r8) flux(:,:) - real (r8) xw(:,:) - real (r8) phi(:,:) - real (r8) deltat - - integer, intent(in) :: pver ! number of vertical levels - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real (r8) psi(ncol,pver+1) - real (r8) fdot(ncol,pver+1) - real (r8) xx(ncol) - real (r8) fxdot(ncol) - real (r8) fxdd(ncol) - - real (r8) psistar(ncol) - - real (r8) xxk(ncol,pver) - - errmsg = '' - errflg = 0 - - do i = 1,ncol -! integral of phi - psi(i,1) = 0._r8 -! fluxes at boundaries - flux(i,1) = 0 - flux(i,pver+1) = 0._r8 - end do - -! integral function - do k = 2,pver+1 - do i = 1,ncol - psi(i,k) = phi(i,k-1)*(xw(i,k)-xw(i,k-1)) + psi(i,k-1) - end do - end do - - -! calculate the derivatives for the interpolating polynomial - call cfdotmc_pro (ncol, xw, psi, fdot, pver) - -! NEW WAY -! calculate fluxes at interior pts - do k = 2,pver - do i = 1,ncol - xxk(i,k) = xw(i,k)-vel(i,k)*deltat - end do - end do - do k = 2,pver - call cfint2(ncol, xw, psi, fdot, xxk(:,k), fxdot, fxdd, psistar, pver, errmsg, errflg) - if (errflg /= 0) return - do i = 1,ncol - flux(i,k) = (psi(i,k)-psistar(i)) - end do - end do - - - return - end subroutine getflx - - - -!############################################################################## - - subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar, pver, errmsg, errflg) - - - implicit none - -! input - integer ncol ! number of colums to process - - real (r8) x(:,:) - real (r8) f(:,:) - real (r8) fdot(:,:) - real (r8) xin(:) - - integer, intent(in) :: pver ! number of vertical levels - -! output - real (r8) fxdot(:) - real (r8) fxdd(:) - real (r8) psistar(:) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer i - integer k - integer intz(ncol) - real (r8) dx - real (r8) s - real (r8) c2 - real (r8) c3 - real (r8) xx - real (r8) xinf - real (r8) psi1, psi2, psi3, psim - real (r8) cfint - real (r8) cfnew - real (r8) xins(ncol) - -! the minmod function - real (r8) a, b, c - real (r8) minmod - real (r8) medan - minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) - medan(a,b,c) = a + minmod(b-a,c-a) - - errmsg = '' - errflg = 0 - - do i = 1,ncol - xins(i) = medan(x(i,1), xin(i), x(i,pver+1)) - intz(i) = 0 - end do - -! first find the interval - do k = 1,pver - do i = 1,ncol - if ((xins(i)-x(i,k))*(x(i,k+1)-xins(i)).ge.0._r8) then - intz(i) = k - endif - end do - end do - - do i = 1,ncol - if (intz(i).eq.0) then - write(errmsg,*) 'DUST_SEDIMENT_MOD:cfint2 -- interval was not found for col i ', i - errflg = 1 - return - endif - end do - -! now interpolate - do i = 1,ncol - k = intz(i) - dx = (x(i,k+1)-x(i,k)) - s = (f(i,k+1)-f(i,k))/dx - c2 = (3*s-2*fdot(i,k)-fdot(i,k+1))/dx - c3 = (fdot(i,k)+fdot(i,k+1)-2*s)/dx**2 - xx = (xins(i)-x(i,k)) - fxdot(i) = (3*c3*xx + 2*c2)*xx + fdot(i,k) - fxdd(i) = 6*c3*xx + 2*c2 - cfint = ((c3*xx + c2)*xx + fdot(i,k))*xx + f(i,k) - -! limit the interpolant - psi1 = f(i,k)+(f(i,k+1)-f(i,k))*xx/dx - if (k.eq.1) then - psi2 = f(i,1) - else - psi2 = f(i,k) + (f(i,k)-f(i,k-1))*xx/(x(i,k)-x(i,k-1)) - endif - if (k+1.eq.pver+1) then - psi3 = f(i,pver+1) - else - psi3 = f(i,k+1) - (f(i,k+2)-f(i,k+1))*(dx-xx)/(x(i,k+2)-x(i,k+1)) - endif - psim = medan(psi1, psi2, psi3) - cfnew = medan(cfint, psi1, psim) - if (abs(cfnew-cfint)/(abs(cfnew)+abs(cfint)+1.e-36_r8) .gt..03_r8) then -! CHANGE THIS BACK LATER!!! -! $ .gt..1) then - - -! UNCOMMENT THIS LATER!!! -! write(iulog,*) ' cfint2 limiting important ', cfint, cfnew - - - endif - psistar(i) = cfnew - end do - - return - end subroutine cfint2 - - - -!############################################################################## - - subroutine cfdotmc_pro (ncol, x, f, fdot, pver) - -! prototype version; eventually replace with final SPITFIRE scheme - -! calculate the derivative for the interpolating polynomial -! multi column version - - - implicit none - -! input - integer ncol ! number of colums to process - - real (r8) x(:,:) - real (r8) f(:,:) - integer, intent(in) :: pver ! number of vertical levels -! output - real (r8) fdot(:,:) ! derivative at nodes - -! assumed variable distribution -! x1.......x2.......x3.......x4.......x5.......x6 1,pverp points -! f1.......f2.......f3.......f4.......f5.......f6 1,pverp points -! ...sh1.......sh2......sh3......sh4......sh5.... 1,pver points -! .........d2.......d3.......d4.......d5......... 2,pver points -! .........s2.......s3.......s4.......s5......... 2,pver points -! .............dh2......dh3......dh4............. 2,pver-1 points -! .............eh2......eh3......eh4............. 2,pver-1 points -! ..................e3.......e4.................. 3,pver-1 points -! .................ppl3......ppl4................ 3,pver-1 points -! .................ppr3......ppr4................ 3,pver-1 points -! .................t3........t4.................. 3,pver-1 points -! ................fdot3.....fdot4................ 3,pver-1 points - - -! work variables - - - integer i - integer k - - real (r8) a ! work var - real (r8) b ! work var - real (r8) c ! work var - real (r8) s(ncol,pver+1) ! first divided differences at nodes - real (r8) sh(ncol,pver+1) ! first divided differences between nodes - real (r8) d(ncol,pver+1) ! second divided differences at nodes - real (r8) dh(ncol,pver+1) ! second divided differences between nodes - real (r8) e(ncol,pver+1) ! third divided differences at nodes - real (r8) eh(ncol,pver+1) ! third divided differences between nodes - real (r8) pp ! p prime - real (r8) ppl(ncol,pver+1) ! p prime on left - real (r8) ppr(ncol,pver+1) ! p prime on right - real (r8) qpl - real (r8) qpr - real (r8) ttt - real (r8) t - real (r8) tmin - real (r8) tmax - real (r8) delxh(ncol,pver+1) - - -! the minmod function - real (r8) minmod - real (r8) medan - minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) - medan(a,b,c) = a + minmod(b-a,c-a) - - do k = 1,pver - - -! first divided differences between nodes - do i = 1, ncol - delxh(i,k) = (x(i,k+1)-x(i,k)) - sh(i,k) = (f(i,k+1)-f(i,k))/delxh(i,k) - end do - -! first and second divided differences at nodes - if (k.ge.2) then - do i = 1,ncol - d(i,k) = (sh(i,k)-sh(i,k-1))/(x(i,k+1)-x(i,k-1)) - s(i,k) = minmod(sh(i,k),sh(i,k-1)) - end do - endif - end do - -! second and third divided diffs between nodes - do k = 2,pver-1 - do i = 1, ncol - eh(i,k) = (d(i,k+1)-d(i,k))/(x(i,k+2)-x(i,k-1)) - dh(i,k) = minmod(d(i,k),d(i,k+1)) - end do - end do - -! treat the boundaries - do i = 1,ncol - e(i,2) = eh(i,2) - e(i,pver) = eh(i,pver-1) -! outside level - fdot(i,1) = sh(i,1) - d(i,2)*delxh(i,1) & - - eh(i,2)*delxh(i,1)*(x(i,1)-x(i,3)) - fdot(i,1) = minmod(fdot(i,1),3*sh(i,1)) - fdot(i,pver+1) = sh(i,pver) + d(i,pver)*delxh(i,pver) & - + eh(i,pver-1)*delxh(i,pver)*(x(i,pver+1)-x(i,pver-1)) - fdot(i,pver+1) = minmod(fdot(i,pver+1),3*sh(i,pver)) -! one in from boundary - fdot(i,2) = sh(i,1) + d(i,2)*delxh(i,1) - eh(i,2)*delxh(i,1)*delxh(i,2) - fdot(i,2) = minmod(fdot(i,2),3*s(i,2)) - fdot(i,pver) = sh(i,pver) - d(i,pver)*delxh(i,pver) & - - eh(i,pver-1)*delxh(i,pver)*delxh(i,pver-1) - fdot(i,pver) = minmod(fdot(i,pver),3*s(i,pver)) - end do - - - do k = 3,pver-1 - do i = 1,ncol - e(i,k) = minmod(eh(i,k),eh(i,k-1)) - end do - end do - - - - do k = 3,pver-1 - - do i = 1,ncol - -! p prime at k-0.5 - ppl(i,k)=sh(i,k-1) + dh(i,k-1)*delxh(i,k-1) -! p prime at k+0.5 - ppr(i,k)=sh(i,k) - dh(i,k) *delxh(i,k) - - t = minmod(ppl(i,k),ppr(i,k)) - -! derivate from parabola thru f(i,k-1), f(i,k), and f(i,k+1) - pp = sh(i,k-1) + d(i,k)*delxh(i,k-1) - -! quartic estimate of fdot - fdot(i,k) = pp & - - delxh(i,k-1)*delxh(i,k) & - *( eh(i,k-1)*(x(i,k+2)-x(i,k )) & - + eh(i,k )*(x(i,k )-x(i,k-2)) & - )/(x(i,k+2)-x(i,k-2)) - -! now limit it - qpl = sh(i,k-1) & - + delxh(i,k-1)*minmod(d(i,k-1)+e(i,k-1)*(x(i,k)-x(i,k-2)), & - d(i,k) -e(i,k)*delxh(i,k)) - qpr = sh(i,k) & - + delxh(i,k )*minmod(d(i,k) +e(i,k)*delxh(i,k-1), & - d(i,k+1)+e(i,k+1)*(x(i,k)-x(i,k+2))) - - fdot(i,k) = medan(fdot(i,k), qpl, qpr) - - ttt = minmod(qpl, qpr) - tmin = min(0._r8,3*s(i,k),1.5_r8*t,ttt) - tmax = max(0._r8,3*s(i,k),1.5_r8*t,ttt) - - fdot(i,k) = fdot(i,k) + minmod(tmin-fdot(i,k), tmax-fdot(i,k)) - - end do - - end do - - return - end subroutine cfdotmc_pro -end module dust_sediment_mod diff --git a/src/chemistry/aerosol/mo_setsox.F90 b/src/chemistry/aerosol/mo_setsox.F90 deleted file mode 100644 index dc86fa76e3..0000000000 --- a/src/chemistry/aerosol/mo_setsox.F90 +++ /dev/null @@ -1,876 +0,0 @@ -module mo_setsox - - ! Portable (CCPP-ready) aqueous sulfur chemistry (setsox). - ! Species indices / invariant flags, the Henry's Law table indices and the - ! host physical constants are provided by the host through setsox_init / - ! setsox_sub arguments (CAM wrapper: mo_setsox_cam). The polymorphic - ! aerosol_state abstraction is deliberately host-portable. - - use shr_kind_mod, only : r8 => shr_kind_r8 - use aerosol_state_mod, only: aerosol_state - - implicit none - - private - public :: setsox_init, setsox_sub - - logical :: inv_o3 - integer :: id_msa - - integer :: id_so2, id_nh3, id_hno3, id_h2o2, id_o3, id_ho2 - integer :: id_so4, id_h2so4 - - logical :: inv_so2, inv_nh3, inv_hno3, inv_h2o2, inv_ho2 - - logical :: cloud_borne = .false. - - ! Indices for species in the shared array of Henry's Law constant parameters - integer :: heff_id_hno3, heff_id_so2, heff_id_nh3, heff_id_co2, heff_id_h2o2, heff_id_o3 - -contains - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine setsox_init( cloud_borne_in, & - id_so2_in, inv_so2_in, & - id_nh3_in, inv_nh3_in, & - id_hno3_in, inv_hno3_in, & - id_h2o2_in, inv_h2o2_in, & - id_ho2_in, inv_ho2_in, & - id_o3_in, inv_o3_in, & - id_h2so4_in, id_so4_in, id_msa_in, & - heff_id_hno3_in, heff_id_so2_in, heff_id_nh3_in, & - heff_id_co2_in, heff_id_h2o2_in, heff_id_o3_in ) - !----------------------------------------------------------------------- - ! ... initialize the hetero sox routine - ! - ! Store the species indices / invariant flags and the Henry's Law - ! constant table indices resolved by the host (CAM: sox_inti in - ! mo_setsox_cam). An id <= 0 marks the species as absent. - !----------------------------------------------------------------------- - - logical, intent(in) :: cloud_borne_in ! aqueous sulfate goes to cloud-borne aerosol - integer, intent(in) :: id_so2_in ! index in invariants (if inv flag) or solution array - logical, intent(in) :: inv_so2_in ! species is an invariant - integer, intent(in) :: id_nh3_in - logical, intent(in) :: inv_nh3_in - integer, intent(in) :: id_hno3_in - logical, intent(in) :: inv_hno3_in - integer, intent(in) :: id_h2o2_in - logical, intent(in) :: inv_h2o2_in - integer, intent(in) :: id_ho2_in - logical, intent(in) :: inv_ho2_in - integer, intent(in) :: id_o3_in - logical, intent(in) :: inv_o3_in - integer, intent(in) :: id_h2so4_in ! used when cloud_borne_in - integer, intent(in) :: id_so4_in ! used when .not. cloud_borne_in - integer, intent(in) :: id_msa_in - ! indices into the shared array of Henry's Law constant parameters (dheff) - integer, intent(in) :: heff_id_hno3_in, heff_id_so2_in, heff_id_nh3_in - integer, intent(in) :: heff_id_co2_in, heff_id_h2o2_in, heff_id_o3_in - - cloud_borne = cloud_borne_in - - id_so2 = id_so2_in - inv_so2 = inv_so2_in - id_nh3 = id_nh3_in - inv_nh3 = inv_nh3_in - id_hno3 = id_hno3_in - inv_hno3 = inv_hno3_in - id_h2o2 = id_h2o2_in - inv_h2o2 = inv_h2o2_in - id_ho2 = id_ho2_in - inv_ho2 = inv_ho2_in - id_o3 = id_o3_in - inv_o3 = inv_o3_in - id_h2so4 = id_h2so4_in - id_so4 = id_so4_in - id_msa = id_msa_in - - heff_id_hno3 = heff_id_hno3_in - heff_id_so2 = heff_id_so2_in - heff_id_nh3 = heff_id_nh3_in - heff_id_co2 = heff_id_co2_in - heff_id_h2o2 = heff_id_h2o2_in - heff_id_o3 = heff_id_o3_in - - end subroutine setsox_init - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine setsox_sub( aero_state, & - ncol, & - pver, & - dtime, & - press, & - pdel, & - tfld, & - mbar, & - lwc, & - cldfrc, & - cldnum, & - invariants, & - co2_mass_mixing_ratio, & - dheff, & - AVOGADRO_KMOL, & - BOLTZMANN, & - GAS_CONSTANT_KMOL, & - MOLECULAR_WEIGHT_CO2_G_MOL, & - MOLECULAR_WEIGHT_DRY_AIR_G_MOL, & - gravit, & - qcw, & - qin, & - xphlwc, & - aqso4, & - aqh2so4,& - aqso4_h2o2, & - aqso4_o3, & - errmsg, & - errflg, & - yph_in, & - aqso4_h2o2_3d, & - aqso4_o3_3d & - ) - - !----------------------------------------------------------------------- - ! ... Compute heterogeneous reactions of SOX - ! - ! (0) using initial PH to calculate PH - ! (a) HENRYs law constants - ! (b) PARTIONING - ! (c) PH values - ! - ! (1) using new PH to repeat - ! (a) HENRYs law constants - ! (b) PARTIONING - ! (c) REACTION rates - ! (d) PREDICTION - ! - ! NOTE: This routine assumes an Ideal Gas. - !----------------------------------------------------------------------- - ! - use sox_cldaero_mod, only : sox_cldaero_update, sox_cldaero_create_obj, sox_cldaero_destroy_obj - use cldaero_mod, only : cldaero_conc_t - - ! - !----------------------------------------------------------------------- - ! ... Dummy arguments - !----------------------------------------------------------------------- - class(aerosol_state), intent(in) :: aero_state - integer, intent(in) :: ncol ! num of columns in chunk - integer, intent(in) :: pver ! num of vertical levels - real(r8), intent(in) :: dtime ! time step (sec) - real(r8), intent(in) :: press(:,:) ! midpoint pressure ( Pa ) - real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: tfld(:,:) ! temperature - real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) - real(r8), target, intent(in) :: lwc(:,:) ! cloud liquid water content (kg/kg) - real(r8), target, intent(in) :: cldfrc(:,:) ! cloud fraction - real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) - real(r8), intent(in) :: invariants(:,:,:) - real(r8), intent(in) :: co2_mass_mixing_ratio(:,:) ! kg kg-1 (host CO2; CAM: rad_cnst_get_gas) - real(r8), intent(in) :: dheff(:,:) ! Henry's Law constant parameters table - ! host physical constants (passed in for bit-for-bit consistency with the host) - real(r8), intent(in) :: AVOGADRO_KMOL ! Avogadro's number (molecules/kmol) - real(r8), intent(in) :: BOLTZMANN ! Boltzmann's constant (J/K/molecule) - real(r8), intent(in) :: GAS_CONSTANT_KMOL ! universal gas constant (J/K/kmol) - real(r8), intent(in) :: MOLECULAR_WEIGHT_CO2_G_MOL ! molecular weight of CO2 (g/mol) - real(r8), intent(in) :: MOLECULAR_WEIGHT_DRY_AIR_G_MOL ! molecular weight of dry air (g/mol) - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - real(r8), target, intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) - real(r8), intent(inout) :: qin(:,:,:) ! transported species ( vmr ) - real(r8), intent(out) :: xphlwc(:,:) ! pH value multiplied by lwc - - real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - real(r8), intent(in), optional :: yph_in ! ph value - real(r8), intent(out), optional :: aqso4_h2o2_3d(:, :) ! 3D SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out), optional :: aqso4_o3_3d(:, :) ! 3D SO4 aqueous phase chemistry due to O3 (kg/m2) - - !----------------------------------------------------------------------- - ! ... Local variables - ! - ! xhno3 ... in mixing ratio - !----------------------------------------------------------------------- - integer, parameter :: itermax = 20 - real(r8), parameter :: ph0 = 5.0_r8 ! INITIAL PH VALUES - real(r8), parameter :: PASCAL_TO_ATM = 1.0_r8 / 101325.0_r8 ! atm Pa-1 - real(r8), parameter :: M3_TO_L = 1.0e3_r8 ! L m-3 - real(r8), parameter :: M3_TO_CM3 = 1.0e6_r8 ! cm3 m-3 - real(r8), parameter :: G_TO_KG = 1.0e-3_r8 ! kg g-1 - real(r8), parameter :: KMOL_TO_MOL = 1.0e3_r8 ! mol kmol-1 - real(r8), parameter :: SMALL_NUMBER = 1.0e-30_r8 - ! derived from host physical constants (assigned below; formerly parameters) - real(r8) :: AVOGADRO ! molecule mol-1 - real(r8) :: const0 - real(r8) :: MOLECULAR_WEIGHT_DRY_AIR ! kg mol-1 - real(r8) :: MOLECULAR_WEIGHT_CO2 ! kg mol-1 - real(r8), parameter :: xa0 = 11._r8 - real(r8), parameter :: xb0 = -.1_r8 - real(r8), parameter :: xa1 = 1.053_r8 - real(r8), parameter :: xb1 = -4.368_r8 - real(r8), parameter :: xa2 = 1.016_r8 - real(r8), parameter :: xb2 = -2.54_r8 - real(r8), parameter :: xa3 = .816e-32_r8 - real(r8), parameter :: xb3 = .259_r8 - - real(r8), parameter :: kh0 = 690.0_r8 ! HO2(g) -> Ho2(a) Reference: JPL 19-5 - real(r8), parameter :: kh1 = 1.6e-5_r8 ! HO2(a) -> H+ + O2- Reference: JPL 19-5 - real(r8), parameter :: kh2 = 8.3e5_r8 ! HO2(a) + ho2(a) -> h2o2(a) + o2 Reference: JPL; Bielski et al. 1985 - real(r8), parameter :: kh3 = 9.7e7_r8 ! HO2(a) + o2- -> h2o2(a) + o2 Reference: JPL; Bielski et al. 1985 - real(r8) :: Ra ! universal constant (atm)/(M-K) (assigned below; formerly a parameter) - real(r8), parameter :: small_value = 1.e-20_r8 - - ! - real(r8) :: xdelso4hp(ncol,pver) - real(r8) :: xhnm(ncol,pver) ! air number density (molecules cm-3) - - integer :: k, i, iter - real(r8) :: wrk, delta - real(r8) :: xph0, xk, xe, x2 - real(r8) :: tz, xl, px, patm - real(r8) :: Eso2, Eso4, Ehno3, Eco2, Eh2o, Enh3 - real(r8) :: so2g, h2o2g, o3g - real(r8) :: rah2o2, rao3, pso4, ccc - real(r8) :: f_hso3 ! fraction of aqueous S(IV) that's HSO3- - real(r8) :: f_so3 ! fraction of aqueous S(IV) that's SO3= - - real(r8) :: hno3g(ncol,pver), nh3g(ncol,pver) - ! - !----------------------------------------------------------------------- - ! for Ho2(g) -> H2o2(a) formation - ! schwartz JGR, 1984, 11589 - !----------------------------------------------------------------------- - real(r8) :: kh4 ! kh2+kh3 - real(r8) :: xam ! air density /cm3 - real(r8) :: ho2s ! ho2s = ho2(a)+o2- - real(r8) :: r1h2o2 ! prod(h2o2) by ho2 in mole/L(w)/s - real(r8) :: r2h2o2 ! prod(h2o2) by ho2 in mix/s - - real(r8), dimension(ncol,pver) :: & - xhno3, xh2o2, xso2, xso4, xno3, xco2, & - xnh3, xnh4, xo3, & - cfact, & - xph, xho2, & - xh2so4, xmsa, xso4_init, & - hehno3, & ! henry law const for hno3 - heh2o2, & ! henry law const for h2o2 - heso2, & ! henry law const for so2 - henh3, & ! henry law const for nh3 - heo3 !!, & ! henry law const for o3 - - real(r8), dimension(ncol) :: work1 - logical :: converged - - real(r8), pointer :: xso4c(:,:) - real(r8), pointer :: xnh4c(:,:) - real(r8), pointer :: xno3c(:,:) - type(cldaero_conc_t), pointer :: cldconc - - real(r8) :: fact1_hno3, fact2_hno3, fact3_hno3 - real(r8) :: fact1_so2, fact2_so2, fact3_so2, fact4_so2 - real(r8) :: fact1_nh3, fact2_nh3, fact3_nh3 - real(r8) :: fact1_co2, fact2_co2, fact3_co2, fact4_co2 - real(r8) :: tmp_hp, tmp_hso3, tmp_hco3, tmp_nh4, tmp_no3 - real(r8) :: tmp_oh, tmp_so3, tmp_so4 - real(r8) :: tmp_neg, tmp_pos - real(r8) :: yph, yph_lo, yph_hi - real(r8) :: ynetpos, ynetpos_lo, ynetpos_hi - - errmsg = '' - errflg = 0 - - ! derived host-constant values (same expressions as the original - ! parameter declarations, computed from the host-passed constants) - AVOGADRO = AVOGADRO_KMOL / KMOL_TO_MOL ! molecule mol-1 - const0 = 1.e3_r8/AVOGADRO - MOLECULAR_WEIGHT_CO2 = MOLECULAR_WEIGHT_CO2_G_MOL * G_TO_KG ! kg mol-1 - Ra = GAS_CONSTANT_KMOL / KMOL_TO_MOL * M3_TO_L * PASCAL_TO_ATM ! universal constant (atm)/(M-K) - - MOLECULAR_WEIGHT_DRY_AIR = MOLECULAR_WEIGHT_DRY_AIR_G_MOL * G_TO_KG ! kg mol-1 - - !----------------------------------------------------------------- - ! ... NOTE: The press array is in pascals and must be - ! mutiplied by 10 to yield dynes/cm**2. - !----------------------------------------------------------------- - !================================================================== - ! ... First set the PH - !================================================================== - ! ... Initial values - ! The values of so2, so4 are after (1) SLT, and CHEM - !----------------------------------------------------------------- - xhnm(:ncol,:) = press(:ncol,:) / (tfld(:ncol,:) * M3_TO_CM3 * BOLTZMANN) ! air number density (molecules cm-3) - - xph0 = 10._r8**(-ph0) ! initial PH value - - do k = 1,pver - cfact(:,k) = xhnm(:,k) & ! /cm3(a) - * 1.e6_r8 & ! /m3(a) - * BOLTZMANN/287._r8 & ! Kg(a)/m3(a) - * 1.e-3_r8 ! Kg(a)/L(a) - end do - - cldconc => sox_cldaero_create_obj( cldfrc,qcw,lwc, cfact, ncol, pver ) - xso4c => cldconc%so4c - xnh4c => cldconc%nh4c - xno3c => cldconc%no3c - - xso4(:,:) = 0._r8 - xno3(:,:) = 0._r8 - xnh4(:,:) = 0._r8 - xso4_init = 0._r8 - - do k = 1,pver - xph(:,k) = xph0 ! initial PH value - - xco2(:ncol,k) = co2_mass_mixing_ratio(:ncol,k) & - * (MOLECULAR_WEIGHT_DRY_AIR / MOLECULAR_WEIGHT_CO2) ! mixing ratio - - if ( inv_so2 ) then - xso2 (:,k) = invariants(:,k,id_so2)/xhnm(:,k) ! mixing ratio - else - xso2 (:,k) = qin(:,k,id_so2) ! mixing ratio - endif - - if (id_hno3 > 0) then - xhno3(:,k) = qin(:,k,id_hno3) - else - xhno3(:,k) = 0.0_r8 - endif - - if ( inv_h2o2 ) then - xh2o2 (:,k) = invariants(:,k,id_h2o2)/xhnm(:,k) ! mixing ratio - else - xh2o2 (:,k) = qin(:,k,id_h2o2) ! mixing ratio - endif - - if (id_nh3 > 0) then - xnh3 (:,k) = qin(:,k,id_nh3) - else - xnh3 (:,k) = 0.0_r8 - endif - - if ( inv_o3 ) then - xo3 (:,k) = invariants(:,k,id_o3)/xhnm(:,k) ! mixing ratio - else - xo3 (:,k) = qin(:,k,id_o3) ! mixing ratio - endif - if ( inv_ho2 ) then - xho2 (:,k) = invariants(:,k,id_ho2)/xhnm(:,k)! mixing ratio - else - xho2 (:,k) = qin(:,k,id_ho2) ! mixing ratio - endif - - if (cloud_borne) then - xh2so4(:,k) = qin(:,k,id_h2so4) - else - xso4 (:,k) = qin(:,k,id_so4) ! mixing ratio - endif - if (id_msa > 0) xmsa (:,k) = qin(:,k,id_msa) - - end do - - !----------------------------------------------------------------- - ! ... Temperature dependent Henry constants - !----------------------------------------------------------------- - ver_loop0: do k = 1,pver !! pver loop for STEP 0 - col_loop0: do i = 1,ncol - - if (cloud_borne .and. cldfrc(i,k)>0._r8) then - xso4(i,k) = xso4c(i,k) / cldfrc(i,k) - xnh4(i,k) = xnh4c(i,k) / cldfrc(i,k) - xno3(i,k) = xno3c(i,k) / cldfrc(i,k) - endif - xl = cldconc%xlwc(i,k) - - if( xl >= 1.e-8_r8 ) then - work1(i) = 1._r8 / tfld(i,k) - 1._r8 / 298._r8 - - !----------------------------------------------------------------- - ! 21-mar-2011 changes by rce - ! ph calculation now uses bisection method to solve the electro-neutrality equation - ! 3-mode aerosols (where so4 is assumed to be nh4hso4) - ! old code set xnh4c = so4c - ! new code sets xnh4c = 0, then uses a -1 charge (instead of -2) - ! for so4 when solving the electro-neutrality equation - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! calculations done before iterating - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - tz = tfld(i,k) - patm = press(i,k) * PASCAL_TO_ATM ! atm - xam = press(i,k)/(BOLTZMANN*tz) ! air density /M3 - - !----------------------------------------------------------------- - ! ... hno3 - !----------------------------------------------------------------- - ! previous code - ! hehno3(i,k) = xk*(1._r8 + xe/xph(i,k)) - ! px = hehno3(i,k) * Ra * tz * xl - ! hno3g = xhno3(i,k)/(1._r8 + px) - ! Ehno3 = xk*xe*hno3g *patm - ! equivalent new code - ! hehno3 = xk + xk*xe/hplus - ! hno3g = xhno3/(1 + px) - ! = xhno3/(1 + hehno3*ra*tz*xl) - ! = xhno3/(1 + xk*ra*tz*xl*(1 + xe/hplus) - ! ehno3 = hno3g*xk*xe*patm - ! = xk*xe*patm*xhno3/(1 + xk*ra*tz*xl*(1 + xe/hplus) - ! = ( fact1_hno3 )/(1 + fact2_hno3 *(1 + fact3_hno3/hplus) - ! [hno3-] = ehno3/hplus - xk = dheff(1,heff_id_hno3) * exp( dheff(2,heff_id_hno3) * work1(i) ) - xe = dheff(3,heff_id_hno3) * exp( dheff(4,heff_id_hno3) * work1(i) ) - fact1_hno3 = xk*xe*patm*xhno3(i,k) - fact2_hno3 = xk*ra*tz*xl - fact3_hno3 = xe - - !----------------------------------------------------------------- - ! ... so2 - !----------------------------------------------------------------- - ! previous code - ! heso2(i,k) = xk*(1._r8 + wrk*(1._r8 + x2/xph(i,k))) - ! px = heso2(i,k) * Ra * tz * xl - ! so2g = xso2(i,k)/(1._r8+ px) - ! Eso2 = xk*xe*so2g *patm - ! equivalent new code - ! heso2 = xk + xk*xe/hplus * xk*xe*x2/hplus**2 - ! so2g = xso2/(1 + px) - ! = xso2/(1 + heso2*ra*tz*xl) - ! = xso2/(1 + xk*ra*tz*xl*(1 + (xe/hplus)*(1 + x2/hplus)) - ! eso2 = so2g*xk*xe*patm - ! = xk*xe*patm*xso2/(1 + xk*ra*tz*xl*(1 + (xe/hplus)*(1 + x2/hplus)) - ! = ( fact1_so2 )/(1 + fact2_so2 *(1 + (fact3_so2/hplus)*(1 + fact4_so2/hplus) - ! [hso3-] + 2*[so3--] = (eso2/hplus)*(1 + 2*x2/hplus) - xk = dheff(1,heff_id_so2) * exp( dheff(2,heff_id_so2) * work1(i) ) - xe = dheff(3,heff_id_so2) * exp( dheff(4,heff_id_so2) * work1(i) ) - x2 = dheff(5,heff_id_so2) * exp( dheff(6,heff_id_so2) * work1(i) ) - fact1_so2 = xk*xe*patm*xso2(i,k) - fact2_so2 = xk*ra*tz*xl - fact3_so2 = xe - fact4_so2 = x2 - - !----------------------------------------------------------------- - ! ... nh3 - !----------------------------------------------------------------- - ! previous code - ! henh3(i,k) = xk*(1._r8 + xe*xph(i,k)/xkw) - ! px = henh3(i,k) * Ra * tz * xl - ! nh3g = (xnh3(i,k)+xnh4(i,k))/(1._r8+ px) - ! Enh3 = xk*xe*nh3g/xkw *patm - ! equivalent new code - ! henh3 = xk + xk*xe*hplus/xkw - ! nh3g = xnh34/(1 + px) - ! = xnh34/(1 + henh3*ra*tz*xl) - ! = xnh34/(1 + xk*ra*tz*xl*(1 + xe*hplus/xkw) - ! enh3 = nh3g*xk*xe*patm/xkw - ! = ((xk*xe*patm/xkw)*xnh34)/(1 + xk*ra*tz*xl*(1 + xe*hplus/xkw) - ! = ( fact1_nh3 )/(1 + fact2_nh3 *(1 + fact3_nh3*hplus) - ! [nh4+] = enh3*hplus - ! NOTE: Algorithm modified to follow that used in wet deposition. - ! This essentially replaces xkw (1.0e-14) with a temperature - ! dependent value for the water dissociation constant, x2. - xk = dheff(1,heff_id_nh3) * exp( dheff(2,heff_id_nh3) * work1(i) ) - xe = dheff(3,heff_id_nh3) * exp( dheff(4,heff_id_nh3) * work1(i) ) - x2 = dheff(5,heff_id_nh3) * exp( dheff(6,heff_id_nh3) * work1(i) ) - fact1_nh3 = (xk*xe*patm/x2)*(xnh3(i,k)+xnh4(i,k)) - fact2_nh3 = xk*ra*tz*xl - fact3_nh3 = xe/x2 - - !----------------------------------------------------------------- - ! ... h2o effects - ! NOTE: Algorithm modified to follow that used in wet deposition. - ! This essentially replaces xkw (1.0e-14) with a temperature - ! dependent value for the water dissociation constant, x2 - ! (calculated above with NH4 Heff terms). - !----------------------------------------------------------------- - Eh2o = x2 - - !----------------------------------------------------------------- - ! ... co2 effects - ! NOTE: Algorithm modified to follow that used in wet deposition. - ! This now applies the same algorithm for diprotic acids used - ! for SO2. - !----------------------------------------------------------------- - xk = dheff(1,heff_id_co2) * exp( dheff(2,heff_id_co2) * work1(i) ) - xe = dheff(3,heff_id_co2) * exp( dheff(4,heff_id_co2) * work1(i) ) - x2 = dheff(5,heff_id_co2) * exp( dheff(6,heff_id_co2) * work1(i) ) - fact1_co2 = xk*xe*patm*xco2(i,k) - fact2_co2 = xk*ra*tz*xl - fact3_co2 = xe - fact4_co2 = x2 - - !----------------------------------------------------------------- - ! ... so4 effect - !----------------------------------------------------------------- - Eso4 = xso4(i,k)*xhnm(i,k) & ! /cm3(a) - *const0/xl - - - !----------------------------------------------------------------- - ! now use bisection method to solve electro-neutrality equation - ! - ! during the iteration loop, - ! yph_lo = lower ph value that brackets the root (i.e., correct ph) - ! yph_hi = upper ph value that brackets the root (i.e., correct ph) - ! yph = current ph value - ! yposnet_lo and yposnet_hi = net positive ions for - ! yph_lo and yph_hi - !----------------------------------------------------------------- - do iter = 1,itermax - - if (.not. present(yph_in)) then - if (iter == 1) then - ! 1st iteration ph = lower bound value - yph_lo = 2.0_r8 - yph_hi = yph_lo - yph = yph_lo - else if (iter == 2) then - ! 2nd iteration ph = upper bound value - yph_hi = 7.0_r8 - yph = yph_hi - else - ! later iteration ph = mean of the two bracketing values - yph = 0.5_r8*(yph_lo + yph_hi) - end if - else - yph = yph_in - end if - - ! calc current [H+] from ph - xph(i,k) = 10.0_r8**(-yph) - - - !----------------------------------------------------------------- - ! ... hno3 - !----------------------------------------------------------------- - Ehno3 = fact1_hno3/(1.0_r8 + fact2_hno3*(1.0_r8 + fact3_hno3/xph(i,k))) - - !----------------------------------------------------------------- - ! ... so2 - !----------------------------------------------------------------- - Eso2 = fact1_so2/(1.0_r8 + fact2_so2*(1.0_r8 + (fact3_so2/xph(i,k)) & - *(1.0_r8 + fact4_so2/xph(i,k)))) - - !----------------------------------------------------------------- - ! ... nh3 - !----------------------------------------------------------------- - Enh3 = fact1_nh3/(1.0_r8 + fact2_nh3*(1.0_r8 + fact3_nh3*xph(i,k))) - - !----------------------------------------------------------------- - ! ... co2 - !----------------------------------------------------------------- - Eco2 = fact1_co2/(1.0_r8 + fact2_co2*(1.0_r8 + (fact3_co2/xph(i,k)) & - *(1.0_r8 + fact4_co2/xph(i,k)))) - - tmp_nh4 = Enh3 * xph(i,k) - tmp_hso3 = Eso2 / xph(i,k) - tmp_so3 = tmp_hso3 * 2.0_r8*fact4_so2/xph(i,k) - tmp_hco3 = Eco2 / xph(i,k) - tmp_oh = Eh2o / xph(i,k) - tmp_no3 = Ehno3 / xph(i,k) - tmp_so4 = cldconc%so4_fact*Eso4 - tmp_pos = xph(i,k) + tmp_nh4 - tmp_neg = tmp_oh + tmp_hco3 + tmp_no3 + tmp_hso3 + tmp_so3 + tmp_so4 - - ynetpos = tmp_pos - tmp_neg - - - ! yposnet = net positive ions/charge - ! if the correct ph is bracketed by yph_lo and yph_hi (with yph_lo < yph_hi), - ! then you will have yposnet_lo > 0 and yposnet_hi < 0 - converged = .false. - if (iter > 2) then - if (ynetpos == 0.0_r8) then - ! the exact solution was found (very unlikely) - tmp_hp = xph(i,k) - converged = .true. - exit - else if (ynetpos >= 0.0_r8) then - ! net positive ions are >= 0 for both yph and yph_lo - ! so replace yph_lo with yph - yph_lo = yph - ynetpos_lo = ynetpos - else - ! net positive ions are <= 0 for both yph and yph_hi - ! so replace yph_hi with yph - yph_hi = yph - ynetpos_hi = ynetpos - end if - - if (abs(yph_hi - yph_lo) .le. 0.005_r8) then - ! |yph_hi - yph_lo| <= convergence criterion, so set - ! final ph to their midpoint and exit - ! (.005 absolute error in pH gives .01 relative error in H+) - tmp_hp = xph(i,k) - yph = 0.5_r8*(yph_hi + yph_lo) - xph(i,k) = 10.0_r8**(-yph) - converged = .true. - exit - else - ! do another iteration - converged = .false. - end if - - else if (iter == 1) then - if (ynetpos <= 0.0_r8) then - ! the lower and upper bound ph values (2.0 and 7.0) do not bracket - ! the correct ph, so use the lower bound - tmp_hp = xph(i,k) - converged = .true. - exit - end if - ynetpos_lo = ynetpos - - else ! (iter == 2) - if (ynetpos >= 0.0_r8) then - ! the lower and upper bound ph values (2.0 and 7.0) do not bracket - ! the correct ph, so use they upper bound - tmp_hp = xph(i,k) - converged = .true. - exit - end if - ynetpos_hi = ynetpos - end if - - end do ! iter - - if( .not. converged ) then - write(*,*) 'setsox: pH failed to converge @ (',i,',',k,'), % change=', & - 100._r8*delta !!! What should delta be set to ???? - end if - else - xph(i,k) = 1.e-7_r8 - end if - end do col_loop0 - end do ver_loop0 ! end pver loop for STEP 0 - - !============================================================== - ! ... Now use the actual PH - !============================================================== - ver_loop1: do k = 1,pver - col_loop1: do i = 1,ncol - work1(i) = 1._r8 / tfld(i,k) - 1._r8 / 298._r8 - tz = tfld(i,k) - - xl = cldconc%xlwc(i,k) - - patm = press(i,k) * PASCAL_TO_ATM ! atm - xam = press(i,k)/(BOLTZMANN*tz) ! air density /M3 - - !----------------------------------------------------------------------- - ! ... hno3 - !----------------------------------------------------------------------- - xk = dheff(1,heff_id_hno3) * exp( dheff(2,heff_id_hno3) * work1(i) ) - xe = dheff(3,heff_id_hno3) * exp( dheff(4,heff_id_hno3) * work1(i) ) - hehno3(i,k) = xk*(1._r8 + xe/xph(i,k)) - - !----------------------------------------------------------------- - ! ... h2o2 - !----------------------------------------------------------------- - xk = dheff(1,heff_id_h2o2) * exp( dheff(2,heff_id_h2o2) * work1(i) ) - xe = dheff(3,heff_id_h2o2) * exp( dheff(4,heff_id_h2o2) * work1(i) ) - heh2o2(i,k) = xk*(1._r8 + xe/xph(i,k)) - - !----------------------------------------------------------------- - ! ... so2 - !----------------------------------------------------------------- - xk = dheff(1,heff_id_so2) * exp( dheff(2,heff_id_so2) * work1(i) ) - xe = dheff(3,heff_id_so2) * exp( dheff(4,heff_id_so2) * work1(i) ) - x2 = dheff(5,heff_id_so2) * exp( dheff(6,heff_id_so2) * work1(i) ) - - wrk = xe/xph(i,k) - heso2(i,k) = xk*(1._r8 + wrk*(1._r8 + x2/xph(i,k))) - - ! Calculate fraction of total aqueous S(IV) that is HSO3- and SO3= - wrk = xe/(xph(i,k)*xph(i,k) + xe*xph(i,k) + xe*x2) - f_hso3 = wrk*xph(i,k) ! [HSO3-]/[S(IV)] - f_so3 = wrk*x2 ! [SO3=]/[S(IV)] - - !----------------------------------------------------------------- - ! ... nh3 - !----------------------------------------------------------------- - xk = dheff(1,heff_id_nh3) * exp( dheff(2,heff_id_nh3) * work1(i) ) - xe = dheff(3,heff_id_nh3) * exp( dheff(4,heff_id_nh3) * work1(i) ) - x2 = dheff(5,heff_id_nh3) * exp( dheff(6,heff_id_nh3) * work1(i) ) - henh3(i,k) = xk*(1._r8 + xe*xph(i,k)/x2) - - !----------------------------------------------------------------- - ! ... o3 - !----------------------------------------------------------------- - xk = dheff(1,heff_id_o3) * exp( dheff(2,heff_id_o3) * work1(i) ) - heo3(i,k) = xk - - !------------------------------------------------------------------------ - ! ... for Ho2(g) -> H2o2(a) formation - ! schwartz JGR, 1984, 11589 - !------------------------------------------------------------------------ - kh4 = (kh2 + kh3*kh1/xph(i,k)) / ((1._r8 + kh1/xph(i,k))**2) - ho2s = kh0*xho2(i,k)*patm*(1._r8 + kh1/xph(i,k)) ! ho2s = ho2(a)+o2- - r1h2o2 = kh4*ho2s*ho2s ! prod(h2o2) in mole/L(w)/s - r2h2o2 = r1h2o2 * xl & ! (mole(h2o2)/L(w)/s) * (L(w)/L(a)) - / xam & ! / (molecule(a)/m3(a)) - * AVOGADRO & ! * (molecule(a)/mole(a)) - * M3_TO_L ! * (L(a)/m3(a)) = mole(h2o2)/mole(a)/s - - xh2o2(i,k) = xh2o2(i,k) + r2h2o2*dtime ! updated h2o2 by het production - - !----------------------------------------------- - ! ... Partioning - !----------------------------------------------- - - !----------------------------------------------------------------- - ! ... hno3 - !----------------------------------------------------------------- - px = hehno3(i,k) * Ra * tz * xl - hno3g(i,k) = (xhno3(i,k)+xno3(i,k))/(1._r8 + px) - - !------------------------------------------------------------------------ - ! ... h2o2 - !------------------------------------------------------------------------ - px = heh2o2(i,k) * Ra * tz * xl - h2o2g = xh2o2(i,k)/(1._r8+ px) - - !------------------------------------------------------------------------ - ! ... so2 - !------------------------------------------------------------------------ - px = heso2(i,k) * Ra * tz * xl - so2g = xso2(i,k)/(1._r8+ px) - - !------------------------------------------------------------------------ - ! ... o3 - !------------------------------------------------------------------------ - px = heo3(i,k) * Ra * tz * xl - o3g = xo3(i,k)/(1._r8+ px) - - !------------------------------------------------------------------------ - ! ... nh3 - !------------------------------------------------------------------------ - px = henh3(i,k) * Ra * tz * xl - if (id_nh3>0) then - nh3g(i,k) = (xnh3(i,k)+xnh4(i,k))/(1._r8+ px) - else - nh3g(i,k) = 0._r8 - endif - - !----------------------------------------------- - ! ... Aqueous phase reaction rates - ! SO2 + H2O2 -> SO4 - ! SO2 + O3 -> SO4 - !----------------------------------------------- - - !------------------------------------------------------------------------ - ! ... S(IV) (HSO3) + H2O2 - ! Reference: Seinfeld and Pandis textbook (chapter 6); - ! original source: Hoffmann and Calvert (1985) - !------------------------------------------------------------------------ - rah2o2 = 7.45e7_r8 * EXP( -4430.0_r8*work1(i) ) * xph(i,k) & - / (1.0_r8 + 13.0_r8*xph(i,k)) * f_hso3 - - !------------------------------------------------------------------------ - ! ... S(IV)+ O3 - ! Reference: Seinfeld and Pandis textbook (chapter 6); - ! original source: Hoffmann and Calvert (1985) - !------------------------------------------------------------------------ - rao3 = 3.75e5_r8 * EXP(-5530.0_r8*work1(i)) * f_hso3 & - + 1.59e9_r8 * EXP(-5280.0_r8*work1(i)) * f_so3 - - !----------------------------------------------------------------- - ! ... Prediction after aqueous phase - ! so4 - ! When Cloud is present - ! - ! S(IV) + H2O2 = S(VI) - ! S(IV) + O3 = S(VI) - ! - ! reference: - ! (1) Seinfeld - ! (2) Benkovitz - !----------------------------------------------------------------- - - !............................ - ! S(IV) + H2O2 = S(VI) - !............................ - - IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED - - pso4 = rah2o2 * heh2o2(i,k) * h2o2g * patm & - * heso2(i,k) * so2g * patm ! [M/s] - - pso4 = pso4 & ! [M/s] = [mole/L(w)/s] - * xl & ! [mole/L(a)/s] - / const0 & ! [/L(a)/s] - / xhnm(i,k) - - ! estimate the net production of so4, without exceeding reactant concentrations - xso4_init(i,k) = xso4(i,k) - ccc = max(min(pso4*dtime, min(xh2o2(i,k) - SMALL_NUMBER, xso2(i,k) - SMALL_NUMBER)), 0.0_r8) - xso4(i,k) = xso4(i,k) + ccc - xh2o2(i,k) = xh2o2(i,k) - ccc - xso2(i,k) = xso2(i,k) - ccc - xdelso4hp(i,k) = ccc - - !........................... - ! S(IV) + O3 = S(VI) - !........................... - - pso4 = rao3 * heo3(i,k)*o3g*patm * heso2(i,k)*so2g*patm ! [M/s] - - pso4 = pso4 & ! [M/s] = [mole/L(w)/s] - * xl & ! [mole/L(a)/s] - / const0 & ! [/L(a)/s] - / xhnm(i,k) ! [mixing ratio/s] - - ! estimate the net production of so4, without exceeding reactant concentrations - xso4_init(i,k) = xso4(i,k) - ccc = max(min(pso4*dtime, xso2(i,k) - SMALL_NUMBER), 0.0_r8) - xso4(i,k) = xso4(i,k) + ccc - xso2(i,k) = xso2(i,k) - ccc - - END IF !! WHEN CLOUD IS PRESENTED - - end do col_loop1 - end do ver_loop1 - - aqso4 = 0._r8 - aqh2so4 = 0._r8 - aqso4_h2o2 = 0._r8 - aqso4_o3 = 0._r8 - - if (cloud_borne) then - ! update cloud-borne aerosols - call sox_cldaero_update( aero_state, & - ncol, pver, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, cldconc%xlwc, & - gravit, & - xdelso4hp, xh2so4, xso4, xso4_init, nh3g, xnh3, xnh4c, xmsa, xso2, xh2o2, qcw, qin, & - aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d=aqso4_h2o2_3d, aqso4_o3_3d=aqso4_o3_3d ) - else - if (id_so2>0) then - qin(:ncol,:,id_so2) = max( xso2(:ncol,:), small_value ) - endif - if (id_h2o2>0) then - qin(:ncol,:,id_h2o2) = max( xh2o2(:ncol,:), small_value ) - endif - qin(:ncol,:,id_so4) = max( xso4(:ncol,:), small_value ) - endif - - xphlwc(:,:) = 0._r8 - do k = 1, pver - do i = 1, ncol - if (cldfrc(i,k)>=1.e-5_r8 .and. lwc(i,k)>=1.e-8_r8) then - xphlwc(i,k) = -1._r8*log10(xph(i,k)) * lwc(i,k) - endif - end do - end do - - call sox_cldaero_destroy_obj(cldconc) - - end subroutine setsox_sub - -end module mo_setsox diff --git a/src/chemistry/aerosol/sox_cldaero_mod.F90 b/src/chemistry/aerosol/sox_cldaero_mod.F90 deleted file mode 100644 index 0565de7544..0000000000 --- a/src/chemistry/aerosol/sox_cldaero_mod.F90 +++ /dev/null @@ -1,494 +0,0 @@ -!---------------------------------------------------------------------------------- -! Generic aerosol implementation -! -! Portable (CCPP-ready): species indices, host constants and configuration are -! passed in through sox_cldaero_init; no CAM infrastructure dependencies. -!---------------------------------------------------------------------------------- -module sox_cldaero_mod - - use shr_kind_mod, only : r8 => shr_kind_r8 - use cldaero_mod, only : cldaero_conc_t, cldaero_allocate, cldaero_deallocate - use cldaero_mod, only : cldaero_uptakerate - use aerosol_properties_mod, only: aerosol_properties - use aerosol_state_mod, only: aerosol_state - - implicit none - private - - public :: sox_cldaero_init - public :: sox_cldaero_create_obj - public :: sox_cldaero_update - public :: sox_cldaero_destroy_obj - - integer :: id_msa=-1, id_h2so4=-1, id_so2=-1, id_h2o2=-1, id_nh3=-1 - - real(r8), parameter :: small_value = 1.e-20_r8 - - integer :: ncnst_tot = -huge(1) ! total number of mode number conc + mode species - integer, public, protected :: nbins = 0 - - class(aerosol_properties), pointer :: aero_props =>null() - - logical :: has_msa = .false. - - ! host value of pi (passed at init for bit-for-bit consistency) - real(r8) :: pi = -huge(1._r8) - - ! apply the aqueous sulfur oxidation update to the aerosol/gas state here; - ! .false. when the chemistry package does its own in-cloud sulfur oxidation - ! (e.g. GEOS-Chem), to avoid double counting - logical :: do_aqueous_sulfur_chemistry_aerosol_update = .true. - -contains - -!---------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------- - - subroutine sox_cldaero_init(aero_props_in, id_msa_in, id_h2so4_in, id_so2_in, & - id_h2o2_in, id_nh3_in, pi_in, do_aqueous_sulfur_chemistry_aerosol_update_in, & - errmsg, errflg) - class(aerosol_properties), target, intent(in) :: aero_props_in - ! species indices in the chemistry solution array, resolved by the host - integer, intent(in) :: id_msa_in, id_h2so4_in, id_so2_in, id_h2o2_in, id_nh3_in - real(r8), intent(in) :: pi_in ! host value of pi - logical, intent(in) :: do_aqueous_sulfur_chemistry_aerosol_update_in - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - - id_msa = id_msa_in - id_h2so4 = id_h2so4_in - id_so2 = id_so2_in - id_h2o2 = id_h2o2_in - id_nh3 = id_nh3_in - has_msa = id_msa>0 - - pi = pi_in - do_aqueous_sulfur_chemistry_aerosol_update = do_aqueous_sulfur_chemistry_aerosol_update_in - - if ( id_so2<1 ) then - errflg = 1 - errmsg = 'sox_cldaero_init: SO2 is not included in chemistry -- should not invoke sox_cldaero_mod...' - return - endif - - aero_props => aero_props_in - - ncnst_tot = aero_props%ncnst_tot() - nbins = aero_props%nbins() - - end subroutine sox_cldaero_init - -!---------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------- - function sox_cldaero_create_obj(cldfrc, qcw, lwc, cfact, ncol, pver) result( conc_obj ) - - real(r8), intent(in) :: cldfrc(:,:) - real(r8), intent(in) :: qcw(:,:,:) - real(r8), intent(in) :: lwc(:,:) - real(r8), intent(in) :: cfact(:,:) - integer, intent(in) :: ncol - integer, intent(in) :: pver - - type(cldaero_conc_t), pointer :: conc_obj - - character(len=32) :: spectype - integer :: l,m - integer :: i,k,mm, ntot_amode - logical :: mode7 - - conc_obj => cldaero_allocate(ncol, pver) - - if (aero_props%model_is('BAM')) then - ! no cloud-borne aerosols - conc_obj%xlwc(:ncol,:) = lwc(:ncol,:)*cfact(:ncol,:) ! cloud water L(water)/L(air) - return - end if - - if (aero_props%model_is('MAM')) then - ntot_amode = aero_props%nbins() - if (ntot_amode /= 7) then - conc_obj%so4_fact = 1._r8 - end if - end if - - do k = 1,pver - do i = 1,ncol - if(cldfrc(i,k)>0._r8) then - conc_obj%xlwc(i,k) = lwc(i,k) *cfact(i,k) ! cloud water L(water)/L(air) - conc_obj%xlwc(i,k) = conc_obj%xlwc(i,k) / cldfrc(i,k) ! liquid water in the cloudy fraction of cell - else - conc_obj%xlwc(i,k) = 0._r8 - endif - enddo - enddo - - conc_obj%no3c(:,:) = 0._r8 - conc_obj%nh4c(:,:) = 0._r8 - conc_obj%so4c(:,:) = 0._r8 - - do k = 1,pver - do i = 1,ncol - do m = 1, aero_props%nbins() - do l = 1, aero_props%nspecies(m) - mm = aero_props%indexer(m,l) - call aero_props%get(m,l, spectype=spectype) - if (trim(spectype) == 'sulfate') then - conc_obj%so4c(i,k) = conc_obj%so4c(i,k) + qcw(i,k,mm) - end if - if (trim(spectype) == 'ammonium') then - conc_obj%nh4c(i,k) = conc_obj%nh4c(i,k) + qcw(i,k,mm) - end if - end do - end do - end do - end do - - end function sox_cldaero_create_obj - -!---------------------------------------------------------------------------------- -! Update the mixing ratios -!---------------------------------------------------------------------------------- - subroutine sox_cldaero_update( aero_state, & - ncol, pver, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, xlwc, & - gravit, & - delso4_hprxn, xh2so4, xso4, xso4_init, nh3g, xnh3, xnh4c, xmsa, xso2, xh2o2, qcw, qin, & - aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d, aqso4_o3_3d) - - ! args - - class(aerosol_state), intent(in) :: aero_state - - integer, intent(in) :: ncol - integer, intent(in) :: pver - - real(r8), intent(in) :: dtime ! time step (sec) - - real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) - real(r8), intent(in) :: pdel(:,:) - real(r8), intent(in) :: press(:,:) - real(r8), intent(in) :: tfld(:,:) - - real(r8), intent(in) :: cldnum(:,:) - real(r8), intent(in) :: cldfrc(:,:) - real(r8), intent(in) :: cfact(:,:) - real(r8), intent(in) :: xlwc(:,:) - - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - - real(r8), intent(in) :: delso4_hprxn(:,:) - real(r8), intent(in) :: xh2so4(:,:) - real(r8), intent(in) :: xso4(:,:) - real(r8), intent(in) :: xso4_init(:,:) - real(r8), intent(in) :: nh3g(:,:) - real(r8), intent(in) :: xnh3(:,:) - real(r8), intent(in) :: xnh4c(:,:) - real(r8), intent(in) :: xmsa(:,:) - real(r8), intent(in) :: xso2(:,:) - real(r8), intent(in) :: xh2o2(:,:) - - real(r8), intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) - real(r8), intent(inout) :: qin(:,:,:) ! xported species ( vmr ) - - real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) - real(r8), intent(out), optional :: aqso4_h2o2_3d(:,:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out), optional :: aqso4_o3_3d(:,:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) - - ! local vars ... - - real(r8) :: dqdt_aqso4(ncol,pver,ncnst_tot), & - dqdt_aqh2so4(ncol,pver,ncnst_tot), & - dqdt_aqhprxn(ncol,pver), dqdt_aqo3rxn(ncol,pver) - - real(r8) :: faqgain_msa(nbins,ncol,pver), faqgain_so4(nbins,ncol,pver) - real(r8) :: delso4_ox(ncol,pver) - - real(r8) :: delnh3, delnh4 - real(r8) :: dso4dt_aqrxn, dso4dt_hprxn, & - dso4dt_gasuptk, dmsadt_gasuptk, & - dmsadt_gasuptk_tomsa, dmsadt_gasuptk_toso4, & - dqdt_aq, dqdt_wr, dqdt - - real(r8) :: fwetrem, uptkrate - - integer :: l, m, n, mm - integer :: i,k - real(r8) :: xl - real(r8) :: mw_so4 - character(len=32) :: spectype - character(len=32) :: specname - - ! make sure dqdt is zero initially, for budgets - dqdt_aqso4(:,:,:) = 0.0_r8 - dqdt_aqh2so4(:,:,:) = 0.0_r8 - dqdt_aqhprxn(:,:) = 0.0_r8 - dqdt_aqo3rxn(:,:) = 0.0_r8 - - aqso4 = 0.0_r8 - aqh2so4 = 0.0_r8 - aqso4_h2o2 = 0.0_r8 - aqso4_o3 = 0.0_r8 - delso4_ox = 0.0_r8 - - ! Avoid double counting in-cloud sulfur oxidation when running with - ! GEOS-Chem. If running with GEOS-Chem then sulfur oxidation - ! is performed internally to GEOS-Chem. Here, we just return to the - ! parent routine and thus we do not apply tendencies calculated by MAM. - ! (The host sets this flag; CAM passes .not. cam_chempkg_is('geoschem_mam4').) - if ( .not. do_aqueous_sulfur_chemistry_aerosol_update ) return - - where (cldfrc(:ncol,:) >= 1.0e-5_r8) - delso4_ox(:ncol,:) = xso4(:ncol,:) - xso4_init(:ncol,:) - end where - - !------------------------------------------------------------------------- - ! Compute factors for partitioning aerosol mass gains among bins / modes. - ! The factors are proportional to the activated particle MR for each - ! bin, which is the MR of cloud drops "associated with" the mode - ! thus we are assuming the cloud drop size is independent of the - ! associated aerosol mode properties - call aero_state%aqu_gain_binfraction(aero_props, 'sulfate', qcw, delso4_ox, faqgain_so4) - if (has_msa) call aero_state%aqu_gain_binfraction(aero_props, 'msa', qcw, delso4_ox, faqgain_msa) - - lev_loop: do k = 1,pver - col_loop: do i = 1,ncol - cloud: if (cldfrc(i,k) >= 1.0e-5_r8) then - xl = xlwc(i,k) - - if (xl .ge. 1.e-8_r8) then !! when cloud is present - - if (id_nh3>0) then - delnh3 = nh3g(i,k) - xnh3(i,k) - delnh4 = - delnh3 - endif - - ! faqgain_msa(n) = fraction of total msa_c gain going to mode n - - uptkrate = cldaero_uptakerate( xl, cldnum(i,k), cfact(i,k), cldfrc(i,k), tfld(i,k), press(i,k), pi ) - ! average uptake rate over dtime - uptkrate = (1.0_r8 - exp(-min(100._r8,dtime*uptkrate))) / dtime - - ! dso4dt_gasuptk = so4_c tendency from h2so4 gas uptake (mol/mol/s) - ! dmsadt_gasuptk = msa_c tendency from msa gas uptake (mol/mol/s) - dso4dt_gasuptk = xh2so4(i,k) * uptkrate - if (has_msa) then - dmsadt_gasuptk = xmsa(i,k) * uptkrate - else - dmsadt_gasuptk = 0.0_r8 - end if - - ! if no modes have msa aerosol, then "rename" scavenged msa gas to so4 - if (has_msa) then - dmsadt_gasuptk_toso4 = 0.0_r8 - dmsadt_gasuptk_tomsa = dmsadt_gasuptk - else - ! no MSA - dmsadt_gasuptk_tomsa = 0.0_r8 - dmsadt_gasuptk_toso4 = dmsadt_gasuptk - end if - - !----------------------------------------------------------------------- - ! now compute TMR tendencies - ! this includes the above aqueous so2 chemistry AND - ! the uptake of highly soluble aerosol precursor gases (h2so4, msa, ...) - ! AND the wetremoval of dissolved, unreacted so2 and h2o2 - - dso4dt_aqrxn = (delso4_ox(i,k) + delso4_hprxn(i,k)) / dtime - dso4dt_hprxn = delso4_hprxn(i,k) / dtime - - ! fwetrem = fraction of in-cloud-water material that is wet removed - ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*clwlrat(i,k)))) ) - fwetrem = 0.0_r8 ! don't have so4 & msa wet removal here - - ! compute TMR tendencies for so4 and msa aerosol-in-cloud-water - do m = 1, aero_props%nbins() - do l = 1, aero_props%nspecies(m) - mm = aero_props%indexer(m,l) - call aero_props%get(m,l, spectype=spectype) - if (trim(spectype) == 'sulfate') then - - dqdt_aqso4(i,k,mm) = faqgain_so4(m,i,k)*dso4dt_aqrxn*cldfrc(i,k) - - dqdt_aqh2so4(i,k,mm) = faqgain_so4(m,i,k)* & - (dso4dt_gasuptk + dmsadt_gasuptk_toso4)*cldfrc(i,k) - dqdt_aq = dqdt_aqso4(i,k,mm) + dqdt_aqh2so4(i,k,mm) - dqdt_wr = -fwetrem*dqdt_aq - dqdt = dqdt_aq + dqdt_wr - qcw(i,k,mm) = qcw(i,k,mm) + dqdt*dtime - - end if - if (trim(spectype) == 'msa') then - dqdt_aq = faqgain_msa(m,i,k)*dmsadt_gasuptk_tomsa*cldfrc(i,k) - dqdt_wr = -fwetrem*dqdt_aq - dqdt = dqdt_aq + dqdt_wr - qcw(i,k,mm) = qcw(i,k,mm) + dqdt*dtime - end if - if (trim(spectype) == 'ammonium') then - if (delnh4 > 0.0_r8) then - dqdt_aq = faqgain_so4(m,i,k)*delnh4/dtime*cldfrc(i,k) - dqdt = dqdt_aq - qcw(i,k,mm) = qcw(i,k,mm) + dqdt*dtime - else - dqdt = (qcw(i,k,mm)/max(xnh4c(i,k),1.0e-35_r8)) & - *delnh4/dtime*cldfrc(i,k) - qcw(i,k,mm) = qcw(i,k,mm) + dqdt*dtime - endif - end if - end do - end do - - ! For gas species, tendency includes - ! reactive uptake to cloud water that essentially transforms the gas to - ! a different species. Wet removal associated with this is applied - ! to the "new" species (e.g., so4_c) rather than to the gas. - ! wet removal of the unreacted gas that is dissolved in cloud water. - ! Need to multiply both these parts by cldfrc - - ! h2so4 (g) & msa (g) - qin(i,k,id_h2so4) = qin(i,k,id_h2so4) - dso4dt_gasuptk * dtime * cldfrc(i,k) - if (has_msa) qin(i,k,id_msa) = qin(i,k,id_msa) - dmsadt_gasuptk * dtime * cldfrc(i,k) - - ! so2 -- the first order loss rate for so2 is frso2_c*clwlrat(i,k) - ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*frso2_c*clwlrat(i,k)))) ) - fwetrem = 0.0_r8 ! don't include so2 wet removal here - - dqdt_wr = -fwetrem*xso2(i,k)/dtime*cldfrc(i,k) - dqdt_aq = -dso4dt_aqrxn*cldfrc(i,k) - dqdt = dqdt_aq + dqdt_wr - qin(i,k,id_so2) = qin(i,k,id_so2) + dqdt * dtime - - ! h2o2 -- the first order loss rate for h2o2 is frh2o2_c*clwlrat(i,k) - ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*frh2o2_c*clwlrat(i,k)))) ) - fwetrem = 0.0_r8 ! don't include h2o2 wet removal here - - dqdt_wr = -fwetrem*xh2o2(i,k)/dtime*cldfrc(i,k) - dqdt_aq = -dso4dt_hprxn*cldfrc(i,k) - dqdt = dqdt_aq + dqdt_wr - qin(i,k,id_h2o2) = qin(i,k,id_h2o2) + dqdt * dtime - - ! NH3 - if (id_nh3>0) then - dqdt_aq = delnh3/dtime*cldfrc(i,k) - dqdt = dqdt_aq - qin(i,k,id_nh3) = qin(i,k,id_nh3) + dqdt * dtime - endif - - ! for SO4 from H2O2/O3 budgets - dqdt_aqhprxn(i,k) = dso4dt_hprxn*cldfrc(i,k) - dqdt_aqo3rxn(i,k) = (dso4dt_aqrxn - dso4dt_hprxn)*cldfrc(i,k) - - endif !! when cloud is present - endif cloud - enddo col_loop - enddo lev_loop - - !============================================================== - ! ... Update the mixing ratios - !============================================================== - do k = 1,pver - - do n = 1, aero_props%nbins() - do l = 1, aero_props%nspecies(n) - mm = aero_props%indexer(n,l) - call aero_props%get(n,l, spectype=spectype) - if (trim(spectype) == 'sulfate') then - qcw(:ncol,k,mm) = MAX(qcw(:ncol,k,mm), small_value ) - end if - if (trim(spectype) == 'msa') then - qcw(:ncol,k,mm) = MAX(qcw(:ncol,k,mm), small_value ) - end if - if (trim(spectype) == 'ammonium') then - qcw(:ncol,k,mm) = MAX(qcw(:ncol,k,mm), small_value ) - end if - end do - end do - - qin(:ncol,k,id_so2) = MAX( qin(:ncol,k,id_so2), small_value ) - qin(:ncol,k,id_h2o2) = MAX( qin(:ncol,k,id_h2o2), small_value ) - qin(:ncol,k,id_h2so4) = MAX( qin(:ncol,k,id_h2so4), small_value ) - if ( id_msa > 0 ) qin(:ncol,k,id_msa) = MAX( qin(:ncol,k,id_msa), small_value ) - if ( id_nh3 > 0 ) qin(:ncol,k,id_nh3) = MAX( qin(:ncol,k,id_nh3), small_value ) - - end do - - ! diagnostics - mw_so4 = -huge(1._r8) - - do n = 1, aero_props%nbins() - ! while looking through all species, only dqdt_aqso4 from sulfates is gt zero - do l = 1, aero_props%nspecies(n) - mm = aero_props%indexer(n,l) - call aero_props%get(n,l, spectype=spectype, specname=specname) - if (trim(spectype) == 'sulfate') then - call aero_props%get(n,l, spec_mw=mw_so4) - aqso4(:,n)=0._r8 - do k=1,pver - do i=1,ncol - aqso4(i,n)=aqso4(i,n)+dqdt_aqso4(i,k,mm)*mw_so4/mbar(i,k) & - *pdel(i,k)/gravit ! kg/m2/s - enddo - enddo - aqh2so4(:,n)=0._r8 - do k=1,pver - do i=1,ncol - aqh2so4(i,n)=aqh2so4(i,n)+dqdt_aqh2so4(i,k,mm)*mw_so4/mbar(i,k) & - *pdel(i,k)/gravit ! kg/m2/s - enddo - enddo - end if - end do - end do - - aqso4_h2o2(:) = 0._r8 - do k=1,pver - do i=1,ncol - aqso4_h2o2(i)=aqso4_h2o2(i)+dqdt_aqhprxn(i,k)*mw_so4/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - - if (present(aqso4_h2o2_3d)) then - aqso4_h2o2_3d(:,:) = 0._r8 - do k=1,pver - do i=1,ncol - aqso4_h2o2_3d(i,k)=dqdt_aqhprxn(i,k)*mw_so4/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - end if - - aqso4_o3(:)=0._r8 - do k=1,pver - do i=1,ncol - aqso4_o3(i)=aqso4_o3(i)+dqdt_aqo3rxn(i,k)*mw_so4/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - - if (present(aqso4_o3_3d)) then - aqso4_o3_3d(:,:)=0._r8 - do k=1,pver - do i=1,ncol - aqso4_o3_3d(i,k)=dqdt_aqo3rxn(i,k)*mw_so4/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - end if - - end subroutine sox_cldaero_update - - !---------------------------------------------------------------------------------- - !---------------------------------------------------------------------------------- - subroutine sox_cldaero_destroy_obj( conc_obj ) - type(cldaero_conc_t), pointer :: conc_obj - - call cldaero_deallocate( conc_obj ) - - end subroutine sox_cldaero_destroy_obj - -end module sox_cldaero_mod diff --git a/src/chemistry/aerosol/sslt_sections.F90 b/src/chemistry/aerosol/sslt_sections.F90 deleted file mode 100644 index 946daf703d..0000000000 --- a/src/chemistry/aerosol/sslt_sections.F90 +++ /dev/null @@ -1,120 +0,0 @@ -!=============================================================================== -! used to compute sea salt surface emissions for modal and sectional aerosol models -!=============================================================================== -module sslt_sections - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - - private - - public :: sslt_sections_init - public :: fluxes - public :: nsections - public :: Dg - public :: rdry - - integer,parameter :: nsections = 31 - - ! only use up to ~20um - real(r8),parameter :: Dg(nsections) = (/ & - 0.0020e-5_r8, 0.0025e-5_r8, 0.0032e-5_r8, & - 0.0040e-5_r8, 0.0051e-5_r8, 0.0065e-5_r8, & - 0.0082e-5_r8, 0.0104e-5_r8, 0.0132e-5_r8, & - 0.0167e-5_r8, 0.0211e-5_r8, 0.0267e-5_r8, & - 0.0338e-5_r8, 0.0428e-5_r8, 0.0541e-5_r8, & - 0.0685e-5_r8, 0.0867e-5_r8, 0.1098e-5_r8, & - 0.1389e-5_r8, 0.1759e-5_r8, 0.2226e-5_r8, & - 0.2818e-5_r8, 0.3571e-5_r8, 0.4526e-5_r8, & - 0.5735e-5_r8, 0.7267e-5_r8, 0.9208e-5_r8, & - 1.1668e-5_r8, 1.4786e-5_r8, 1.8736e-5_r8, & - 2.3742e-5_r8 /) - - real(r8), dimension(nsections) :: bm, rdry, rm - real(r8), dimension(4,nsections) :: consta, constb !constants for calculating emission polynomial - -contains - - !=========================================================================== - !=========================================================================== - subroutine sslt_sections_init() - - integer :: m - - ! use Ekman's ss - rdry(:)=Dg(:)/2._r8 ! meter - ! multiply rm with 1.814 because it should be RH=80% and not dry particles - ! for the parameterization - rm(:)=1.814_r8*rdry(:)*1.e6_r8 ! um - bm(:)=(0.380_r8-log10(rm(:)))/0.65_r8 ! use in Manahan - - ! calculate constants form emission polynomials - do m=1,nsections - if ((m).le.9)then - consta(1,m) = (-2.576_r8)*10._r8**35*Dg(m)**4+5.932_r8*10._r8**28 & - * Dg(m)**3+(-2.867_r8)*10._r8**21*Dg(m)**2+(-3.003_r8) & - * 10._r8**13*Dg(m) + (-2.881_r8)*10._r8**6 - constb(1,m) = 7.188_r8*10._r8**37 & - * Dg(m)**4+(-1.616_r8)*10._r8**31*Dg(m)**3+6.791_r8*10._r8**23 & - * Dg(m)**2+1.829_r8*10._r8**16*Dg(m)+7.609_r8*10._r8**8 - elseif ((m).ge.10.and.(m).le.13)then - consta(2,m) = (-2.452_r8)*10._r8**33*Dg(m)**4+2.404_r8*10._r8**27 & - * Dg(m)**3+(-8.148_r8)*10._r8**20*Dg(m)**2+(1.183_r8)*10._r8**14 & - * Dg(m)+(-6.743_r8)*10._r8**6 - constb(2,m) = 7.368_r8*10._r8**35 & - * Dg(m)**4+(-7.310_r8)*10._r8**29*Dg(m)**3+ 2.528_r8*10._r8**23 & - * Dg(m)**2+(-3.787_r8)*10._r8**16*Dg(m)+ 2.279_r8*10._r8**9 - elseif ((m).ge.14.and.(m).lt.22)then - consta(3,m) = (1.085_r8)*10._r8**29*Dg(m)**4+(-9.841_r8)*10._r8**23 & - * Dg(m)**3+(3.132_r8)*10._r8**18*Dg(m)**2+(-4.165_r8)*10._r8**12 & - * Dg(m)+(2.181_r8)*10._r8**6 - constb(3,m) = (-2.859_r8)*10._r8**31 & - * Dg(m)**4+(2.601_r8)*10._r8**26*Dg(m)**3+(-8.297_r8)*10._r8**20 & - * Dg(m)**2+(1.105_r8)*10._r8**15*Dg(m)+(-5.800_r8)*10._r8**8 - elseif (m.ge.22.and.m.le.40)then - ! use monahan - consta(4,m) = (1.373_r8*rm(m)**(-3)*(1+0.057_r8*rm(m)**1.05_r8) & - * 10**(1.19_r8*exp(-bm(m)**2))) & - * (rm(m)-rm(m-1)) - endif - enddo - end subroutine sslt_sections_init - - !=========================================================================== - !=========================================================================== - function fluxes ( sst, u10cubed, ncol ) result(fi) - - real (r8),intent(in) :: sst(:) - real (r8),intent(in) :: u10cubed(:) - integer ,intent(in) :: ncol - - real (r8) :: fi(ncol,nsections) - - integer :: m - real (r8) :: W(ncol) - - ! Calculations of source strength and size distribution - ! NB the 0.1 is the dlogDp we have to multiplie with to get the flux, but the value dependence - ! of course on what dlogDp you have. You will also have to change the sections of Dg if you use - ! a different number of size bins with different intervals. - - W(:ncol)=3.84e-6_r8*u10cubed(:ncol)*0.1_r8 ! whitecap area - - ! calculate number flux fi (#/m2/s) - fi(:,:)=0._r8 - do m=1,nsections - if (m.le.9)then - fi(:ncol,m)=W(:ncol)*((sst(:ncol))*consta(1,m)+constb(1,m)) - elseif (m.ge.10.and.m.le.13)then - fi(:ncol,m)=W(:ncol)*((sst(:ncol))*consta(2,m)+constb(2,m)) - elseif (m.ge.14.and.m.lt.22)then - fi(:ncol,m)=W(:ncol)*((sst(:ncol))*consta(3,m)+constb(3,m)) - elseif (m.ge.22.and.m.le.40)then - ! use Monahan - fi(:ncol,m)=consta(4,m)*u10cubed(:ncol) - endif - enddo - - end function fluxes - -end module sslt_sections diff --git a/src/chemistry/aerosol/wetdep.F90 b/src/chemistry/aerosol/wetdep.F90 deleted file mode 100644 index b60791ea95..0000000000 --- a/src/chemistry/aerosol/wetdep.F90 +++ /dev/null @@ -1,1277 +0,0 @@ -module wetdep - -!----------------------------------------------------------------------- -! -! Wet deposition routines for both aerosols and gas phase constituents. -! -!----------------------------------------------------------------------- - -use shr_kind_mod, only: r8 => shr_kind_r8 -use aerosol_properties_mod, only: aerosol_properties -use shr_infnan_mod, only: nan => shr_infnan_nan, assignment(=) - -implicit none -save -private - -public :: wetdepa_v1 ! scavenging codes for very soluble aerosols -- CAM4 version -public :: wetdepa_v2 ! scavenging codes for very soluble aerosols -- CAM5 version -public :: clddiag ! calc of cloudy volume and rain mixing ratio -public :: init_bcscavcoef ! build below-cloud impaction scavenging lookup table -public :: get_bcscavcoefs ! interpolate below-cloud impaction scavenging coefs - -real(r8), parameter :: cmftau = 3600._r8 -real(r8), parameter :: rhoh2o = 1000._r8 ! density of water -real(r8), parameter :: omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - -! variables for table lookup of aerosol impaction/interception scavenging rates -integer, parameter :: nimptblgrow_mind=-7, nimptblgrow_maxd=12 -real(r8) :: dlndg_nimptblgrow -real(r8),allocatable :: scavimptblnum(:,:) -real(r8),allocatable :: scavimptblvol(:,:) - -!============================================================================== -contains -!============================================================================== - -subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & - cldt, cldcu, cldst, evapr, & - prain, cldv, cldvcu, cldvst, rain, & - ncol, pver, gravit, tmelt, rair) - - ! ------------------------------------------------------------------------------------ - ! Estimate the cloudy volume which is occupied by rain or cloud water as - ! the max between the local cloud amount or the - ! sum above of (cloud*positive precip production) sum total precip from above - ! ---------------------------------- x ------------------------ - ! sum above of (positive precip ) sum positive precip from above - ! Author: P. Rasch - ! Sungsu Park. Mar.2010 - ! ------------------------------------------------------------------------------------ - - ! Input arguments: - real(r8), intent(in) :: t(:,:) ! temperature (K) - real(r8), intent(in) :: pmid(:,:) ! pressure at layer midpoints - real(r8), intent(in) :: pdel(:,:) ! pressure difference across layers - real(r8), intent(in) :: cmfdqr(:,:) ! dq/dt due to convective rainout - real(r8), intent(in) :: evapc(:,:) ! Evaporation rate of convective precipitation ( >= 0 ) - real(r8), intent(in) :: cldt(:,:) ! total cloud fraction - real(r8), intent(in) :: cldcu(:,:) ! Cumulus cloud fraction - real(r8), intent(in) :: cldst(:,:) ! Stratus cloud fraction - real(r8), intent(in) :: evapr(:,:) ! rate of evaporation of falling precipitation (kg/kg/s) - real(r8), intent(in) :: prain(:,:) ! rate of conversion of condensate to precipitation (kg/kg/s) - integer, intent(in) :: ncol - integer, intent(in) :: pver - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - real(r8), intent(in) :: tmelt ! freezing point of water (K) - real(r8), intent(in) :: rair ! dry air gas constant (J/K/kg) - - ! Output arguments: - real(r8), intent(out) :: cldv(:,:) ! fraction occupied by rain or cloud water - real(r8), intent(out) :: cldvcu(:,:) ! Convective precipitation volume - real(r8), intent(out) :: cldvst(:,:) ! Stratiform precipitation volume - real(r8), intent(out) :: rain(:,:) ! mixing ratio of rain (kg/kg) - - ! Local variables: - integer i, k - real(r8) convfw ! used in fallspeed calculation; taken from findmcnew - real(r8) sumppr(ncol) ! precipitation rate (kg/m2-s) - real(r8) sumpppr(ncol) ! sum of positive precips from above - real(r8) cldv1(ncol) ! precip weighted cloud fraction from above - real(r8) lprec ! local production rate of precip (kg/m2/s) - real(r8) lprecp ! local production rate of precip (kg/m2/s) if positive - real(r8) rho ! air density - real(r8) vfall - real(r8) sumppr_cu(ncol) ! Convective precipitation rate (kg/m2-s) - real(r8) sumpppr_cu(ncol) ! Sum of positive convective precips from above - real(r8) cldv1_cu(ncol) ! Convective precip weighted convective cloud fraction from above - real(r8) lprec_cu ! Local production rate of convective precip (kg/m2/s) - real(r8) lprecp_cu ! Local production rate of convective precip (kg/m2/s) if positive - real(r8) sumppr_st(ncol) ! Stratiform precipitation rate (kg/m2-s) - real(r8) sumpppr_st(ncol) ! Sum of positive stratiform precips from above - real(r8) cldv1_st(ncol) ! Stratiform precip weighted stratiform cloud fraction from above - real(r8) lprec_st ! Local production rate of stratiform precip (kg/m2/s) - real(r8) lprecp_st ! Local production rate of stratiform precip (kg/m2/s) if positive - ! ----------------------------------------------------------------------- - - convfw = 1.94_r8*2.13_r8*sqrt(rhoh2o*gravit*2.7e-4_r8) - do i=1,ncol - sumppr(i) = 0._r8 - cldv1(i) = 0._r8 - sumpppr(i) = 1.e-36_r8 - sumppr_cu(i) = 0._r8 - cldv1_cu(i) = 0._r8 - sumpppr_cu(i) = 1.e-36_r8 - sumppr_st(i) = 0._r8 - cldv1_st(i) = 0._r8 - sumpppr_st(i) = 1.e-36_r8 - end do - - do k = 1,pver - do i = 1,ncol - cldv(i,k) = & - max(min(1._r8, & - cldv1(i)/sumpppr(i) & - )*sumppr(i)/sumpppr(i), & - cldt(i,k) & - ) - lprec = pdel(i,k)/gravit & - *(prain(i,k)+cmfdqr(i,k)-evapr(i,k)) - lprecp = max(lprec,1.e-30_r8) - cldv1(i) = cldv1(i) + cldt(i,k)*lprecp - sumppr(i) = sumppr(i) + lprec - sumpppr(i) = sumpppr(i) + lprecp - - ! For convective precipitation volume at the top interface of each layer. Neglect the current layer. - cldvcu(i,k) = max(min(1._r8,cldv1_cu(i)/sumpppr_cu(i))*(sumppr_cu(i)/sumpppr_cu(i)),0._r8) - lprec_cu = (pdel(i,k)/gravit)*(cmfdqr(i,k)-evapc(i,k)) - lprecp_cu = max(lprec_cu,1.e-30_r8) - cldv1_cu(i) = cldv1_cu(i) + cldcu(i,k)*lprecp_cu - sumppr_cu(i) = sumppr_cu(i) + lprec_cu - sumpppr_cu(i) = sumpppr_cu(i) + lprecp_cu - - ! For stratiform precipitation volume at the top interface of each layer. Neglect the current layer. - cldvst(i,k) = max(min(1._r8,cldv1_st(i)/sumpppr_st(i))*(sumppr_st(i)/sumpppr_st(i)),0._r8) - lprec_st = (pdel(i,k)/gravit)*(prain(i,k)-evapr(i,k)) - lprecp_st = max(lprec_st,1.e-30_r8) - cldv1_st(i) = cldv1_st(i) + cldst(i,k)*lprecp_st - sumppr_st(i) = sumppr_st(i) + lprec_st - sumpppr_st(i) = sumpppr_st(i) + lprecp_st - - rain(i,k) = 0._r8 - if(t(i,k) > tmelt) then - rho = pmid(i,k)/(rair*t(i,k)) - vfall = convfw/sqrt(rho) - rain(i,k) = sumppr(i)/(rho*vfall) - if (rain(i,k) < 1.e-14_r8) rain(i,k) = 0._r8 - endif - end do - end do - -end subroutine clddiag - -!============================================================================== - -! This is the CAM5 version of wetdepa. - -subroutine wetdepa_v2( & - pdel, cldt, cldc, & - cmfdqr, evapc, conicw, precs, & - evaps, cwat, tracer, deltat, scavt, & - iscavt, cldvcu, cldvst, dlf, fracis, & - sol_fact, ncol, scavcoef, gravit, pver, errmsg, errflg, & - is_strat_cloudborne, qqcw, & - f_act_conv, icscavt, isscavt, bcscavt, bsscavt, & - convproc_do_aer, rcscavt, rsscavt, & - sol_facti_in, sol_factic_in, convproc_do_evaprain_atonce_in, bergso_in ) - - !----------------------------------------------------------------------- - ! - ! scavenging code for very soluble aerosols - ! - !----------------------------------------------------------------------- - - real(r8), intent(in) ::& - pdel(:,:), &! pressure thikness - cldt(:,:), &! total cloud fraction - cldc(:,:), &! convective cloud fraction - cmfdqr(:,:), &! rate of production of convective precip - evapc(:,:), &! Evaporation rate of convective precipitation - conicw(:,:), &! convective cloud water - cwat(:,:), &! cloud water amount - precs(:,:), &! rate of production of stratiform precip - evaps(:,:), &! rate of evaporation of precip - cldvcu(:,:), &! Convective precipitation area at the top interface of each layer - cldvst(:,:), &! Stratiform precipitation area at the top interface of each layer - dlf(:,:), &! Detrainment of convective condensate [kg/kg/s] - deltat, &! time step - tracer(:,:) ! 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(:,:) - integer, intent(in) :: ncol - real(r8), intent(in) :: scavcoef(:,:) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - integer, intent(in) :: pver - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - real(r8), intent(out) ::& - scavt(:,:), &! scavenging tend - iscavt(:,:), &! incloud scavenging tends - fracis(:,:) ! fraction of species not scavenged - - ! Setting is_strat_cloudborne=.true. indicates that tracer is stratiform-cloudborne aerosol. - ! This is only used by MAM code. The optional args qqcw and f_act_conv are not referenced - ! in this case. - ! Setting is_strat_cloudborne=.false. is being used to indicate that the tracers are the - ! interstitial modal aerosols. In this case the optional qqcw (the cloud borne mixing ratio - ! corresponding to the interstitial aerosol) must be provided, as well as the optional f_act_conv. - logical, intent(in), optional :: is_strat_cloudborne - real(r8), intent(in), optional :: qqcw(:,:) - real(r8), intent(in), optional :: f_act_conv(:,:) - - real(r8), intent(in), optional :: sol_facti_in(:,:) ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factic_in(:,:) ! sol_facti_in for convective clouds - - - real(r8), intent(out), optional :: icscavt(:,:) ! incloud, convective - real(r8), intent(out), optional :: isscavt(:,:) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(:,:) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(:,:) ! below cloud, stratiform - - ! Setting convproc_do_aer=.true. removes the resuspension term from bcscavt and - ! bsscavt and returns those terms as rcscavt and rsscavt respectively. - logical, intent(in), optional :: convproc_do_aer - real(r8), intent(out), optional :: rcscavt(:,:) ! resuspension, convective - real(r8), intent(out), optional :: rsscavt(:,:) ! resuspension, stratiform - logical, intent(in), optional :: convproc_do_evaprain_atonce_in - real(r8), intent(in), optional :: bergso_in(:,:) - - ! local variables - - integer :: i, k - logical :: out_resuspension - - real(r8) :: clds(ncol) ! stratiform cloud fraction - real(r8) :: fracev(ncol) ! fraction of precip from above that is evaporating - real(r8) :: fracev_cu(ncol) ! Fraction of convective precip from above that is evaporating - real(r8) :: fracp(ncol) ! fraction of cloud water converted to precip - real(r8) :: pdog(ncol) ! work variable (pdel/gravit) - real(r8) :: rpdog(ncol) ! work variable (gravit/pdel) - real(r8) :: precabc(ncol) ! conv precip from above (work array) - real(r8) :: precabs(ncol) ! strat precip from above (work array) - real(r8) :: rat(ncol) ! ratio of amount available to amount removed - real(r8) :: scavab(ncol) ! scavenged tracer flux from above (work array) - real(r8) :: scavabc(ncol) ! scavenged tracer flux from above (work array) - real(r8) :: srcc(ncol) ! tend for convective rain - real(r8) :: srcs(ncol) ! tend for stratiform rain - real(r8) :: srct(ncol) ! work variable - - real(r8) :: fins(ncol) ! fraction of rem. rate by strat rain - real(r8) :: finc(ncol) ! fraction of rem. rate by conv. rain - real(r8) :: conv_scav_ic(ncol) ! convective scavenging incloud - real(r8) :: conv_scav_bc(ncol) ! convective scavenging below cloud - real(r8) :: st_scav_ic(ncol) ! stratiform scavenging incloud - real(r8) :: st_scav_bc(ncol) ! stratiform scavenging below cloud - - real(r8) :: odds(ncol) ! limit on removal rate (proportional to prec) - real(r8) :: dblchek(ncol) - logical :: found - - real(r8) :: trac_qqcw(ncol) - real(r8) :: tracer_incu(ncol) - real(r8) :: tracer_mean(ncol) - - ! 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. - - real(r8) :: sol_facti(ncol,pver) ! in cloud fraction of aerosol scavenged - real(r8) :: sol_factb(ncol,pver) ! below cloud fraction of aerosol scavenged - real(r8) :: sol_factic(ncol,pver) ! in cloud fraction of aerosol scavenged for convective clouds - - real(r8) :: rdeltat - logical :: convproc_do_evaprain_atonce - - ! ------------------------------------------------------------------------ - - errmsg = '' - errflg = 0 - - if (present(convproc_do_evaprain_atonce_in)) then - convproc_do_evaprain_atonce = convproc_do_evaprain_atonce_in - else - convproc_do_evaprain_atonce = .false. - endif - - ! default (if other sol_facts aren't in call, set all to required sol_fact) - sol_facti = sol_fact - sol_factb = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - - sol_factic = sol_facti - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - - ! Determine whether resuspension fields are output. - out_resuspension = .false. - if (present(convproc_do_aer)) then - if (convproc_do_aer) then - if (present(bcscavt) .and. present(bsscavt) .and. & - present(rcscavt) .and. present(rsscavt) ) then - out_resuspension = .true. - else - errmsg = 'wetdepa_v2: bcscavt, bsscavt, rcscavt, rsscavt'// & - ' must be present when convproc_do_aero true' - errflg = 1 - return - end if - end if - end if - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! for both convective and stratiform clouds, - ! the fraction of cloud water converted to precip defines - ! the amount of tracer which is pulled out. - - precabs(:ncol) = 0.0_r8 - precabc(:ncol) = 0.0_r8 - scavab(:ncol) = 0.0_r8 - scavabc(:ncol) = 0.0_r8 - - do k = 1, pver - do i = 1, ncol - - clds(i) = cldt(i,k) - cldc(i,k) - pdog(i) = pdel(i,k)/gravit - rpdog(i) = gravit/pdel(i,k) - rdeltat = 1.0_r8/deltat - - ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above - ! which evaporates within this layer - fracev(i) = evaps(i,k)*pdog(i) & - /max(1.e-12_r8,precabs(i)) - - ! If resuspending aerosol only when all the rain has totally - ! evaporated then zero out any aerosol tendency for partial - ! evaporation. - if (convproc_do_evaprain_atonce .and. (evaps(i,k)*pdog(i)/=precabs(i))) then - fracev(i) = 0._r8 - end if - - ! trap to ensure reasonable ratio bounds - fracev(i) = max(0._r8,min(1._r8,fracev(i))) - - ! Same as above but convective precipitation part - fracev_cu(i) = evapc(i,k)*pdog(i)/max(1.e-12_r8,precabc(i)) - fracev_cu(i) = max(0._r8,min(1._r8,fracev_cu(i))) - - ! ****************** Convection *************************** - ! - ! set odds proportional to fraction of the grid box that is swept by the - ! precipitation =precabc/rhoh20*(area of sphere projected on plane - ! /volume of sphere)*deltat - ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, - ! unless the fraction of the area that is cloud is less than odds, in which - ! case use the cloud fraction (assumes precabs is in kg/m2/s) - ! is really: precabs*3/4/1000./1e-3*deltat - ! here I use .1 from Balkanski - ! - ! use a local rate of convective rain production for incloud scav - ! - ! Fraction of convective cloud water converted to rain. This version is used - ! in 2 of the 3 branches below before fracp is reused in the stratiform calc. - ! NB: In below formula for fracp conicw is a LWC/IWC that has already - ! precipitated out, i.e., conicw does not contain precipitation - - fracp(i) = cmfdqr(i,k)*deltat / & - max( 1.e-12_r8, cldc(i,k)*conicw(i,k) + (cmfdqr(i,k)+dlf(i,k))*deltat ) - fracp(i) = max( min( 1._r8, fracp(i)), 0._r8 ) - - if ( present(is_strat_cloudborne) ) then - - if ( is_strat_cloudborne ) then - - ! convective scavenging - - conv_scav_ic(i) = 0._r8 - - conv_scav_bc(i) = 0._r8 - - ! stratiform scavenging - if (convproc_do_evaprain_atonce .and. present(bergso_in)) then - fracp(i) = (precs(i,k)-bergso_in(i,k))*deltat / & - max( 1.e-12_r8, cwat(i,k) + precs(i,k)*deltat ) - else - fracp(i) = precs(i,k)*deltat / & - max( 1.e-12_r8, cwat(i,k) + precs(i,k)*deltat ) - endif - - fracp(i) = max( 0._r8, min(1._r8, fracp(i)) ) - - st_scav_ic(i) = sol_facti(i,k) *fracp(i)*tracer(i,k)*rdeltat - - st_scav_bc(i) = 0._r8 - - else - - ! convective scavenging - - trac_qqcw(i) = min(qqcw(i,k), & - tracer(i,k)*( clds(i)/max( 0.01_r8, 1._r8-clds(i) ) ) ) - - tracer_incu(i) = f_act_conv(i,k)*(tracer(i,k) + trac_qqcw(i)) - - conv_scav_ic(i) = sol_factic(i,k)*cldc(i,k)*fracp(i)*tracer_incu(i)*rdeltat - - tracer_mean(i) = tracer(i,k)*(1._r8 - cldc(i,k)*f_act_conv(i,k)) - & - cldc(i,k)*f_act_conv(i,k)*trac_qqcw(i) - tracer_mean(i) = max(0._r8,tracer_mean(i)) - - odds(i) = precabc(i)/max(cldvcu(i,k),1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max(min(1._r8,odds(i)),0._r8) - conv_scav_bc(i) = sol_factb(i,k) *cldvcu(i,k)*odds(i)*tracer_mean(i)*rdeltat - - - ! stratiform scavenging - - st_scav_ic(i) = 0._r8 - - odds(i) = precabs(i)/max(cldvst(i,k),1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max(min(1._r8,odds(i)),0._r8) - st_scav_bc(i) = sol_factb(i,k) *cldvst(i,k)*odds(i)*tracer_mean(i)*rdeltat - - end if - - else - - ! convective scavenging - - conv_scav_ic(i) = sol_factic(i,k)*cldc(i,k)*fracp(i)*tracer(i,k)*rdeltat - - odds(i) = precabc(i)/max(cldvcu(i,k), 1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max( min(1._r8, odds(i)), 0._r8) - conv_scav_bc(i) = sol_factb(i,k)*cldvcu(i,k)*odds(i)*tracer(i,k)*rdeltat - - ! stratiform scavenging - - ! fracp is the fraction of cloud water converted to precip - ! NB: In below formula for fracp cwat is a LWC/IWC that has already - ! precipitated out, i.e., cwat does not contain precipitation - fracp(i) = precs(i,k)*deltat / & - max( 1.e-12_r8, cwat(i,k) + precs(i,k)*deltat ) - fracp(i) = max( 0._r8, min( 1._r8, fracp(i) ) ) - - ! assume the corresponding amnt of tracer is removed - st_scav_ic(i) = sol_facti(i,k)*clds(i)*fracp(i)*tracer(i,k)*rdeltat - - odds(i) = precabs(i)/max(cldvst(i,k),1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max(min(1._r8,odds(i)),0._r8) - st_scav_bc(i) =sol_factb(i,k)*(cldvst(i,k)*odds(i)) *tracer(i,k)*rdeltat - - end if - - ! total convective scavenging - srcc(i) = conv_scav_ic(i) + conv_scav_bc(i) - finc(i) = conv_scav_ic(i)/(srcc(i) + 1.e-36_r8) - - ! total stratiform scavenging - srcs(i) = st_scav_ic(i) + st_scav_bc(i) - fins(i) = st_scav_ic(i)/(srcs(i) + 1.e-36_r8) - - ! make sure we dont take out more than is there - ! ratio of amount available to amount removed - rat(i) = tracer(i,k)/max(deltat*(srcc(i)+srcs(i)),1.e-36_r8) - if (rat(i)<1._r8) then - srcs(i) = srcs(i)*rat(i) - srcc(i) = srcc(i)*rat(i) - endif - srct(i) = (srcc(i)+srcs(i))*omsm - - - ! fraction that is not removed within the cloud - ! (assumed to be interstitial, and subject to convective transport) - fracp(i) = deltat*srct(i)/max(cldvst(i,k)*tracer(i,k),1.e-36_r8) ! amount removed - fracp(i) = max(0._r8,min(1._r8,fracp(i))) - fracis(i,k) = 1._r8 - fracp(i) - - ! 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))*rpdog(i) - iscavt(i,k) = -(srcc(i)*finc(i) + srcs(i)*fins(i))*omsm - - if ( present(icscavt) ) icscavt(i,k) = -(srcc(i)*finc(i)) * omsm - if ( present(isscavt) ) isscavt(i,k) = -(srcs(i)*fins(i)) * omsm - - if (.not. out_resuspension) then - if (present(bcscavt)) bcscavt(i,k) = -(srcc(i) * (1-finc(i))) * omsm + & - fracev_cu(i)*scavabc(i)*rpdog(i) - - if (present(bsscavt)) bsscavt(i,k) = -(srcs(i) * (1-fins(i))) * omsm + & - fracev(i)*scavab(i)*rpdog(i) - else - bcscavt(i,k) = -(srcc(i) * (1-finc(i))) * omsm - rcscavt(i,k) = fracev_cu(i)*scavabc(i)*rpdog(i) - - bsscavt(i,k) = -(srcs(i) * (1-fins(i))) * omsm - rsscavt(i,k) = fracev(i)*scavab(i)*rpdog(i) - end if - - 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(i)*pdog(i) - precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdog(i) - scavabc(i) = scavabc(i)*(1-fracev_cu(i)) + srcc(i)*pdog(i) - precabc(i) = precabc(i) + (cmfdqr(i,k) - evapc(i,k))*pdog(i) - - end do ! End of i = 1, ncol - -#ifdef DEBUG - ! only check in debug mode which aborts when larger negative values are found - found = .false. - do i = 1,ncol - ! catch the larger negative values, ignore insignificant small negaive values - if (dblchek(i) < -1.e-10_r8) then - found = .true. - endif - end do - - if (found) then - errmsg = 'wetdapa_v2: negative values found' - errflg = 1 - return - end if -#endif - - end do ! End of k = 1, pver - -end subroutine wetdepa_v2 - - -!============================================================================== - -! This is the frozen CAM4 version of wetdepa. - - - subroutine wetdepa_v1( t, pdel, & - cldt, cmfdqr, conicw, precs, & - evaps, cwat, tracer, deltat, & - scavt, iscavt, cldv, fracis, sol_fact, ncol, & - scavcoef, tmelt, gravit, pver, errmsg, errflg, & - icscavt, isscavt, bcscavt, bsscavt, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging code for very soluble aerosols - ! - ! Author: P. Rasch - ! Modified by T. Bond 3/2003 to track different removals - !----------------------------------------------------------------------- - - implicit none - - real(r8), intent(in) ::& - t(:,:), &! temperature - pdel(:,:), &! pressure thikness - cldt(:,:), &! total cloud fraction - cmfdqr(:,:), &! rate of production of convective precip - conicw(:,:), &! convective cloud water - cwat(:,:), &! cloud water amount - precs(:,:), &! rate of production of stratiform precip - evaps(:,:), &! rate of evaporation of precip - cldv(:,:), &! total cloud fraction - deltat, &! time step - tracer(:,:) ! 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) - 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(:,:) ! sol_facti_in for convective clouds - real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds - real(r8), intent(in) :: scavcoef(:,:) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - - integer, intent(in) :: ncol - integer, intent(in) :: pver - real(r8), intent(in) :: tmelt ! freezing point of water (K) - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real(r8), intent(out) ::& - scavt(:,:), &! scavenging tend - iscavt(:,:), &! incloud scavenging tends - fracis(:,:) ! fraction of species not scavenged - - real(r8), intent(out), optional :: icscavt(:,:) ! incloud, convective - real(r8), intent(out), optional :: isscavt(:,:) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(:,:) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(:,:) ! below cloud, stratiform - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) fracev(ncol) ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) precabc(ncol) ! conv precip from above (work array) - real(r8) precabs(ncol) ! strat precip from above (work array) - real(r8) rat(ncol) ! ratio of amount available to amount removed - real(r8) scavab(ncol) ! scavenged tracer flux from above (work array) - real(r8) scavabc(ncol) ! scavenged tracer flux from above (work array) - real(r8) srcc ! tend for convective rain - real(r8) srcs ! tend for stratiform rain - real(r8) srct(ncol) ! work variable - real(r8) tracab(ncol) ! column integrated tracer amount - - real(r8) fins ! fraction of rem. rate by strat rain - real(r8) finc ! fraction of rem. rate by conv. rain - real(r8) srcs1 ! work variable - real(r8) srcs2 ! work variable - real(r8) tc ! temp in celcius - real(r8) weight ! fraction of condensate which is ice - real(r8) cldmabs(ncol) ! maximum cloud at or above this level - real(r8) cldmabc(ncol) ! maximum cloud at or above this level - real(r8) odds ! limit on removal rate (proportional to prec) - real(r8) dblchek(ncol) - logical :: found - - 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(ncol,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. - - ! ------------------------------------------------------------------------ - errmsg = '' - errflg = 0 - - ! 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 - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! 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,ncol - precabs(i) = 0 - precabc(i) = 0 - scavab(i) = 0 - scavabc(i) = 0 - tracab(i) = 0 - cldmabs(i) = 0 - cldmabc(i) = 0 - end do - - do k = 1,pver - 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 - weight = 0._r8 ! assume no ice - - ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above - ! which evaporates within this layer - fracev(i) = evaps(i,k)*pdel(i,k)/gravit & - /max(1.e-12_r8,precabs(i)) - - ! trap to ensure reasonable ratio bounds - fracev(i) = max(0._r8,min(1._r8,fracev(i))) - - ! ****************** Convection *************************** - ! now do the convective scavenging - - ! set odds proportional to fraction of the grid box that is swept by the - ! precipitation =precabc/rhoh20*(area of sphere projected on plane - ! /volume of sphere)*deltat - ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, - ! unless the fraction of the area that is cloud is less than odds, in which - ! case use the cloud fraction (assumes precabs is in kg/m2/s) - ! is really: precabs*3/4/1000./1e-3*deltat - ! here I use .1 from Balkanski - ! - ! use a local rate of convective rain production for incloud scav - !odds=max(min(1._r8, & - ! cmfdqr(i,k)*pdel(i,k)/gravit*0.1_r8*deltat),0._r8) - !++mcb -- change cldc to cldt; change cldt to cldv (9/17/96) - ! srcs1 = cldt(i,k)*odds*tracer(i,k)*(1.-weight) & - ! srcs1 = cldv(i,k)*odds*tracer(i,k)*(1.-weight) & - !srcs1 = cldc(i,k)*odds*tracer(i,k)*(1.-weight) & - ! /deltat - - ! fraction of convective cloud water converted to rain - fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,conicw(i,k)) - ! note cmfdrq can be negative from evap of rain, so constrain it - fracp = max(min(1._r8,fracp),0._r8) - ! remove that amount from within the convective area -! srcs1 = cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat ! liquid only -! srcs1 = cldc(i,k)*fracp*tracer(i,k)/deltat ! any condensation -! srcs1 = 0. - srcs1 = sol_factic(i,k)*cldt(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factiic*cldt(i,k)*fracp*tracer(i,k)*(weight)/deltat ! ice - - - !--mcb - - ! scavenge below cloud - - ! cldmabc(i) = max(cldc(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldt(i,k),cldmabc(i)) - cldmabc(i) = max(cldv(i,k),cldmabc(i)) - cldmabc(i) = cldv(i,k) - - 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 - !Note that using the temperature-determined weight doesn't make much sense here - - - srcc = srcs1 + srcs2 ! convective tend by both processes - finc = srcs1/(srcc + 1.e-36_r8) ! fraction in-cloud - - ! ****************** Stratiform *********************** - ! now do the stratiform scavenging - - ! incloud scavenging - - ! fracp is the fraction of cloud water converted to precip - fracp = precs(i,k)*deltat/max(cwat(i,k),1.e-12_r8) - 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 - srcs1 = sol_facti*cldt(i,k)*fracp*tracer(i,k)/deltat*(1._r8-weight) & ! liquid - + sol_factii*cldt(i,k)*fracp*tracer(i,k)/deltat*(weight) ! ice - - - ! below cloud scavenging - -! volume undergoing below cloud scavenging - cldmabs(i) = cldv(i,k) ! precipitating volume -! cldmabs(i) = cldt(i,k) ! local cloud volume - - 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 - !Note that using the temperature-determined weight doesn't make much sense here - - - srcs = srcs1 + srcs2 ! total stratiform scavenging - fins=srcs1/(srcs + 1.e-36_r8) ! fraction taken by incloud processes - - ! make sure we dont take out more than is there - ! ratio of amount available to amount removed - rat(i) = tracer(i,k)/max(deltat*(srcc+srcs),1.e-36_r8) - if (rat(i) < 1._r8) then - srcs = srcs*rat(i) - srcc = srcc*rat(i) - endif - srct(i) = (srcc+srcs)*omsm - - - ! fraction that is not removed within the cloud - ! (assumed to be interstitial, and subject to convective transport) - fracp = deltat*srct(i)/max(cldmabs(i)*tracer(i,k),1.e-36_r8) ! amount removed - fracp = max(0._r8,min(1._r8,fracp)) - fracis(i,k) = 1._r8 - fracp - - ! tend is all tracer removed by scavenging, plus all re-appearing from evaporation above - scavt(i,k) = -srct(i) + fracev(i)*scavab(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 - if ( present(bcscavt) ) bcscavt(i,k) = -(srcc * (1-finc)) * omsm - if ( present(bsscavt) ) bsscavt(i,k) = -(srcs * (1-fins)) * omsm + & - fracev(i)*scavab(i)*gravit/pdel(i,k) - - 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) + srcc*pdel(i,k)/gravit - precabc(i) = precabc(i) + (cmfdqr(i,k))*pdel(i,k)/gravit - tracab(i) = tracab(i) + tracer(i,k)*pdel(i,k)/gravit - - end do - -#ifdef DEBUG - ! only check in debug mode which aborts when larger negative values are found - found = .false. - do i = 1,ncol - ! catch the larger negative values, ignore insignificant small negaive values - if (dblchek(i) < -1.e-10_r8) then - found = .true. - endif - end do - - if (found) then - errmsg = 'wetdapa_v1: negative values found' - errflg = 1 - return - end if -#endif - - end do - - end subroutine wetdepa_v1 - -!############################################################################## - - -!############################################################################## - -! below cloud impaction scavenging coefs -subroutine get_bcscavcoefs( m, ncol, pver, isprx, diam_wet, scavcoefnum, scavcoefvol, aero_props ) - - integer,intent(in) :: m, ncol, pver - logical,intent(in):: isprx(:,:) - real(r8), intent(in) :: diam_wet(:,:) - real(r8), intent(out) :: scavcoefnum(:,:), scavcoefvol(:,:) - class(aerosol_properties), intent(in) :: aero_props - - integer i, k, jgrow - real(r8) dumdgratio, xgrow, dumfhi, dumflo, scavimpvol, scavimpnum - - do k = 1, pver - do i = 1, ncol - - ! do only if no precip - if ( isprx(i,k) .and. diam_wet(i,k)>0.0_r8) then - ! - ! interpolate table values using log of (actual-wet-size)/(base-dry-size) - - dumdgratio = diam_wet(i,k)/aero_props%scav_diam(m) - if ((dumdgratio >= 0.99_r8) .and. (dumdgratio <= 1.01_r8)) then - scavimpvol = scavimptblvol(0,m) - scavimpnum = scavimptblnum(0,m) - else - xgrow = log( dumdgratio ) / dlndg_nimptblgrow - jgrow = int( xgrow ) - if (xgrow < 0._r8) jgrow = jgrow - 1 - if (jgrow < nimptblgrow_mind) then - jgrow = nimptblgrow_mind - xgrow = jgrow - else - jgrow = min( jgrow, nimptblgrow_maxd-1 ) - end if - - dumfhi = xgrow - jgrow - dumflo = 1._r8 - dumfhi - - scavimpvol = dumflo*scavimptblvol(jgrow,m) + & - dumfhi*scavimptblvol(jgrow+1,m) - scavimpnum = dumflo*scavimptblnum(jgrow,m) + & - dumfhi*scavimptblnum(jgrow+1,m) - - end if - - ! impaction scavenging removal amount for volume - scavcoefvol(i,k) = exp( scavimpvol ) - ! impaction scavenging removal amount to number - scavcoefnum(i,k) = exp( scavimpnum ) - - else - scavcoefvol(i,k) = 0._r8 - scavcoefnum(i,k) = 0._r8 - end if - - end do - end do - -end subroutine get_bcscavcoefs - -!############################################################################## - -!------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ -subroutine init_bcscavcoef( aero_props, pi, boltz_cgs, rgas_cgs, & - errmsg, errflg ) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Computes lookup table for aerosol impaction/interception scavenging rates - ! - ! Authors: R. Easter - ! Simone Tilmes Nov 2021 - ! added modifications for bin model, assuming sigma = 1. - ! - !----------------------------------------------------------------------- - - class(aerosol_properties), intent(in) :: aero_props - real(r8), intent(in) :: pi ! ratio of circle circumference to diameter - real(r8), intent(in) :: boltz_cgs ! Boltzmann's constant (erg/K) - real(r8), intent(in) :: rgas_cgs ! universal gas constant (erg/mol/K) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - integer nnfit_maxd - parameter (nnfit_maxd=27) - - integer m, jgrow, nnfit - integer astat - - real(r8) dg0, dg0_cgs, press, dg0_base, & - rhodryaero, rhowetaero, rhowetaero_cgs, & - scavratenum, scavratevol, logsig, & - temp, wetdiaratio, wetvolratio - - real(r8) :: xxfitnum(1,nnfit_maxd), yyfitnum(nnfit_maxd) - real(r8) :: xxfitvol(1,nnfit_maxd), yyfitvol(nnfit_maxd) - - character(len=*), parameter :: subname = 'wetdep::init_bcscavcoef' - - errmsg = '' - errflg = 0 - - allocate(scavimptblnum(nimptblgrow_mind:nimptblgrow_maxd, aero_props%nbins()), stat=astat) - if (astat/=0) then - errmsg = subname//' : not able to allocate scavimptblnum array' - errflg = 1 - return - end if - allocate(scavimptblvol(nimptblgrow_mind:nimptblgrow_maxd, aero_props%nbins()), stat=astat) - if (astat/=0) then - errmsg = subname//' : not able to allocate scavimptblvol array' - errflg = 1 - return - end if - scavimptblnum = nan - scavimptblvol = nan - - dlndg_nimptblgrow = log( 1.25_r8 ) - - ! bin model: main loop over aerosol bins - - modeloop: do m = 1, aero_props%nbins() - - ! for setting up the lookup table, use the dry density of the first species - ! -- assume the first species of the mode/bin is the dominate species - call aero_props%get(m,1,density=rhodryaero) - - dg0_base = aero_props%scav_diam(m) - - logsig = aero_props%alogsig(m) - - growloop: do jgrow = nimptblgrow_mind, nimptblgrow_maxd - - wetdiaratio = exp( jgrow*dlndg_nimptblgrow ) - dg0 = dg0_base*wetdiaratio - - wetvolratio = exp( jgrow*dlndg_nimptblgrow*3._r8 ) - rhowetaero = 1.0_r8 + (rhodryaero-1.0_r8)/wetvolratio - rhowetaero = min( rhowetaero, rhodryaero ) - - ! - ! compute impaction scavenging rates at 1 temp-press pair and save - ! - nnfit = 0 - - temp = 273.16_r8 - press = 0.75e6_r8 ! dynes/cm2 - rhowetaero = rhodryaero - - dg0_cgs = dg0*1.0e2_r8 ! m to cm - - rhowetaero_cgs = rhowetaero*1.0e-3_r8 ! kg/m3 to g/cm3 - - call calc_1_impact_rate( & - dg0_cgs, logsig, rhowetaero_cgs, temp, press, & - scavratenum, scavratevol, & - pi, boltz_cgs, rgas_cgs, errmsg, errflg ) - if (errflg /= 0) return - - nnfit = nnfit + 1 - if (nnfit > nnfit_maxd) then - errmsg = subname//' : nnfit > nnfit_maxd' - errflg = 1 - return - end if - - xxfitnum(1,nnfit) = 1._r8 - yyfitnum(nnfit) = log( scavratenum ) - - xxfitvol(1,nnfit) = 1._r8 - yyfitvol(nnfit) = log( scavratevol ) - - !depends on both bins and different species - scavimptblnum(jgrow,m) = yyfitnum(1) - scavimptblvol(jgrow,m) = yyfitvol(1) - - enddo growloop - enddo modeloop - -contains - - !=============================================================================== - subroutine calc_1_impact_rate( & - dg0, logsig, rhoaero, temp, press, & - scavratenum, scavratevol, & - pi, boltz_cgs, rgas, errmsg, errflg ) - ! - ! routine computes a single impaction scavenging rate - ! for precipitation rate of 1 mm/h - ! - ! dg0 = geometric mean diameter of aerosol number size distrib. (cm) - ! sigmag = geometric standard deviation of size distrib. - ! rhoaero = density of aerosol particles (g/cm^3) - ! temp = temperature (K) - ! press = pressure (dyne/cm^2) - ! scavratenum = number scavenging rate (1/h) - ! scavratevol = volume or mass scavenging rate (1/h) - ! errmsg/errflg = error message and flag (returned on error) - ! - - implicit none - - ! subr. parameters - real(r8), intent(in) :: dg0, logsig, rhoaero, temp, press - real(r8), intent(out) :: scavratenum, scavratevol - real(r8), intent(in) :: pi ! ratio of circle circumference to diameter - real(r8), intent(in) :: boltz_cgs ! Boltzmann's constant (erg/K) - real(r8), intent(in) :: rgas ! universal gas constant (erg/mol/K) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - integer nrainsvmax - parameter (nrainsvmax=50) - real(r8) rrainsv(nrainsvmax), xnumrainsv(nrainsvmax),& - vfallrainsv(nrainsvmax) - - integer naerosvmax - parameter (naerosvmax=51) - real(r8) aaerosv(naerosvmax), & - ynumaerosv(naerosvmax), yvolaerosv(naerosvmax) - - integer i, ja, jr, na, nr - real(r8) a, aerodiffus, aeromass, ag0, airdynvisc, airkinvisc - real(r8) anumsum, avolsum, cair, chi - real(r8) d, dr, dum, dumfuchs, dx - real(r8) ebrown, eimpact, eintercept, etotal, freepath - real(r8) precip, precipmmhr, precipsum - real(r8) r, rainsweepout, reynolds, rhi, rhoair, rlo, rnumsum - real(r8) scavsumnum, scavsumnumbb - real(r8) scavsumvol, scavsumvolbb - real(r8) schmidt, sqrtreynolds, sstar, stokes, sx - real(r8) taurelax, vfall, vfallstp - real(r8) x, xg0, xg3, xhi, xlo, xmuwaterair - - errmsg = '' - errflg = 0 - - rlo = .005_r8 - rhi = .250_r8 - dr = 0.005_r8 - nr = 1 + nint( (rhi-rlo)/dr ) - if (nr > nrainsvmax) then - errmsg = subname//' : nr > nrainsvmax' - errflg = 1 - return - end if - - precipmmhr = 1.0_r8 - precip = precipmmhr/36000._r8 - - ag0 = dg0/2._r8 - sx = logsig - xg0 = log( ag0 ) - xg3 = xg0 + 3._r8*sx*sx - - xlo = xg3 - 4._r8*sx - xhi = xg3 + 4._r8*sx - dx = 0.2_r8*sx - - dx = max( 0.2_r8*sx, 0.01_r8 ) - xlo = xg3 - max( 4._r8*sx, 2._r8*dx ) - xhi = xg3 + max( 4._r8*sx, 2._r8*dx ) - - na = 1 + nint( (xhi-xlo)/dx ) - if (na > naerosvmax) then - errmsg = subname//' : na > naerosvmax' - errflg = 1 - return - end if - - ! air molar density - cair = press/(rgas*temp) - ! air mass density - rhoair = 28.966_r8*cair - ! molecular freepath - freepath = 2.8052e-10_r8/cair - ! air dynamic viscosity - airdynvisc = 1.8325e-4_r8 * (416.16_r8/(temp+120._r8)) * & - ((temp/296.16_r8)**1.5_r8) - ! air kinemaic viscosity - airkinvisc = airdynvisc/rhoair - ! ratio of water viscosity to air viscosity (from Slinn) - xmuwaterair = 60.0_r8 - - ! - ! compute rain drop number concentrations - ! rrainsv = raindrop radius (cm) - ! xnumrainsv = raindrop number concentration (#/cm^3) - ! (number in the bin, not number density) - ! vfallrainsv = fall velocity (cm/s) - ! - precipsum = 0._r8 - do i = 1, nr - r = rlo + (i-1)*dr - rrainsv(i) = r - xnumrainsv(i) = exp( -r/2.7e-2_r8 ) - - d = 2._r8*r - if (d <= 0.007_r8) then - vfallstp = 2.88e5_r8 * d**2._r8 - else if (d <= 0.025_r8) then - vfallstp = 2.8008e4_r8 * d**1.528_r8 - else if (d <= 0.1_r8) then - vfallstp = 4104.9_r8 * d**1.008_r8 - else if (d <= 0.25_r8) then - vfallstp = 1812.1_r8 * d**0.638_r8 - else - vfallstp = 1069.8_r8 * d**0.235_r8 - end if - - vfall = vfallstp * sqrt(1.204e-3_r8/rhoair) - vfallrainsv(i) = vfall - precipsum = precipsum + vfall*(r**3)*xnumrainsv(i) - end do - precipsum = precipsum*pi*1.333333_r8 - - rnumsum = 0._r8 - do i = 1, nr - xnumrainsv(i) = xnumrainsv(i)*(precip/precipsum) - rnumsum = rnumsum + xnumrainsv(i) - end do - - ! - ! compute aerosol concentrations - ! aaerosv = particle radius (cm) - ! fnumaerosv = fraction of total number in the bin (--) - ! fvolaerosv = fraction of total volume in the bin (--) - ! - anumsum = 0._r8 - avolsum = 0._r8 - do i = 1, na - x = xlo + (i-1)*dx - a = exp( x ) - aaerosv(i) = a - dum = (x - xg0)/sx - ynumaerosv(i) = exp( -0.5_r8*dum*dum ) - yvolaerosv(i) = ynumaerosv(i)*1.3333_r8*pi*a*a*a - anumsum = anumsum + ynumaerosv(i) - avolsum = avolsum + yvolaerosv(i) - end do - - do i = 1, na - ynumaerosv(i) = ynumaerosv(i)/anumsum - yvolaerosv(i) = yvolaerosv(i)/avolsum - end do - - ! - ! compute scavenging - ! - scavsumnum = 0._r8 - scavsumvol = 0._r8 - ! - ! outer loop for rain drop radius - ! - jr_loop: do jr = 1, nr - - r = rrainsv(jr) - vfall = vfallrainsv(jr) - - reynolds = r * vfall / airkinvisc - sqrtreynolds = sqrt( reynolds ) - - ! - ! inner loop for aerosol particle radius - ! - scavsumnumbb = 0._r8 - scavsumvolbb = 0._r8 - - ja_loop: do ja = 1, na - - a = aaerosv(ja) - - chi = a/r - - dum = freepath/a - dumfuchs = 1._r8 + 1.246_r8*dum + 0.42_r8*dum*exp(-0.87_r8/dum) - taurelax = 2._r8*rhoaero*a*a*dumfuchs/(9._r8*rhoair*airkinvisc) - - aeromass = 4._r8*pi*a*a*a*rhoaero/3._r8 - aerodiffus = boltz_cgs*temp*taurelax/aeromass - - schmidt = airkinvisc/aerodiffus - stokes = vfall*taurelax/r - - ebrown = 4._r8*(1._r8 + 0.4_r8*sqrtreynolds*(schmidt**0.3333333_r8)) / & - (reynolds*schmidt) - - dum = (1._r8 + 2._r8*xmuwaterair*chi) / & - (1._r8 + xmuwaterair/sqrtreynolds) - eintercept = 4._r8*chi*(chi + dum) - - dum = log( 1._r8 + reynolds ) - sstar = (1.2_r8 + dum/12._r8) / (1._r8 + dum) - eimpact = 0._r8 - if (stokes > sstar) then - dum = stokes - sstar - eimpact = (dum/(dum+0.6666667_r8)) ** 1.5_r8 - end if - - etotal = ebrown + eintercept + eimpact - etotal = min( etotal, 1.0_r8 ) - - rainsweepout = xnumrainsv(jr)*4._r8*pi*r*r*vfall - - scavsumnumbb = scavsumnumbb + rainsweepout*etotal*ynumaerosv(ja) - scavsumvolbb = scavsumvolbb + rainsweepout*etotal*yvolaerosv(ja) - - enddo ja_loop - - scavsumnum = scavsumnum + scavsumnumbb - scavsumvol = scavsumvol + scavsumvolbb - - enddo jr_loop - - scavratenum = scavsumnum*3600._r8 - scavratevol = scavsumvol*3600._r8 - - end subroutine calc_1_impact_rate - -end subroutine init_bcscavcoef - -!############################################################################## - -end module wetdep diff --git a/src/chemistry/modal_aero/modal_aero_coag.F90 b/src/chemistry/modal_aero/modal_aero_coag.F90 deleted file mode 100644 index 3a2386a647..0000000000 --- a/src/chemistry/modal_aero/modal_aero_coag.F90 +++ /dev/null @@ -1,2686 +0,0 @@ -! modal_aero_coag.F90 - - -!---------------------------------------------------------------------- -!BOP -! -! !MODULE: modal_aero_coag --- modal aerosol coagulation -! -! !INTERFACE: - module modal_aero_coag - -! !USES: - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - save - -! !PUBLIC MEMBER FUNCTIONS: - public modal_aero_coag_run, modal_aero_coag_init - -! !PUBLIC DATA MEMBERS: - integer, protected, public :: pair_option_acoag = 0 -! specifies pairs of modes for which coagulation is calculated -! (set by modal_aero_coag_init from the host; default 0 = do no coag) -! 1 -- [aitken-->accum] -! 2 -- [aitken-->accum], and [pcarbon-->accum] -! 3 -- [aitken-->accum], [pcarbon-->accum], -! and [aitken-->pcarbon--(aging)-->accum] -! other -- do no coag - - integer, parameter, public :: maxpair_acoag = 10 - integer, protected, public :: maxspec_acoag != nspec_max - -! coagulation-pair tables (host constituent-index space), handed to -! modal_aero_coag_init by the host wrapper (see modal_aero_coag_cam) - integer, protected, public :: npair_acoag = 0 - integer, protected, public :: modefrm_acoag(maxpair_acoag) - integer, protected, public :: modetoo_acoag(maxpair_acoag) - integer, protected, public :: modetooeff_acoag(maxpair_acoag) - integer, protected, public :: nspecfrm_acoag(maxpair_acoag) - integer, allocatable, protected, public :: lspecfrm_acoag(:,:) - integer, allocatable, protected, public :: lspectoo_acoag(:,:) - - integer :: ip_aitacc, ip_aitpca, ip_pcaacc - real(r8), allocatable :: fac_m2v_aitage(:), fac_m2v_pcarbon(:) - -! mode metadata from the host (set by modal_aero_coag_init); names match -! the modal_aero_data originals so the science bodies are unchanged - integer :: ntot_amode - integer :: modeptr_accum, modeptr_aitken, modeptr_pcarbon - integer, allocatable :: numptr_amode(:), mprognum_amode(:), nspec_amode(:) - integer, allocatable :: lmassptr_amode(:,:) - real(r8), allocatable :: alnsg_amode(:), sigmag_amode(:) - -! host physical constants (set by modal_aero_coag_init; passed from the host -! rather than hardcoded so the values stay bit-identical with the host's) - real(r8) :: r_universal ! universal gas constant (J/K/kmol) - real(r8) :: p0 ! standard pressure (Pa) - real(r8) :: tmelt ! freezing point of water (K) - real(r8) :: boltz ! Boltzmann constant (J/K) - -! !DESCRIPTION: This module implements ... -! -! !REVISION HISTORY: -! -! RCE 07.04.13: Adapted from MIRAGE2 code -! -!EOP -!---------------------------------------------------------------------- -!BOC - -! list private module data here - -!EOC -!---------------------------------------------------------------------- - contains -!---------------------------------------------------------------------- -!BOP -! !ROUTINE: modal_aero_coag_run --- ... -! -! !INTERFACE: - subroutine modal_aero_coag_run( & - ncol, pver, top_lev, & - num_q, loffset, nstep, & - deltat_main, & - t, pmid, pdel, & - q, & - dgncur_a, dgncur_awet, & - wetdens_a, & - dqdt, dotend, & - errmsg, errflg ) - - -!---------------------------------------------------------------------- -! Authors: R. Easter -!---------------------------------------------------------------------- - -! !USES: - use modal_aero_gasaerexch, only: n_so4_monolayers_pcage - - implicit none - -! !PARAMETERS: - integer, intent(in) :: ncol ! number of columns in chunk - integer, intent(in) :: pver ! number of vertical levels - integer, intent(in) :: top_lev ! top level for modal aerosol calculations - integer, intent(in) :: num_q ! number of species in q/dqdt (= gas_pcnst) - integer, intent(in) :: loffset ! offset applied to modal aero "pointers" - integer, intent(in) :: nstep ! model step (for coagulation sub-cycling) - - real(r8), intent(in) :: deltat_main ! model timestep (s) - - real(r8), intent(in) :: t(:,:) ! (ncol,pver) temperature (K) - real(r8), intent(in) :: pmid(:,:) ! (ncol,pver) pressure at model levels (Pa) - real(r8), intent(in) :: pdel(:,:) ! (ncol,pver) pressure thickness of levels (Pa) - - real(r8), intent(inout) :: q(:,:,:) ! (ncol,pver,num_q) - ! tracer mixing ratio (TMR) array - ! *** MUST BE mol/mol-air or #/mol-air - ! *** updated in place: number changes are - ! direct assignments, and dqdt*deltat_main - ! is NOT bit-identical to the stored change - ! (deltatinv_main carries a 1+1e-15 guard), - ! so this scheme cannot be tendency-return - real(r8), intent(in) :: dgncur_a(:,:,:) ! (ncol,pver,ntot_amode) - ! dry geo. mean dia. (m) of number distrib. - real(r8), intent(in) :: dgncur_awet(:,:,:) - ! (ncol,pver,ntot_amode) - ! wet geo. mean dia. (m) of number distrib. - real(r8), intent(in) :: wetdens_a(:,:,:) ! (ncol,pver,ntot_amode) - ! density of wet aerosol (kg/m3) - real(r8), intent(out) :: dqdt(:,:,:) ! (ncol,pver,num_q) TMR "dq/dt" array - ! (diagnostic only; q is updated in place) - logical, intent(out) :: dotend(:) ! (num_q) identifies the species that - ! tendencies are computed for - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! !DESCRIPTION: -! computes changes due to coagulation involving -! aitken mode (modeptr_aitken) with accumulation mode (modeptr_accum) -! this version will -! compute changes to mass and number, but not to surface area -! calculates coagulation rate coefficients using either -! new CMAQ V4.6 fast method -! older cmaq slow method (direct gauss-hermite quadrature) -! -! !REVISION HISTORY: -! RCE 07.04.15: Adapted from MIRAGE2 code and CMAQ V4.6 code -! -!EOP -!---------------------------------------------------------------------- -!BOC - -! local variables - integer :: i, ipair, iq - integer :: idomode(ntot_amode), iselfcoagdone(ntot_amode) - integer :: jfreqcoag, jsoa - integer :: k - integer :: l, l2, lsfrm, lstoo, lunout - integer :: modefrm, modetoo, mait, macc, mpca - integer :: n, nfreqcoag - - - integer, save :: nerr = 0 ! number of errors for entire run - integer, save :: nerrmax = 9999 ! maximum number of errors before abort - integer, parameter :: ldiag1=-1, ldiag2=-1, ldiag3=-1 - - logical, parameter :: fastcoag_flag = .true. ! selects coag rate-coef method - - real(r8) :: aircon - real(r8) :: deltat, deltatinv_main - real(r8) :: dr_so4_monolayers_pcage - real(r8) :: dumexp, dumloss, dumprod - real(r8) :: dumsfc_frm_old, dumsfc_frm_new - real(r8) :: dum_m2v - real(r8) :: fac_volsfc_pcarbon - real(r8) :: lnsg_frm, lnsg_too - real(r8) :: sg_frm, sg_too - real(r8) :: tmpa, tmpb, tmpc, tmpf, tmpg, tmph, tmpn - real(r8) :: tmp1, tmp2 - real(r8) :: tmp_qold - real(r8) :: vol_core, vol_shell - real(r8) :: wetdens_frm, wetdens_too, wetdgnum_frm, wetdgnum_too - real(r8) :: xbetaij0, xbetaij2i, xbetaij2j, xbetaij3, & - xbetaii0, xbetaii2, xbetajj0, xbetajj2 - real(r8) :: xferamt, xferfracvol, xferfrac_pcage, xferfrac_max - real(r8) :: xnumbconc(ntot_amode) - real(r8) :: xnumbconcavg(ntot_amode), xnumbconcnew(ntot_amode) - real(r8) :: ybetaij0(maxpair_acoag), ybetaij3(maxpair_acoag) - real(r8) :: ybetaii0(maxpair_acoag), ybetajj0(maxpair_acoag) - -! begin - errmsg = ' ' - errflg = 0 - -! zero the tendency outputs up front: they are intent(out) and the caller -! uses them unconditionally, including on the bypass paths below - dotend(:) = .false. - dqdt(1:ncol,:,:) = 0.0_r8 - -! check if any coagulation pairs exist - if (npair_acoag <= 0) return - -!-------------------------------------------------------------------------------- -!!$ if (ldiag1 > 0) then -!!$ if (nstep <= 3) then -!!$ do i = 1, ncol -!!$ if (lonndx(i) /= 37) cycle -!!$ if (latndx(i) /= 23) cycle -!!$ if (nstep > 3) cycle -!!$ write( *, '(/a,i7,i5,2(2x,2i5))' ) & -!!$ '*** modal_aero_coag_sub -- nstep, iam, lat, lon, pcols, ncol =', & -!!$ nstep, iam, latndx(i), lonndx(i), pcols, ncol -!!$ end do -!!$ end if -!!$! if (ncol /= -999888777) return -!!$ if (nstep > 3) call endrun( 'modal_aero_coag_sub -- nstep>3 testing halt' ) -!!$ end if ! (ldiag1 > 0) -!-------------------------------------------------------------------------------- - - lunout = 6 - - -! -! determine if coagulation will be done on this time-step -! currently coagulation is done every 3 hours -! -! deltat = 3600.0*3.0 - deltat = deltat_main - nfreqcoag = max( 1, nint( deltat/deltat_main ) ) - jfreqcoag = nfreqcoag/2 - xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps - - if (nfreqcoag .gt. 1) then - if ( mod(nstep,nfreqcoag) .ne. jfreqcoag ) return - end if - -! -! set idomode -! - idomode(:) = 0 - do ipair = 1, npair_acoag - idomode(modefrm_acoag(ipair)) = 1 - idomode(modetoo_acoag(ipair)) = 1 - end do - -! -! other init -! - macc = modeptr_accum - mait = modeptr_aitken - mpca = modeptr_pcarbon - - if (mpca > 0 .and. mpca <= ntot_amode) then - ! use 1 mol (bi-)sulfate = 65 cm^3 --> 1 molecule = (4.76e-10 m)^3 - dr_so4_monolayers_pcage = n_so4_monolayers_pcage * 4.76e-10_r8 - fac_volsfc_pcarbon = exp( 2.5_r8*(alnsg_amode(mpca)**2) ) - end if - -! -! loop over levels and columns to calc the coagulation -! -! integrate coagulation changes over deltat = nfreqcoag*deltat_main -! then compute tendencies as -! dqdt = (q(t+deltat) - q(t))/deltat_main -! because tendencies are applied (in physics_update) over deltat_main -! - deltat = nfreqcoag*deltat_main - deltatinv_main = 1.0_r8/(deltat_main*(1.0_r8 + 1.0e-15_r8)) - -main_k: do k = top_lev, pver -main_i: do i = 1, ncol - -! air molar density (kmol/m3) - aircon = (pmid(i,k)/(r_universal*t(i,k))) - -! calculate number conc. (#/m3) for modes doing coagulation - do n = 1, ntot_amode - if (idomode(n) .gt. 0) then - xnumbconc(n) = q(i,k,numptr_amode(n)-loffset)*aircon - xnumbconc(n) = max( 0.0_r8, xnumbconc(n) ) - end if - iselfcoagdone(n) = 0 - end do - -! -! calculate coagulation rates for each pair -! -main_ipair1: do ipair = 1, npair_acoag - - modefrm = modefrm_acoag(ipair) - modetoo = modetoo_acoag(ipair) - -! -! compute coagulation rates using cmaq "fast" method -! (based on E. Whitby's approximation approach) -! here subr. arguments are all in mks unit -! - call getcoags_wrapper_f( & - t(i,k), pmid(i,k), & - dgncur_awet(i,k,modefrm), dgncur_awet(i,k,modetoo), & - sigmag_amode(modefrm), sigmag_amode(modetoo), & - alnsg_amode(modefrm), alnsg_amode(modetoo), & - wetdens_a(i,k,modefrm), wetdens_a(i,k,modetoo), & - xbetaij0, xbetaij2i, xbetaij2j, xbetaij3, & - xbetaii0, xbetaii2, xbetajj0, xbetajj2 ) - - -! test diagnostics begin -------------------------------------------- -!!$ if (ldiag2 > 0) then -!!$ if (nstep <= 3) then -!!$ if ((lonndx(i) == 37) .and. (latndx(i) == 23)) then -!!$ if ((mod(k-1,5) == 0) .or. (k>=23)) then -!!$ -!!$ wetdgnum_frm = dgncur_awet(i,k,modefrm) -!!$ wetdgnum_too = dgncur_awet(i,k,modetoo) -!!$ wetdens_frm = wetdens_a(i,k,modefrm) -!!$ wetdens_too = wetdens_a(i,k,modetoo) -!!$ sg_frm = sigmag_amode(modefrm) -!!$ sg_too = sigmag_amode(modetoo) -!!$ lnsg_frm = alnsg_amode(modefrm) -!!$ lnsg_too = alnsg_amode(modetoo) -!!$ -!!$ call getcoags_wrapper_f( & -!!$ t(i,k), pmid(i,k), & -!!$ wetdgnum_frm, wetdgnum_too, & -!!$ sg_frm, sg_too, & -!!$ lnsg_frm, lnsg_too, & -!!$ wetdens_frm, wetdens_too, & -!!$ xbetaij0, xbetaij2i, xbetaij2j, xbetaij3, & -!!$ xbetaii0, xbetaii2, xbetajj0, xbetajj2 ) -!!$ -!!$ -!!$ write(lunout,9801) -!!$ write(lunout,9810) 'nstep,lat,lon,k,ipair ', & -!!$ nstep, latndx(i), lonndx(i), k, ipair -!!$ write(lunout,9820) 'tk, pmb, aircon, pdel ', & -!!$ t(i,k), pmid(i,k)*1.0e-2_r8, aircon, pdel(i,k)*1.0e-2_r8 -!!$ write(lunout,9820) 'wetdens-cgs, sg f/t', & -!!$ wetdens_frm*1.0e-3_r8, wetdens_too*1.0e-3_r8, & -!!$ sg_frm, sg_too -!!$ write(lunout,9820) 'dgnwet-um, dgndry-um f/t', & -!!$ 1.0e6_r8*wetdgnum_frm, 1.0e6_r8*wetdgnum_too, & -!!$ 1.0e6_r8*dgncur_a(i,k,modefrm), 1.0e6_r8*dgncur_a(i,k,modetoo) -!!$ write(lunout,9820) 'xbeta ij0, ij3, ii0, jj0', & -!!$ xbetaij0, xbetaij3, xbetaii0, xbetajj0 -!!$ write(lunout,9820) 'xbeta ij2i & j, ii2, jj2', & -!!$ xbetaij2i, xbetaij2j, xbetaii2, xbetajj2 -!!$ write(lunout,9820) 'numbii, numbjj, deltat ', & -!!$ xnumbconc(modefrm), xnumbconc(modetoo), deltat -!!$ write(lunout,9820) 'loss ij3, ii0, jj0 ', & -!!$ (xbetaij3*xnumbconc(modetoo)*deltat), & -!!$ (xbetaij0*xnumbconc(modetoo)*deltat+ & -!!$ xbetaii0*xnumbconc(modefrm)*deltat), & -!!$ (xbetajj0*xnumbconc(modetoo)*deltat) -!!$ 9801 format( / 72x, 'ACOAG' ) -!!$ 9810 format( 'ACOAG ', a, 2i8, 3i7, 3(1pe15.6) ) -!!$ 9820 format( 'ACOAG ', a, 4(1pe15.6) ) -!!$ 9830 format( 'ACOAG ', a, i1, a, 4(1pe15.6) ) -!!$ end if -!!$ end if -!!$ end if -!!$ end if ! (ldiag2 > 0) -! test diagnostics end ---------------------------------------------- - - ybetaij0(ipair) = xbetaij0 - ybetaij3(ipair) = xbetaij3 - ybetaii0(ipair) = xbetaii0 - ybetajj0(ipair) = xbetajj0 - - end do main_ipair1 - - - - if ( (pair_option_acoag == 1) .or. & - (pair_option_acoag == 2) ) then -! -! calculate number and mass changes for pair_option_acoag == 1,2 -! -main_ipair2: do ipair = 1, npair_acoag - - modefrm = modefrm_acoag(ipair) - modetoo = modetoo_acoag(ipair) - -! calculate number changes -! apply self-coagulation losses only once to a mode (when iselfcoagdone=0) -! first calc change to "too" mode -! next calc change to "frm" mode, using average number conc of "too" - if ( (mprognum_amode(modetoo) > 0) .and. & - (iselfcoagdone(modetoo) <= 0) ) then - iselfcoagdone(modetoo) = 1 - tmpn = xnumbconc(modetoo) - xnumbconcnew(modetoo) = tmpn/(1.0_r8 + deltat*ybetajj0(ipair)*tmpn) - xnumbconcavg(modetoo) = 0.5_r8*(xnumbconcnew(modetoo) + tmpn) - lstoo = numptr_amode(modetoo) - loffset - q(i,k,lstoo) = xnumbconcnew(modetoo)/aircon - dqdt(i,k,lstoo) = (xnumbconcnew(modetoo)-tmpn)*deltatinv_main/aircon - end if - - if ( (mprognum_amode(modefrm) > 0) .and. & - (iselfcoagdone(modefrm) <= 0) ) then - iselfcoagdone(modefrm) = 1 - tmpn = xnumbconc(modefrm) - tmpa = deltat*ybetaij0(ipair)*xnumbconcavg(modetoo) - tmpb = deltat*ybetaii0(ipair) - tmpc = tmpa + tmpb*tmpn - if (abs(tmpc) < 0.01_r8) then - xnumbconcnew(modefrm) = tmpn*exp(-tmpc) - else if (abs(tmpa) < 0.001_r8) then - xnumbconcnew(modefrm) = & - exp(-tmpa)*tmpn/(1.0_r8 + tmpb*tmpn) - else - tmpf = tmpb*tmpn/tmpc - tmpg = exp(-tmpa) - tmph = tmpg*(1.0_r8 - tmpf)/(1.0_r8 - tmpg*tmpf) - xnumbconcnew(modefrm) = tmpn*max( 0.0_r8, min( 1.0_r8, tmph ) ) - end if - xnumbconcavg(modefrm) = 0.5_r8*(xnumbconcnew(modefrm) + tmpn) - lsfrm = numptr_amode(modefrm) - loffset - q(i,k,lsfrm) = xnumbconcnew(modefrm)/aircon - dqdt(i,k,lsfrm) = (xnumbconcnew(modefrm)-tmpn)*deltatinv_main/aircon - end if - -! calculate mass changes -! xbetaij3*xnumbconc(modetoo) = first order loss rate for modefrm volume -! xferfracvol = fraction of modefrm volume transferred to modetoo over deltat - dumloss = ybetaij3(ipair)*xnumbconcavg(modetoo) - xferfracvol = 1.0_r8 - exp( -dumloss*deltat ) - xferfracvol = max( 0.0_r8, min( xferfrac_max, xferfracvol ) ) - - do iq = 1, nspecfrm_acoag(ipair) - lsfrm = lspecfrm_acoag(iq,ipair) - loffset - lstoo = lspectoo_acoag(iq,ipair) - loffset - if (lsfrm > 0) then - xferamt = q(i,k,lsfrm)*xferfracvol - dqdt(i,k,lsfrm) = dqdt(i,k,lsfrm) - xferamt*deltatinv_main - q(i,k,lsfrm) = q(i,k,lsfrm) - xferamt - if (lstoo > 0) then - dqdt(i,k,lstoo) = dqdt(i,k,lstoo) + xferamt*deltatinv_main - q(i,k,lstoo) = q(i,k,lstoo) + xferamt - end if - end if - end do - - end do main_ipair2 - - - else if (pair_option_acoag == 3) then -! -! calculate number and mass changes for pair_option_acoag == 3 -! - -! calculate number changes to accum mode - if (mprognum_amode(macc) > 0) then - tmpn = xnumbconc(macc) - xnumbconcnew(macc) = tmpn/(1.0_r8 + deltat*ybetajj0(ip_aitacc)*tmpn) - xnumbconcavg(macc) = 0.5_r8*(xnumbconcnew(macc) + tmpn) - lstoo = numptr_amode(macc) - loffset - q(i,k,lstoo) = xnumbconcnew(macc)/aircon - dqdt(i,k,lstoo) = (xnumbconcnew(macc)-tmpn)*deltatinv_main/aircon - end if - -! calculate number changes to primary carbon mode - modefrm = modeptr_pcarbon - if (mprognum_amode(mpca) > 0) then - tmpn = xnumbconc(mpca) - tmpa = deltat*ybetaij0(ip_pcaacc)*xnumbconcavg(macc) - tmpb = deltat*ybetaii0(ip_pcaacc) - tmpc = tmpa + tmpb*tmpn - if (abs(tmpc) < 0.01_r8) then - xnumbconcnew(mpca) = tmpn*exp(-tmpc) - else if (abs(tmpa) < 0.001_r8) then - xnumbconcnew(mpca) = & - exp(-tmpa)*tmpn/(1.0_r8 + tmpb*tmpn) - else - tmpf = tmpb*tmpn/tmpc - tmpg = exp(-tmpa) - tmph = tmpg*(1.0_r8 - tmpf)/(1.0_r8 - tmpg*tmpf) - xnumbconcnew(mpca) = tmpn*max( 0.0_r8, min( 1.0_r8, tmph ) ) - end if - xnumbconcavg(mpca) = 0.5_r8*(xnumbconcnew(mpca) + tmpn) - lsfrm = numptr_amode(mpca) - loffset - q(i,k,lsfrm) = xnumbconcnew(mpca)/aircon - dqdt(i,k,lsfrm) = (xnumbconcnew(mpca)-tmpn)*deltatinv_main/aircon - end if - -! calculate number changes to aitken mode - if (mprognum_amode(mait) > 0) then - tmpn = xnumbconc(mait) - tmpa = deltat*( ybetaij0(ip_aitacc)*xnumbconcavg(macc) & - + ybetaij0(ip_aitpca)*xnumbconcavg(mpca) ) - tmpb = deltat*ybetaii0(ip_aitacc) - tmpc = tmpa + tmpb*tmpn - if (abs(tmpc) < 0.01_r8) then - xnumbconcnew(mait) = tmpn*exp(-tmpc) - else if (abs(tmpa) < 0.001_r8) then - xnumbconcnew(mait) = & - exp(-tmpa)*tmpn/(1.0_r8 + tmpb*tmpn) - else - tmpf = tmpb*tmpn/tmpc - tmpg = exp(-tmpa) - tmph = tmpg*(1.0_r8 - tmpf)/(1.0_r8 - tmpg*tmpf) - xnumbconcnew(mait) = tmpn*max( 0.0_r8, min( 1.0_r8, tmph ) ) - end if - xnumbconcavg(mait) = 0.5_r8*(xnumbconcnew(mait) + tmpn) - lsfrm = numptr_amode(mait) - loffset - q(i,k,lsfrm) = xnumbconcnew(mait)/aircon - dqdt(i,k,lsfrm) = (xnumbconcnew(mait)-tmpn)*deltatinv_main/aircon - end if - - -! calculate mass changes from aitken-->accum direct coagulation and -! aitken-->pcarbon-->accum coagulation/aging -! also calc volume of shell material (so4 & nh4 from aitken-->pcarbon) - dumloss = ybetaij3(ip_aitacc)*xnumbconcavg(macc) & - + ybetaij3(ip_aitpca)*xnumbconcavg(mpca) - tmpa = ybetaij3(ip_aitpca)*xnumbconcavg(mpca)/max( dumloss, 1.0e-37_r8 ) - xferfracvol = 1.0_r8 - exp( -dumloss*deltat ) - xferfracvol = max( 0.0_r8, min( xferfrac_max, xferfracvol ) ) - vol_shell = 0.0_r8 - - ipair = ip_aitacc - do iq = 1, nspecfrm_acoag(ipair) - lsfrm = lspecfrm_acoag(iq,ipair) - loffset - lstoo = lspectoo_acoag(iq,ipair) - loffset - if (lsfrm > 0) then - xferamt = q(i,k,lsfrm)*xferfracvol - dqdt(i,k,lsfrm) = dqdt(i,k,lsfrm) - xferamt*deltatinv_main - q(i,k,lsfrm) = q(i,k,lsfrm) - xferamt - if (lstoo > 0) then - dqdt(i,k,lstoo) = dqdt(i,k,lstoo) + xferamt*deltatinv_main - q(i,k,lstoo) = q(i,k,lstoo) + xferamt - end if - vol_shell = vol_shell + xferamt*tmpa*fac_m2v_aitage(iq) - end if - end do - - -! now calculate aging transfer fraction for pcarbon-->accum -! this duplicates the code in modal_aero_gasaerexch - vol_core = 0.0_r8 - do l = 1, nspec_amode(mpca) - vol_core = vol_core + & - q(i,k,lmassptr_amode(l,mpca)-loffset)*fac_m2v_pcarbon(l) - end do - tmp1 = vol_shell*dgncur_a(i,k,mpca)*fac_volsfc_pcarbon - tmp2 = 6.0_r8*dr_so4_monolayers_pcage*vol_core - tmp2 = max( tmp2, 0.0_r8 ) - if (tmp1 >= tmp2) then - xferfrac_pcage = xferfrac_max - else - xferfrac_pcage = min( tmp1/tmp2, xferfrac_max ) - end if - - -! calculate mass changes from pcarbon-->accum by direct coagulation -! and aging - dumloss = ybetaij3(ip_pcaacc)*xnumbconcavg(macc) - xferfracvol = 1.0_r8 - exp( -dumloss*deltat ) - xferfracvol = xferfracvol + xferfrac_pcage - xferfracvol = max( 0.0_r8, min( xferfrac_max, xferfracvol ) ) - - ipair = ip_pcaacc - do iq = 1, nspecfrm_acoag(ipair) - lsfrm = lspecfrm_acoag(iq,ipair) - loffset - lstoo = lspectoo_acoag(iq,ipair) - loffset - if (lsfrm > 0) then - xferamt = q(i,k,lsfrm)*xferfracvol - dqdt(i,k,lsfrm) = dqdt(i,k,lsfrm) - xferamt*deltatinv_main - q(i,k,lsfrm) = q(i,k,lsfrm) - xferamt - if (lstoo > 0) then - dqdt(i,k,lstoo) = dqdt(i,k,lstoo) + xferamt*deltatinv_main - q(i,k,lstoo) = q(i,k,lstoo) + xferamt - end if - end if - end do - - lsfrm = numptr_amode(mpca) - loffset - lstoo = numptr_amode(macc) - loffset - if (lsfrm > 0) then - xferamt = q(i,k,lsfrm)*xferfrac_pcage - dqdt(i,k,lsfrm) = dqdt(i,k,lsfrm) - xferamt*deltatinv_main - q(i,k,lsfrm) = q(i,k,lsfrm) - xferamt - if (lstoo > 0) then - dqdt(i,k,lstoo) = dqdt(i,k,lstoo) + xferamt*deltatinv_main - q(i,k,lstoo) = q(i,k,lstoo) + xferamt - end if - end if - - - - else ! (pair_option_acoag /= 1,2,3) then - - write(lunout,*) '*** modal_aero_coag_sub error' - write(lunout,*) ' cannot do _coag_sub error pair_option_acoag =', & - pair_option_acoag - errmsg = 'modal_aero_coag_sub error' - errflg = 1 - return - - - end if ! (pair_option_acoag == ...) - - -! test diagnostics begin -------------------------------------------- -!!$ if (ldiag3 > 0) then -!!$ if (nstep <= 3) then -!!$ if ((lonndx(i) == 37) .and. (latndx(i) == 23)) then -!!$ if ((mod(k-1,5) == 0) .or. (k>=23)) then -!!$ if (pair_option_acoag == 3) then -!!$ write(*,*) -!!$ write(lunout,9820) 'xnumbconcavg ait,acc,pca', & -!!$ xnumbconcavg(mait), xnumbconcavg(macc), xnumbconcavg(mpca) -!!$ write(lunout,9820) 'vshell, core ', & -!!$ vol_shell, vol_core -!!$ write(lunout,9820) 'dr_mono, dgn ', & -!!$ dr_so4_monolayers_pcage, dgncur_a(i,k,mpca) -!!$ write(lunout,9820) 'tmp1, tmp2 ', tmp1, tmp2 -!!$ write(lunout,9820) 'xferfrac_age ', xferfrac_pcage -!!$ end if -!!$ -!!$ do ipair = 1, npair_acoag -!!$ modefrm = modefrm_acoag(ipair) -!!$ modetoo = modetoo_acoag(ipair) -!!$ if (npair_acoag > 1) then -!!$ write(lunout,*) -!!$ write(lunout,9810) 'ipair = ', ipair -!!$ end if -!!$ -!!$ do iq = 1, nspecfrm_acoag(ipair) -!!$ lsfrm = lspecfrm_acoag(iq,ipair) - loffset -!!$ lstoo = lspectoo_acoag(iq,ipair) - loffset -!!$ if (lsfrm > 0) then -!!$ tmp_qold = q(i,k,lsfrm) - dqdt(i,k,lsfrm)*deltat_main -!!$! write(lunout,9820) 'm1 frm dqdt/q0,dqdt,q0/1', & -!!$ write(lunout,9830) 'm', iq, & -!!$ ' frm dqdt/q0,dqdt,q0/1', & -!!$ dqdt(i,k,lsfrm)/tmp_qold, dqdt(i,k,lsfrm), tmp_qold, q(i,k,lsfrm) -!!$ end if -!!$ if (lstoo > 0) then -!!$ tmp_qold = q(i,k,lstoo) - dqdt(i,k,lstoo)*deltat_main -!!$ write(lunout,9830) 'm', iq, & -!!$ ' too dqdt/q0,dqdt,q0/1', & -!!$ dqdt(i,k,lstoo)/tmp_qold, dqdt(i,k,lstoo), tmp_qold, q(i,k,lstoo) -!!$ end if -!!$ end do ! iq -!!$ -!!$ lsfrm = numptr_amode(modefrm) - loffset -!!$ lstoo = numptr_amode(modetoo) - loffset -!!$ if (lsfrm > 0) then -!!$ tmp_qold = q(i,k,lsfrm) - dqdt(i,k,lsfrm)*deltat_main -!!$ write(lunout,9820) 'n frm dqdt/q0,dqdt,q0/1', & -!!$ dqdt(i,k,lsfrm)/tmp_qold, dqdt(i,k,lsfrm), tmp_qold, q(i,k,lsfrm) -!!$ end if -!!$ if (lstoo > 0) then -!!$ tmp_qold = q(i,k,lstoo) - dqdt(i,k,lstoo)*deltat_main -!!$ write(lunout,9820) 'n too dqdt/q0,dqdt,q0/1', & -!!$ dqdt(i,k,lstoo)/tmp_qold, dqdt(i,k,lstoo), tmp_qold, q(i,k,lstoo) -!!$ end if -!!$ -!!$ end do ! ipair -!!$ end if -!!$ end if -!!$ end if -!!$ end if ! (ldiag3 > 0) -! test diagnostics end ---------------------------------------------- - - - - end do main_i - end do main_k - - -! set dotend's - do ipair = 1, npair_acoag - modefrm = modefrm_acoag(ipair) - modetoo = modetoo_acoag(ipair) - - do iq = 1, nspecfrm_acoag(ipair) - lsfrm = lspecfrm_acoag(iq,ipair) - loffset - lstoo = lspectoo_acoag(iq,ipair) - loffset - if (lsfrm > 0) dotend(lsfrm) = .true. - if (lstoo > 0) dotend(lstoo) = .true. - end do - - if (mprognum_amode(modefrm) > 0) then - lsfrm = numptr_amode(modefrm) - loffset - if (lsfrm > 0) dotend(lsfrm) = .true. - end if - if (mprognum_amode(modetoo) > 0) then - lstoo = numptr_amode(modetoo) - loffset - if (lstoo > 0) dotend(lstoo) = .true. - end if - - end do - - -! history file column-tendency fields (column integral of dqdt with -! adv_mass/mwdry scaling + outfld) are done by the caller, which owns -! the host constituent metadata - - - return - - -!EOC - end subroutine modal_aero_coag_run - - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- - subroutine modal_aero_coag_init( pair_option_acoag_in, & - npair_acoag_in, modefrm_acoag_in, modetoo_acoag_in, & - modetooeff_acoag_in, nspecfrm_acoag_in, & - lspecfrm_acoag_in, lspectoo_acoag_in, & - ip_aitacc_in, ip_aitpca_in, ip_pcaacc_in, & - fac_m2v_aitage_in, fac_m2v_pcarbon_in, & - nspec_max_in, ntot_amode_in, & - modeptr_accum_in, modeptr_aitken_in, modeptr_pcarbon_in, & - numptr_amode_in, mprognum_amode_in, nspec_amode_in, & - lmassptr_amode_in, alnsg_amode_in, sigmag_amode_in, & - r_universal_in, pstd_in, tmelt_in, boltz_in, & - errmsg, errflg ) -! -! store the resolved coagulation-pair tables, mode metadata, and host -! physical constants used by modal_aero_coag_run -! pair/species resolution and history-field registration are host -! responsibilities (see modal_aero_coag_cam) -! - implicit none - -! arguments - integer, intent(in) :: pair_option_acoag_in ! pair selection (see module header) - integer, intent(in) :: npair_acoag_in ! number of coagulation pairs - integer, intent(in) :: modefrm_acoag_in(:) ! (maxpair_acoag) "from" mode of each pair - integer, intent(in) :: modetoo_acoag_in(:) ! (maxpair_acoag) "too" mode of each pair - integer, intent(in) :: modetooeff_acoag_in(:) ! (maxpair_acoag) effective "too" mode of each pair - integer, intent(in) :: nspecfrm_acoag_in(:) ! (maxpair_acoag) species count of each pair - integer, intent(in) :: lspecfrm_acoag_in(:,:) ! (nspec_max,maxpair_acoag) "from" species - ! indices (host constituent space) - integer, intent(in) :: lspectoo_acoag_in(:,:) ! (nspec_max,maxpair_acoag) "too" species - ! indices (host constituent space) - integer, intent(in) :: ip_aitacc_in ! pair index of [aitken-->accum] - integer, intent(in) :: ip_aitpca_in ! pair index of [aitken-->pcarbon] - integer, intent(in) :: ip_pcaacc_in ! pair index of [pcarbon-->accum] - real(r8), intent(in) :: fac_m2v_aitage_in(:) ! (nspec_max) mixing-ratio to volume factors - real(r8), intent(in) :: fac_m2v_pcarbon_in(:) ! (nspec_max) for aging shell/core calcs - integer, intent(in) :: nspec_max_in ! max number of species in a mode - integer, intent(in) :: ntot_amode_in ! number of aerosol modes - integer, intent(in) :: modeptr_accum_in ! accumulation mode index - integer, intent(in) :: modeptr_aitken_in ! aitken mode index - integer, intent(in) :: modeptr_pcarbon_in ! primary carbon mode index - integer, intent(in) :: numptr_amode_in(:) ! (ntot_amode) number indices (host constituent space) - integer, intent(in) :: mprognum_amode_in(:) ! (ntot_amode) prognostic-number flags - integer, intent(in) :: nspec_amode_in(:) ! (ntot_amode) species counts - integer, intent(in) :: lmassptr_amode_in(:,:) ! (nspec_max,ntot_amode) mass indices - ! (host constituent space) - real(r8), intent(in) :: alnsg_amode_in(:) ! (ntot_amode) ln(sigmag) - real(r8), intent(in) :: sigmag_amode_in(:) ! (ntot_amode) geometric standard deviation - real(r8), intent(in) :: r_universal_in ! universal gas constant (J/K/kmol) - real(r8), intent(in) :: pstd_in ! standard pressure (Pa) - real(r8), intent(in) :: tmelt_in ! freezing point of water (K) - real(r8), intent(in) :: boltz_in ! Boltzmann constant (J/K) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = ' ' - errflg = 0 - - pair_option_acoag = pair_option_acoag_in - - maxspec_acoag = nspec_max_in - allocate( lspecfrm_acoag(maxspec_acoag,maxpair_acoag) ) - allocate( lspectoo_acoag(maxspec_acoag,maxpair_acoag) ) - allocate( fac_m2v_aitage(nspec_max_in), fac_m2v_pcarbon(nspec_max_in) ) - - npair_acoag = npair_acoag_in - modefrm_acoag(:) = modefrm_acoag_in(:) - modetoo_acoag(:) = modetoo_acoag_in(:) - modetooeff_acoag(:) = modetooeff_acoag_in(:) - nspecfrm_acoag(:) = nspecfrm_acoag_in(:) - lspecfrm_acoag(:,:) = lspecfrm_acoag_in(:,:) - lspectoo_acoag(:,:) = lspectoo_acoag_in(:,:) - - ip_aitacc = ip_aitacc_in - ip_aitpca = ip_aitpca_in - ip_pcaacc = ip_pcaacc_in - - fac_m2v_aitage(:) = fac_m2v_aitage_in(:) - fac_m2v_pcarbon(:) = fac_m2v_pcarbon_in(:) - - ntot_amode = ntot_amode_in - modeptr_accum = modeptr_accum_in - modeptr_aitken = modeptr_aitken_in - modeptr_pcarbon = modeptr_pcarbon_in - - allocate( numptr_amode(ntot_amode_in), mprognum_amode(ntot_amode_in), & - nspec_amode(ntot_amode_in) ) - allocate( lmassptr_amode(nspec_max_in,ntot_amode_in) ) - allocate( alnsg_amode(ntot_amode_in), sigmag_amode(ntot_amode_in) ) - numptr_amode(:) = numptr_amode_in(:) - mprognum_amode(:) = mprognum_amode_in(:) - nspec_amode(:) = nspec_amode_in(:) - lmassptr_amode(:,:) = lmassptr_amode_in(:,:) - alnsg_amode(:) = alnsg_amode_in(:) - sigmag_amode(:) = sigmag_amode_in(:) - - r_universal = r_universal_in - p0 = pstd_in - tmelt = tmelt_in - boltz = boltz_in - - return - end subroutine modal_aero_coag_init - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- - subroutine getcoags_wrapper_f( & - airtemp, airprs, & - dgatk, dgacc, & - sgatk, sgacc, & - xxlsgat, xxlsgac, & - pdensat, pdensac, & - betaij0, betaij2i, betaij2j, betaij3, & - betaii0, betaii2, betajj0, betajj2 ) -! (p0, tmelt, boltz are module-level host constants -! set by modal_aero_coag_init) -! -! interface to subr. getcoags -! -! interface code adapted from subr. aeroproc of cmaq v4.6, -! with some of the parameter values from module aero_info_ae4 -! - implicit none - -! *** arguments - - real(r8), intent(in) :: airtemp ! air temperature [ k ] - real(r8), intent(in) :: airprs ! air pressure in [ pa ] - - real(r8), intent(in) :: dgatk ! aitken mode geometric mean diameter [m] - real(r8), intent(in) :: dgacc ! accumulation mode geometric mean diam [m] - - real(r8), intent(in) :: sgatk ! aitken mode geometric standard deviation - real(r8), intent(in) :: sgacc ! accumulation mode geometric standard deviation - - real(r8), intent(in) :: xxlsgat ! natural log of geometric standard - real(r8), intent(in) :: xxlsgac ! deviations - - real(r8), intent(in) :: pdensat ! aitken mode particle density [ kg / m**3 ] - real(r8), intent(in) :: pdensac ! accumulation mode density [ kg / m**3 ] - - real(r8), intent(out) :: betaij0, betaij2i, betaij2j, betaij3, & - betaii0, betaii2, betajj0, betajj2 - - -! *** local parameters - real(r8) :: t0 ! standard surface temperature (15 deg C) [ k ] - real(r8), parameter :: two3 = 2.0_r8/3.0_r8 - -! *** local variables - real(r8) amu ! atmospheric dynamic viscosity [ kg/m s ] - real(r8) sqrt_temp ! square root of ambient temperature - real(r8) lamda ! mean free path [ m ] - -! *** intramodal coagulation rates [ m**3/s ] ( 0th & 2nd moments ) - real(r8) batat( 2 ) ! aitken mode - real(r8) bacac( 2 ) ! accumulation mode -! *** intermodal coagulation rates [ m**3/s ] ( 0th & 2nd moments ) - real(r8) batac( 2 ) ! aitken to accumulation - real(r8) bacat( 2 ) ! accumulation from aitken -! *** intermodal coagulation rate [ m**3/s ] ( 3rd moment ) - real(r8) c3ij ! aitken to accumulation -! *** 3rd moment intermodal transfer rate by coagulation - real(r8) c30atac ! aitken to accumulation - -! *** near continnuum regime (independent of mode) - real(r8) knc ! knc = two3 * boltz * airtemp / amu -! *** free molecular regime (depends upon modal density) - real(r8) kfmat ! kfmat = sqrt(3.0*boltz*airtemp/pdensat) - real(r8) kfmac ! kfmac = sqrt(3.0*boltz*airtemp/pdensac) - real(r8) kfmatac ! kfmatac = sqrt( 6.0 * boltz * airtemp / - ! ( pdensat + pdensac ) ) - - real(r8) dumacc2, dumatk2, dumatk3 - - t0 = tmelt + 15._r8 - - sqrt_temp = sqrt( airtemp) - -! *** calculate mean free path [ m ]: -! 6.6328e-8 is the sea level value given in table i.2.8 -! on page 10 of u.s. standard atmosphere 1962 - lamda = 6.6328e-8_r8 * p0 * airtemp / ( t0 * airprs ) - -! *** calculate dynamic viscosity [ kg m**-1 s**-1 ]: -! u.s. standard atmosphere 1962 page 14 expression -! for dynamic viscosity is: -! dynamic viscosity = beta * t * sqrt(t) / ( t + s) -! where beta = 1.458e-6 [ kg sec^-1 k**-0.5 ], s = 110.4 [ k ]. - amu = 1.458e-6_r8 * airtemp * sqrt_temp / ( airtemp + 110.4_r8 ) - -! *** coagulation -! calculate coagulation coefficients using a method dictated by -! the value of fastcoag_flag. if true, the computationally- -! efficient getcoags routine is used. if false, the more intensive -! gauss-hermite numerical quadrature method is used. see section -! 2.1 of bhave et al. (2004) for further discussion. - -! *** calculate term used in equation a6 of binkowski & shankar (1995) - knc = two3 * boltz * airtemp / amu -! *** calculate terms used in equation a5 of binkowski & shankar (1995) - kfmat = sqrt( 3.0_r8 * boltz * airtemp / pdensat ) - kfmac = sqrt( 3.0_r8 * boltz * airtemp / pdensac ) - kfmatac = sqrt( 6.0_r8 * boltz * airtemp / ( pdensat + pdensac ) ) - -! *** transfer of number to accumulation mode from aitken mode is zero - bacat(1) = 0.0_r8 - -! *** calculate intermodal and intramodal coagulation coefficients -! for zeroth and second moments, and intermodal coagulation -! coefficient for third moment - call getcoags( lamda, kfmatac, kfmat, kfmac, knc, & - dgatk, dgacc, sgatk, sgacc, & - xxlsgat, xxlsgac, & - batat(2), batat(1), bacac(2), bacac(1), & - batac(2), bacat(2), batac(1), c3ij ) - -! convert from the "cmaq" coag rate parameters -! to the "mirage2" parameters - dumacc2 = ( (dgacc**2) * exp( 2.0_r8*xxlsgac*xxlsgac ) ) - dumatk2 = ( (dgatk**2) * exp( 2.0_r8*xxlsgat*xxlsgat ) ) - dumatk3 = ( (dgatk**3) * exp( 4.5_r8*xxlsgat*xxlsgat ) ) - - betaii0 = max( 0.0_r8, batat(1) ) - betajj0 = max( 0.0_r8, bacac(1) ) - betaij0 = max( 0.0_r8, batac(1) ) - betaij3 = max( 0.0_r8, c3ij / dumatk3 ) - - betajj2 = max( 0.0_r8, bacac(2) / dumacc2 ) - betaii2 = max( 0.0_r8, batat(2) / dumatk2 ) - betaij2i = max( 0.0_r8, batac(2) / dumatk2 ) - betaij2j = max( 0.0_r8, bacat(2) / dumatk2 ) - - - return - end subroutine getcoags_wrapper_f - - - -! ////////////////////////////////////////////////////////////////// -! subroutine getcoags calculates the coagulation rates using a new -! approximate algorithm for the 2nd moment. the 0th and 3rd moments -! are done by analytic expressions from whitby et al. (1991). the -! correction factors are also similar to those from whitby et al. -! (1991), but are derived from the gauss-hermite numerical -! quadratures used by binkowski and roselle (2003). -! -! called from aerostep as: -! call getcoags( lamda, kfmatac, kfmat, kfmac, knc, -! dgat,dgac, sgatk, sgacc, xxlsgat,xxlsgac, -! batat(2), batat(1), bacac(2), bacac(1), -! batac(2), bacat(2), batac(1), c3ij ) -! where all input and outputs are real*8 -! -! revision history: -! fsb 08/25/03 coded by dr. francis s. binkowksi -! -! fsb 08/25/04 added in-line documentation -! -! rce 04/15/2007 -! code taken from cmaq v4.6 code; converted to f90; -! added "intent" to subr arguments; -! renamed "r4" & "r8" variables to "rx4" & "rx8"; -! changed "real*N" declarations to "real(rN)" (N = 4 or 8) -! -! references: -! 1. whitby, e. r., p. h. mcmurry, u. shankar, and f. s. binkowski, -! modal aerosol dynamics modeling, rep. 600/3-91/020, atmospheric -! research and exposure assessment laboratory, -! u.s. environmental protection agency, research triangle park, n.c., -! (ntis pb91-161729/as), 1991 -! -! 2. binkowski, f.s. an u. shankar, the regional particulate matter -! model 1. model decsription and preliminary results, journal of -! geophysical research, 100, d12, pp 26,191-26,209, -! december 20, 1995. -! -! 3. binkowski, f.s. and s.j. roselle, models-3 community -! multiscale air quality (cmaq) model aerosol component 1: -! model description. j. geophys. res., vol 108, no d6, 4183 -! doi:10.1029/2001jd001409, 2003. - - - subroutine getcoags( lamda, kfmatac, kfmat, kfmac, knc, & - dgatk, dgacc, sgatk, sgacc, xxlsgat,xxlsgac, & - qs11, qn11, qs22, qn22, & - qs12, qs21, qn12, qv12 ) - - implicit none - - real(r8), intent(in) :: lamda ! mean free path [ m ] - -! *** coefficients for free molecular regime - real(r8), intent(in) :: kfmat ! aitken mode - real(r8), intent(in) :: kfmac ! accumulation mode - real(r8), intent(in) :: kfmatac ! aitken to accumulation mode - - real(r8), intent(in) :: knc ! coefficient for near continnuum regime - -! *** modal geometric mean diameters: [ m ] - real(r8), intent(in) :: dgatk ! aitken mode - real(r8), intent(in) :: dgacc ! accumulation mode - -! *** modal geometric standard deviation - real(r8), intent(in) :: sgatk ! atken mode - real(r8), intent(in) :: sgacc ! accumulation mode - -! *** natural log of modal geometric standard deviation - real(r8), intent(in) :: xxlsgat ! aitken mode - real(r8), intent(in) :: xxlsgac ! accumulation mode - -! *** coagulation coefficients - real(r8), intent(out) :: qs11, qn11, qs22, qn22, & - qs12, qs21, qn12, qv12 - - integer ibeta, n1, n2a, n2n ! indices for correction factors - - real(r8) i1fm_at - real(r8) i1nc_at - real(r8) i1_at - - real(r8) i1fm_ac - real(r8) i1nc_ac - real(r8) i1_ac - - real(r8) i1fm - real(r8) i1nc - real(r8) i1 - - real(r8) constii - - real(r8) kngat, kngac - real(r8) one, two, half - parameter( one = 1.0_r8, two = 2.0_r8, half = 0.5_r8 ) - real(r8) a -! parameter( a = 2.492_r8) - parameter( a = 1.246_r8) - real(r8) two3rds - parameter( two3rds = 2._r8 / 3._r8) - - real(r8) sqrttwo ! sqrt(two) - real(r8) dlgsqt2 ! 1/ln( sqrt( 2 ) ) - - - real(r8) esat01 ! aitken mode exp( log^2( sigmag )/8 ) - real(r8) esac01 ! accumulation mode exp( log^2( sigmag )/8 ) - - real(r8) esat04 - real(r8) esac04 - - real(r8) esat05 - real(r8) esac05 - - real(r8) esat08 - real(r8) esac08 - - real(r8) esat09 - real(r8) esac09 - - real(r8) esat16 - real(r8) esac16 - - real(r8) esat20 - real(r8) esac20 - - real(r8) esat24 - real(r8) esac24 - - real(r8) esat25 - real(r8) esac25 - - real(r8) esat36 - real(r8) esac36 - - real(r8) esat49 - - real(r8) esat64 - real(r8) esac64 - - real(r8) esat100 - - real(r8) dgat2, dgac2, dgat3, dgac3 - real(r8) sqdgat, sqdgac - real(r8) sqdgat5, sqdgac5 - real(r8) sqdgat7 - real(r8) r, r2, r3, rx4, r5, r6, rx8 - real(r8) ri1, ri2, ri3, ri4 - real(r8) rat - real(r8) coagfm0, coagnc0 - real(r8) coagfm3, coagnc3 - real(r8) coagfm_at, coagfm_ac - real(r8) coagnc_at, coagnc_ac - real(r8) coagatat0 - real(r8) coagacac0 - real(r8) coagatat2 - real(r8) coagacac2 - real(r8) coagatac0, coagatac3 - real(r8) coagatac2 - real(r8) coagacat2 - real(r8) xm2at, xm3at, xm2ac, xm3ac - -! *** correction factors for coagulation rates - real(r8), save :: bm0( 10 ) ! m0 intramodal fm - rpm values - real(r8), save :: bm0ij( 10, 10, 10 ) ! m0 intermodal fm - real(r8), save :: bm3i( 10, 10, 10 ) ! m3 intermodal fm- rpm values - real(r8), save :: bm2ii(10) ! m2 intramodal fm - real(r8), save :: bm2iitt(10) ! m2 intramodal total - real(r8), save :: bm2ij(10,10,10) ! m2 intermodal fm i to j - real(r8), save :: bm2ji(10,10,10) ! m2 total intermodal j from i - -! *** populate the arrays for the correction factors. - -! rpm 0th moment correction factors for unimodal fm coagulation rates - data bm0 / & - 0.707106785165097_r8, 0.726148960080488_r8, 0.766430744110958_r8, & - 0.814106389441342_r8, 0.861679526483207_r8, 0.903600509090092_r8, & - 0.936578814219156_r8, 0.960098926735545_r8, 0.975646823342881_r8, & - 0.985397173215326_r8 / - - -! fsb new fm correction factors for m0 intermodal coagulation - - data (bm0ij ( 1, 1,ibeta), ibeta = 1,10) / & - 0.628539_r8, 0.639610_r8, 0.664514_r8, 0.696278_r8, 0.731558_r8, & - 0.768211_r8, 0.804480_r8, 0.838830_r8, 0.870024_r8, 0.897248_r8/ - data (bm0ij ( 1, 2,ibeta), ibeta = 1,10) / & - 0.639178_r8, 0.649966_r8, 0.674432_r8, 0.705794_r8, 0.740642_r8, & - 0.776751_r8, 0.812323_r8, 0.845827_r8, 0.876076_r8, 0.902324_r8/ - data (bm0ij ( 1, 3,ibeta), ibeta = 1,10) / & - 0.663109_r8, 0.673464_r8, 0.697147_r8, 0.727637_r8, 0.761425_r8, & - 0.796155_r8, 0.829978_r8, 0.861419_r8, 0.889424_r8, 0.913417_r8/ - data (bm0ij ( 1, 4,ibeta), ibeta = 1,10) / & - 0.693693_r8, 0.703654_r8, 0.726478_r8, 0.755786_r8, 0.787980_r8, & - 0.820626_r8, 0.851898_r8, 0.880459_r8, 0.905465_r8, 0.926552_r8/ - data (bm0ij ( 1, 5,ibeta), ibeta = 1,10) / & - 0.727803_r8, 0.737349_r8, 0.759140_r8, 0.786870_r8, 0.816901_r8, & - 0.846813_r8, 0.874906_r8, 0.900060_r8, 0.921679_r8, 0.939614_r8/ - data (bm0ij ( 1, 6,ibeta), ibeta = 1,10) / & - 0.763461_r8, 0.772483_r8, 0.792930_r8, 0.818599_r8, 0.845905_r8, & - 0.872550_r8, 0.897051_r8, 0.918552_r8, 0.936701_r8, 0.951528_r8/ - data (bm0ij ( 1, 7,ibeta), ibeta = 1,10) / & - 0.799021_r8, 0.807365_r8, 0.826094_r8, 0.849230_r8, 0.873358_r8, & - 0.896406_r8, 0.917161_r8, 0.935031_r8, 0.949868_r8, 0.961828_r8/ - data (bm0ij ( 1, 8,ibeta), ibeta = 1,10) / & - 0.833004_r8, 0.840514_r8, 0.857192_r8, 0.877446_r8, 0.898147_r8, & - 0.917518_r8, 0.934627_r8, 0.949106_r8, 0.960958_r8, 0.970403_r8/ - data (bm0ij ( 1, 9,ibeta), ibeta = 1,10) / & - 0.864172_r8, 0.870734_r8, 0.885153_r8, 0.902373_r8, 0.919640_r8, & - 0.935494_r8, 0.949257_r8, 0.960733_r8, 0.970016_r8, 0.977346_r8/ - data (bm0ij ( 1, 10,ibeta), ibeta = 1,10) / & - 0.891658_r8, 0.897227_r8, 0.909343_r8, 0.923588_r8, 0.937629_r8, & - 0.950307_r8, 0.961151_r8, 0.970082_r8, 0.977236_r8, 0.982844_r8/ - data (bm0ij ( 2, 1,ibeta), ibeta = 1,10) / & - 0.658724_r8, 0.670587_r8, 0.697539_r8, 0.731890_r8, 0.769467_r8, & - 0.807391_r8, 0.843410_r8, 0.875847_r8, 0.903700_r8, 0.926645_r8/ - data (bm0ij ( 2, 2,ibeta), ibeta = 1,10) / & - 0.667070_r8, 0.678820_r8, 0.705538_r8, 0.739591_r8, 0.776758_r8, & - 0.814118_r8, 0.849415_r8, 0.881020_r8, 0.908006_r8, 0.930121_r8/ - data (bm0ij ( 2, 3,ibeta), ibeta = 1,10) / & - 0.686356_r8, 0.697839_r8, 0.723997_r8, 0.757285_r8, 0.793389_r8, & - 0.829313_r8, 0.862835_r8, 0.892459_r8, 0.917432_r8, 0.937663_r8/ - data (bm0ij ( 2, 4,ibeta), ibeta = 1,10) / & - 0.711425_r8, 0.722572_r8, 0.747941_r8, 0.780055_r8, 0.814518_r8, & - 0.848315_r8, 0.879335_r8, 0.906290_r8, 0.928658_r8, 0.946526_r8/ - data (bm0ij ( 2, 5,ibeta), ibeta = 1,10) / & - 0.739575_r8, 0.750307_r8, 0.774633_r8, 0.805138_r8, 0.837408_r8, & - 0.868504_r8, 0.896517_r8, 0.920421_r8, 0.939932_r8, 0.955299_r8/ - data (bm0ij ( 2, 6,ibeta), ibeta = 1,10) / & - 0.769143_r8, 0.779346_r8, 0.802314_r8, 0.830752_r8, 0.860333_r8, & - 0.888300_r8, 0.913014_r8, 0.933727_r8, 0.950370_r8, 0.963306_r8/ - data (bm0ij ( 2, 7,ibeta), ibeta = 1,10) / & - 0.798900_r8, 0.808431_r8, 0.829700_r8, 0.855653_r8, 0.882163_r8, & - 0.906749_r8, 0.928075_r8, 0.945654_r8, 0.959579_r8, 0.970280_r8/ - data (bm0ij ( 2, 8,ibeta), ibeta = 1,10) / & - 0.827826_r8, 0.836542_r8, 0.855808_r8, 0.878954_r8, 0.902174_r8, & - 0.923316_r8, 0.941345_r8, 0.955989_r8, 0.967450_r8, 0.976174_r8/ - data (bm0ij ( 2, 9,ibeta), ibeta = 1,10) / & - 0.855068_r8, 0.862856_r8, 0.879900_r8, 0.900068_r8, 0.919956_r8, & - 0.937764_r8, 0.952725_r8, 0.964726_r8, 0.974027_r8, 0.981053_r8/ - data (bm0ij ( 2, 10,ibeta), ibeta = 1,10) / & - 0.879961_r8, 0.886755_r8, 0.901484_r8, 0.918665_r8, 0.935346_r8, & - 0.950065_r8, 0.962277_r8, 0.971974_r8, 0.979432_r8, 0.985033_r8/ - data (bm0ij ( 3, 1,ibeta), ibeta = 1,10) / & - 0.724166_r8, 0.735474_r8, 0.761359_r8, 0.794045_r8, 0.828702_r8, & - 0.862061_r8, 0.891995_r8, 0.917385_r8, 0.937959_r8, 0.954036_r8/ - data (bm0ij ( 3, 2,ibeta), ibeta = 1,10) / & - 0.730416_r8, 0.741780_r8, 0.767647_r8, 0.800116_r8, 0.834344_r8, & - 0.867093_r8, 0.896302_r8, 0.920934_r8, 0.940790_r8, 0.956237_r8/ - data (bm0ij ( 3, 3,ibeta), ibeta = 1,10) / & - 0.745327_r8, 0.756664_r8, 0.782255_r8, 0.814026_r8, 0.847107_r8, & - 0.878339_r8, 0.905820_r8, 0.928699_r8, 0.946931_r8, 0.960977_r8/ - data (bm0ij ( 3, 4,ibeta), ibeta = 1,10) / & - 0.765195_r8, 0.776312_r8, 0.801216_r8, 0.831758_r8, 0.863079_r8, & - 0.892159_r8, 0.917319_r8, 0.937939_r8, 0.954145_r8, 0.966486_r8/ - data (bm0ij ( 3, 5,ibeta), ibeta = 1,10) / & - 0.787632_r8, 0.798347_r8, 0.822165_r8, 0.850985_r8, 0.880049_r8, & - 0.906544_r8, 0.929062_r8, 0.947218_r8, 0.961288_r8, 0.971878_r8/ - data (bm0ij ( 3, 6,ibeta), ibeta = 1,10) / & - 0.811024_r8, 0.821179_r8, 0.843557_r8, 0.870247_r8, 0.896694_r8, & - 0.920365_r8, 0.940131_r8, 0.955821_r8, 0.967820_r8, 0.976753_r8/ - data (bm0ij ( 3, 7,ibeta), ibeta = 1,10) / & - 0.834254_r8, 0.843709_r8, 0.864356_r8, 0.888619_r8, 0.912245_r8, & - 0.933019_r8, 0.950084_r8, 0.963438_r8, 0.973530_r8, 0.980973_r8/ - data (bm0ij ( 3, 8,ibeta), ibeta = 1,10) / & - 0.856531_r8, 0.865176_r8, 0.883881_r8, 0.905544_r8, 0.926290_r8, & - 0.944236_r8, 0.958762_r8, 0.969988_r8, 0.978386_r8, 0.984530_r8/ - data (bm0ij ( 3, 9,ibeta), ibeta = 1,10) / & - 0.877307_r8, 0.885070_r8, 0.901716_r8, 0.920729_r8, 0.938663_r8, & - 0.953951_r8, 0.966169_r8, 0.975512_r8, 0.982442_r8, 0.987477_r8/ - data (bm0ij ( 3, 10,ibeta), ibeta = 1,10) / & - 0.896234_r8, 0.903082_r8, 0.917645_r8, 0.934069_r8, 0.949354_r8, & - 0.962222_r8, 0.972396_r8, 0.980107_r8, 0.985788_r8, 0.989894_r8/ - data (bm0ij ( 4, 1,ibeta), ibeta = 1,10) / & - 0.799294_r8, 0.809144_r8, 0.831293_r8, 0.858395_r8, 0.885897_r8, & - 0.911031_r8, 0.932406_r8, 0.949642_r8, 0.963001_r8, 0.973062_r8/ - data (bm0ij ( 4, 2,ibeta), ibeta = 1,10) / & - 0.804239_r8, 0.814102_r8, 0.836169_r8, 0.862984_r8, 0.890003_r8, & - 0.914535_r8, 0.935274_r8, 0.951910_r8, 0.964748_r8, 0.974381_r8/ - data (bm0ij ( 4, 3,ibeta), ibeta = 1,10) / & - 0.815910_r8, 0.825708_r8, 0.847403_r8, 0.873389_r8, 0.899185_r8, & - 0.922275_r8, 0.941543_r8, 0.956826_r8, 0.968507_r8, 0.977204_r8/ - data (bm0ij ( 4, 4,ibeta), ibeta = 1,10) / & - 0.831348_r8, 0.840892_r8, 0.861793_r8, 0.886428_r8, 0.910463_r8, & - 0.931614_r8, 0.948993_r8, 0.962593_r8, 0.972872_r8, 0.980456_r8/ - data (bm0ij ( 4, 5,ibeta), ibeta = 1,10) / & - 0.848597_r8, 0.857693_r8, 0.877402_r8, 0.900265_r8, 0.922180_r8, & - 0.941134_r8, 0.956464_r8, 0.968298_r8, 0.977143_r8, 0.983611_r8/ - data (bm0ij ( 4, 6,ibeta), ibeta = 1,10) / & - 0.866271_r8, 0.874764_r8, 0.892984_r8, 0.913796_r8, 0.933407_r8, & - 0.950088_r8, 0.963380_r8, 0.973512_r8, 0.981006_r8, 0.986440_r8/ - data (bm0ij ( 4, 7,ibeta), ibeta = 1,10) / & - 0.883430_r8, 0.891216_r8, 0.907762_r8, 0.926388_r8, 0.943660_r8, & - 0.958127_r8, 0.969499_r8, 0.978070_r8, 0.984351_r8, 0.988872_r8/ - data (bm0ij ( 4, 8,ibeta), ibeta = 1,10) / & - 0.899483_r8, 0.906505_r8, 0.921294_r8, 0.937719_r8, 0.952729_r8, & - 0.965131_r8, 0.974762_r8, 0.981950_r8, 0.987175_r8, 0.990912_r8/ - data (bm0ij ( 4, 9,ibeta), ibeta = 1,10) / & - 0.914096_r8, 0.920337_r8, 0.933373_r8, 0.947677_r8, 0.960579_r8, & - 0.971111_r8, 0.979206_r8, 0.985196_r8, 0.989520_r8, 0.992597_r8/ - data (bm0ij ( 4, 10,ibeta), ibeta = 1,10) / & - 0.927122_r8, 0.932597_r8, 0.943952_r8, 0.956277_r8, 0.967268_r8, & - 0.976147_r8, 0.982912_r8, 0.987882_r8, 0.991450_r8, 0.993976_r8/ - data (bm0ij ( 5, 1,ibeta), ibeta = 1,10) / & - 0.865049_r8, 0.872851_r8, 0.889900_r8, 0.909907_r8, 0.929290_r8, & - 0.946205_r8, 0.959991_r8, 0.970706_r8, 0.978764_r8, 0.984692_r8/ - data (bm0ij ( 5, 2,ibeta), ibeta = 1,10) / & - 0.868989_r8, 0.876713_r8, 0.893538_r8, 0.913173_r8, 0.932080_r8, & - 0.948484_r8, 0.961785_r8, 0.972080_r8, 0.979796_r8, 0.985457_r8/ - data (bm0ij ( 5, 3,ibeta), ibeta = 1,10) / & - 0.878010_r8, 0.885524_r8, 0.901756_r8, 0.920464_r8, 0.938235_r8, & - 0.953461_r8, 0.965672_r8, 0.975037_r8, 0.982005_r8, 0.987085_r8/ - data (bm0ij ( 5, 4,ibeta), ibeta = 1,10) / & - 0.889534_r8, 0.896698_r8, 0.912012_r8, 0.929395_r8, 0.945647_r8, & - 0.959366_r8, 0.970227_r8, 0.978469_r8, 0.984547_r8, 0.988950_r8/ - data (bm0ij ( 5, 5,ibeta), ibeta = 1,10) / & - 0.902033_r8, 0.908713_r8, 0.922848_r8, 0.938648_r8, 0.953186_r8, & - 0.965278_r8, 0.974729_r8, 0.981824_r8, 0.987013_r8, 0.990746_r8/ - data (bm0ij ( 5, 6,ibeta), ibeta = 1,10) / & - 0.914496_r8, 0.920599_r8, 0.933389_r8, 0.947485_r8, 0.960262_r8, & - 0.970743_r8, 0.978839_r8, 0.984858_r8, 0.989225_r8, 0.992348_r8/ - data (bm0ij ( 5, 7,ibeta), ibeta = 1,10) / & - 0.926281_r8, 0.931761_r8, 0.943142_r8, 0.955526_r8, 0.966600_r8, & - 0.975573_r8, 0.982431_r8, 0.987485_r8, 0.991128_r8, 0.993718_r8/ - data (bm0ij ( 5, 8,ibeta), ibeta = 1,10) / & - 0.937029_r8, 0.941877_r8, 0.951868_r8, 0.962615_r8, 0.972112_r8, & - 0.979723_r8, 0.985488_r8, 0.989705_r8, 0.992725_r8, 0.994863_r8/ - data (bm0ij ( 5, 9,ibeta), ibeta = 1,10) / & - 0.946580_r8, 0.950819_r8, 0.959494_r8, 0.968732_r8, 0.976811_r8, & - 0.983226_r8, 0.988047_r8, 0.991550_r8, 0.994047_r8, 0.995806_r8/ - data (bm0ij ( 5, 10,ibeta), ibeta = 1,10) / & - 0.954909_r8, 0.958581_r8, 0.966049_r8, 0.973933_r8, 0.980766_r8, & - 0.986149_r8, 0.990166_r8, 0.993070_r8, 0.995130_r8, 0.996577_r8/ - data (bm0ij ( 6, 1,ibeta), ibeta = 1,10) / & - 0.914182_r8, 0.919824_r8, 0.931832_r8, 0.945387_r8, 0.957999_r8, & - 0.968606_r8, 0.976982_r8, 0.983331_r8, 0.988013_r8, 0.991407_r8/ - data (bm0ij ( 6, 2,ibeta), ibeta = 1,10) / & - 0.917139_r8, 0.922665_r8, 0.934395_r8, 0.947580_r8, 0.959792_r8, & - 0.970017_r8, 0.978062_r8, 0.984138_r8, 0.988609_r8, 0.991843_r8/ - data (bm0ij ( 6, 3,ibeta), ibeta = 1,10) / & - 0.923742_r8, 0.928990_r8, 0.940064_r8, 0.952396_r8, 0.963699_r8, & - 0.973070_r8, 0.980381_r8, 0.985866_r8, 0.989878_r8, 0.992768_r8/ - data (bm0ij ( 6, 4,ibeta), ibeta = 1,10) / & - 0.931870_r8, 0.936743_r8, 0.946941_r8, 0.958162_r8, 0.968318_r8, & - 0.976640_r8, 0.983069_r8, 0.987853_r8, 0.991330_r8, 0.993822_r8/ - data (bm0ij ( 6, 5,ibeta), ibeta = 1,10) / & - 0.940376_r8, 0.944807_r8, 0.954004_r8, 0.963999_r8, 0.972928_r8, & - 0.980162_r8, 0.985695_r8, 0.989779_r8, 0.992729_r8, 0.994833_r8/ - data (bm0ij ( 6, 6,ibeta), ibeta = 1,10) / & - 0.948597_r8, 0.952555_r8, 0.960703_r8, 0.969454_r8, 0.977181_r8, & - 0.983373_r8, 0.988067_r8, 0.991507_r8, 0.993977_r8, 0.995730_r8/ - data (bm0ij ( 6, 7,ibeta), ibeta = 1,10) / & - 0.956167_r8, 0.959648_r8, 0.966763_r8, 0.974326_r8, 0.980933_r8, & - 0.986177_r8, 0.990121_r8, 0.992993_r8, 0.995045_r8, 0.996495_r8/ - data (bm0ij ( 6, 8,ibeta), ibeta = 1,10) / & - 0.962913_r8, 0.965937_r8, 0.972080_r8, 0.978552_r8, 0.984153_r8, & - 0.988563_r8, 0.991857_r8, 0.994242_r8, 0.995938_r8, 0.997133_r8/ - data (bm0ij ( 6, 9,ibeta), ibeta = 1,10) / & - 0.968787_r8, 0.971391_r8, 0.976651_r8, 0.982148_r8, 0.986869_r8, & - 0.990560_r8, 0.993301_r8, 0.995275_r8, 0.996675_r8, 0.997657_r8/ - data (bm0ij ( 6, 10,ibeta), ibeta = 1,10) / & - 0.973822_r8, 0.976047_r8, 0.980523_r8, 0.985170_r8, 0.989134_r8, & - 0.992215_r8, 0.994491_r8, 0.996124_r8, 0.997277_r8, 0.998085_r8/ - data (bm0ij ( 7, 1,ibeta), ibeta = 1,10) / & - 0.947410_r8, 0.951207_r8, 0.959119_r8, 0.967781_r8, 0.975592_r8, & - 0.981981_r8, 0.986915_r8, 0.990590_r8, 0.993266_r8, 0.995187_r8/ - data (bm0ij ( 7, 2,ibeta), ibeta = 1,10) / & - 0.949477_r8, 0.953161_r8, 0.960824_r8, 0.969187_r8, 0.976702_r8, & - 0.982831_r8, 0.987550_r8, 0.991057_r8, 0.993606_r8, 0.995434_r8/ - data (bm0ij ( 7, 3,ibeta), ibeta = 1,10) / & - 0.954008_r8, 0.957438_r8, 0.964537_r8, 0.972232_r8, 0.979095_r8, & - 0.984653_r8, 0.988907_r8, 0.992053_r8, 0.994330_r8, 0.995958_r8/ - data (bm0ij ( 7, 4,ibeta), ibeta = 1,10) / & - 0.959431_r8, 0.962539_r8, 0.968935_r8, 0.975808_r8, 0.981882_r8, & - 0.986759_r8, 0.990466_r8, 0.993190_r8, 0.995153_r8, 0.996552_r8/ - data (bm0ij ( 7, 5,ibeta), ibeta = 1,10) / & - 0.964932_r8, 0.967693_r8, 0.973342_r8, 0.979355_r8, 0.984620_r8, & - 0.988812_r8, 0.991974_r8, 0.994285_r8, 0.995943_r8, 0.997119_r8/ - data (bm0ij ( 7, 6,ibeta), ibeta = 1,10) / & - 0.970101_r8, 0.972517_r8, 0.977428_r8, 0.982612_r8, 0.987110_r8, & - 0.990663_r8, 0.993326_r8, 0.995261_r8, 0.996644_r8, 0.997621_r8/ - data (bm0ij ( 7, 7,ibeta), ibeta = 1,10) / & - 0.974746_r8, 0.976834_r8, 0.981055_r8, 0.985475_r8, 0.989280_r8, & - 0.992265_r8, 0.994488_r8, 0.996097_r8, 0.997241_r8, 0.998048_r8/ - data (bm0ij ( 7, 8,ibeta), ibeta = 1,10) / & - 0.978804_r8, 0.980591_r8, 0.984187_r8, 0.987927_r8, 0.991124_r8, & - 0.993617_r8, 0.995464_r8, 0.996795_r8, 0.997739_r8, 0.998403_r8/ - data (bm0ij ( 7, 9,ibeta), ibeta = 1,10) / & - 0.982280_r8, 0.983799_r8, 0.986844_r8, 0.989991_r8, 0.992667_r8, & - 0.994742_r8, 0.996273_r8, 0.997372_r8, 0.998149_r8, 0.998695_r8/ - data (bm0ij ( 7, 10,ibeta), ibeta = 1,10) / & - 0.985218_r8, 0.986503_r8, 0.989071_r8, 0.991711_r8, 0.993945_r8, & - 0.995669_r8, 0.996937_r8, 0.997844_r8, 0.998484_r8, 0.998932_r8/ - data (bm0ij ( 8, 1,ibeta), ibeta = 1,10) / & - 0.968507_r8, 0.970935_r8, 0.975916_r8, 0.981248_r8, 0.985947_r8, & - 0.989716_r8, 0.992580_r8, 0.994689_r8, 0.996210_r8, 0.997297_r8/ - data (bm0ij ( 8, 2,ibeta), ibeta = 1,10) / & - 0.969870_r8, 0.972210_r8, 0.977002_r8, 0.982119_r8, 0.986619_r8, & - 0.990219_r8, 0.992951_r8, 0.994958_r8, 0.996405_r8, 0.997437_r8/ - data (bm0ij ( 8, 3,ibeta), ibeta = 1,10) / & - 0.972820_r8, 0.974963_r8, 0.979339_r8, 0.983988_r8, 0.988054_r8, & - 0.991292_r8, 0.993738_r8, 0.995529_r8, 0.996817_r8, 0.997734_r8/ - data (bm0ij ( 8, 4,ibeta), ibeta = 1,10) / & - 0.976280_r8, 0.978186_r8, 0.982060_r8, 0.986151_r8, 0.989706_r8, & - 0.992520_r8, 0.994636_r8, 0.996179_r8, 0.997284_r8, 0.998069_r8/ - data (bm0ij ( 8, 5,ibeta), ibeta = 1,10) / & - 0.979711_r8, 0.981372_r8, 0.984735_r8, 0.988263_r8, 0.991309_r8, & - 0.993706_r8, 0.995499_r8, 0.996801_r8, 0.997730_r8, 0.998389_r8/ - data (bm0ij ( 8, 6,ibeta), ibeta = 1,10) / & - 0.982863_r8, 0.984292_r8, 0.987172_r8, 0.990174_r8, 0.992750_r8, & - 0.994766_r8, 0.996266_r8, 0.997352_r8, 0.998125_r8, 0.998670_r8/ - data (bm0ij ( 8, 7,ibeta), ibeta = 1,10) / & - 0.985642_r8, 0.986858_r8, 0.989301_r8, 0.991834_r8, 0.993994_r8, & - 0.995676_r8, 0.996923_r8, 0.997822_r8, 0.998460_r8, 0.998910_r8/ - data (bm0ij ( 8, 8,ibeta), ibeta = 1,10) / & - 0.988029_r8, 0.989058_r8, 0.991116_r8, 0.993240_r8, 0.995043_r8, & - 0.996440_r8, 0.997472_r8, 0.998214_r8, 0.998739_r8, 0.999108_r8/ - data (bm0ij ( 8, 9,ibeta), ibeta = 1,10) / & - 0.990046_r8, 0.990912_r8, 0.992640_r8, 0.994415_r8, 0.995914_r8, & - 0.997073_r8, 0.997925_r8, 0.998536_r8, 0.998968_r8, 0.999271_r8/ - data (bm0ij ( 8, 10,ibeta), ibeta = 1,10) / & - 0.991732_r8, 0.992459_r8, 0.993906_r8, 0.995386_r8, 0.996633_r8, & - 0.997592_r8, 0.998296_r8, 0.998799_r8, 0.999154_r8, 0.999403_r8/ - data (bm0ij ( 9, 1,ibeta), ibeta = 1,10) / & - 0.981392_r8, 0.982893_r8, 0.985938_r8, 0.989146_r8, 0.991928_r8, & - 0.994129_r8, 0.995783_r8, 0.996991_r8, 0.997857_r8, 0.998473_r8/ - data (bm0ij ( 9, 2,ibeta), ibeta = 1,10) / & - 0.982254_r8, 0.983693_r8, 0.986608_r8, 0.989673_r8, 0.992328_r8, & - 0.994424_r8, 0.995998_r8, 0.997146_r8, 0.997969_r8, 0.998553_r8/ - data (bm0ij ( 9, 3,ibeta), ibeta = 1,10) / & - 0.984104_r8, 0.985407_r8, 0.988040_r8, 0.990798_r8, 0.993178_r8, & - 0.995052_r8, 0.996454_r8, 0.997474_r8, 0.998204_r8, 0.998722_r8/ - data (bm0ij ( 9, 4,ibeta), ibeta = 1,10) / & - 0.986243_r8, 0.987386_r8, 0.989687_r8, 0.992087_r8, 0.994149_r8, & - 0.995765_r8, 0.996971_r8, 0.997846_r8, 0.998470_r8, 0.998913_r8/ - data (bm0ij ( 9, 5,ibeta), ibeta = 1,10) / & - 0.988332_r8, 0.989313_r8, 0.991284_r8, 0.993332_r8, 0.995082_r8, & - 0.996449_r8, 0.997465_r8, 0.998200_r8, 0.998723_r8, 0.999093_r8/ - data (bm0ij ( 9, 6,ibeta), ibeta = 1,10) / & - 0.990220_r8, 0.991053_r8, 0.992721_r8, 0.994445_r8, 0.995914_r8, & - 0.997056_r8, 0.997902_r8, 0.998513_r8, 0.998947_r8, 0.999253_r8/ - data (bm0ij ( 9, 7,ibeta), ibeta = 1,10) / & - 0.991859_r8, 0.992561_r8, 0.993961_r8, 0.995403_r8, 0.996626_r8, & - 0.997574_r8, 0.998274_r8, 0.998778_r8, 0.999136_r8, 0.999387_r8/ - data (bm0ij ( 9, 8,ibeta), ibeta = 1,10) / & - 0.993250_r8, 0.993837_r8, 0.995007_r8, 0.996208_r8, 0.997223_r8, & - 0.998007_r8, 0.998584_r8, 0.998999_r8, 0.999293_r8, 0.999499_r8/ - data (bm0ij ( 9, 9,ibeta), ibeta = 1,10) / & - 0.994413_r8, 0.994903_r8, 0.995878_r8, 0.996876_r8, 0.997716_r8, & - 0.998363_r8, 0.998839_r8, 0.999180_r8, 0.999421_r8, 0.999591_r8/ - data (bm0ij ( 9, 10,ibeta), ibeta = 1,10) / & - 0.995376_r8, 0.995785_r8, 0.996597_r8, 0.997425_r8, 0.998121_r8, & - 0.998655_r8, 0.999048_r8, 0.999328_r8, 0.999526_r8, 0.999665_r8/ - data (bm0ij ( 10, 1,ibeta), ibeta = 1,10) / & - 0.989082_r8, 0.989991_r8, 0.991819_r8, 0.993723_r8, 0.995357_r8, & - 0.996637_r8, 0.997592_r8, 0.998286_r8, 0.998781_r8, 0.999132_r8/ - data (bm0ij ( 10, 2,ibeta), ibeta = 1,10) / & - 0.989613_r8, 0.990480_r8, 0.992224_r8, 0.994039_r8, 0.995594_r8, & - 0.996810_r8, 0.997717_r8, 0.998375_r8, 0.998845_r8, 0.999178_r8/ - data (bm0ij ( 10, 3,ibeta), ibeta = 1,10) / & - 0.990744_r8, 0.991523_r8, 0.993086_r8, 0.994708_r8, 0.996094_r8, & - 0.997176_r8, 0.997981_r8, 0.998564_r8, 0.998980_r8, 0.999274_r8/ - data (bm0ij ( 10, 4,ibeta), ibeta = 1,10) / & - 0.992041_r8, 0.992716_r8, 0.994070_r8, 0.995470_r8, 0.996662_r8, & - 0.997591_r8, 0.998280_r8, 0.998778_r8, 0.999133_r8, 0.999383_r8/ - data (bm0ij ( 10, 5,ibeta), ibeta = 1,10) / & - 0.993292_r8, 0.993867_r8, 0.995015_r8, 0.996199_r8, 0.997205_r8, & - 0.997985_r8, 0.998564_r8, 0.998981_r8, 0.999277_r8, 0.999487_r8/ - data (bm0ij ( 10, 6,ibeta), ibeta = 1,10) / & - 0.994411_r8, 0.994894_r8, 0.995857_r8, 0.996847_r8, 0.997685_r8, & - 0.998334_r8, 0.998814_r8, 0.999159_r8, 0.999404_r8, 0.999577_r8/ - data (bm0ij ( 10, 7,ibeta), ibeta = 1,10) / & - 0.995373_r8, 0.995776_r8, 0.996577_r8, 0.997400_r8, 0.998094_r8, & - 0.998630_r8, 0.999026_r8, 0.999310_r8, 0.999512_r8, 0.999654_r8/ - data (bm0ij ( 10, 8,ibeta), ibeta = 1,10) / & - 0.996181_r8, 0.996516_r8, 0.997181_r8, 0.997861_r8, 0.998435_r8, & - 0.998877_r8, 0.999202_r8, 0.999435_r8, 0.999601_r8, 0.999717_r8/ - data (bm0ij ( 10, 9,ibeta), ibeta = 1,10) / & - 0.996851_r8, 0.997128_r8, 0.997680_r8, 0.998242_r8, 0.998715_r8, & - 0.999079_r8, 0.999346_r8, 0.999538_r8, 0.999673_r8, 0.999769_r8/ - data (bm0ij ( 10, 10,ibeta), ibeta = 1,10) / & - 0.997402_r8, 0.997632_r8, 0.998089_r8, 0.998554_r8, 0.998945_r8, & - 0.999244_r8, 0.999464_r8, 0.999622_r8, 0.999733_r8, 0.999811_r8/ - - -! rpm.... 3rd moment nuclei mode corr. fac. for bimodal fm coag rate - - data (bm3i( 1, 1,ibeta ), ibeta=1,10)/ & - 0.70708_r8,0.71681_r8,0.73821_r8,0.76477_r8,0.79350_r8,0.82265_r8,0.85090_r8,0.87717_r8, & - 0.90069_r8,0.92097_r8/ - data (bm3i( 1, 2,ibeta ), ibeta=1,10)/ & - 0.72172_r8,0.73022_r8,0.74927_r8,0.77324_r8,0.79936_r8,0.82601_r8,0.85199_r8,0.87637_r8, & - 0.89843_r8,0.91774_r8/ - data (bm3i( 1, 3,ibeta ), ibeta=1,10)/ & - 0.78291_r8,0.78896_r8,0.80286_r8,0.82070_r8,0.84022_r8,0.85997_r8,0.87901_r8,0.89669_r8, & - 0.91258_r8,0.92647_r8/ - data (bm3i( 1, 4,ibeta ), ibeta=1,10)/ & - 0.87760_r8,0.88147_r8,0.89025_r8,0.90127_r8,0.91291_r8,0.92420_r8,0.93452_r8,0.94355_r8, & - 0.95113_r8,0.95726_r8/ - data (bm3i( 1, 5,ibeta ), ibeta=1,10)/ & - 0.94988_r8,0.95184_r8,0.95612_r8,0.96122_r8,0.96628_r8,0.97085_r8,0.97467_r8,0.97763_r8, & - 0.97971_r8,0.98089_r8/ - data (bm3i( 1, 6,ibeta ), ibeta=1,10)/ & - 0.98318_r8,0.98393_r8,0.98551_r8,0.98728_r8,0.98889_r8,0.99014_r8,0.99095_r8,0.99124_r8, & - 0.99100_r8,0.99020_r8/ - data (bm3i( 1, 7,ibeta ), ibeta=1,10)/ & - 0.99480_r8,0.99504_r8,0.99551_r8,0.99598_r8,0.99629_r8,0.99635_r8,0.99611_r8,0.99550_r8, & - 0.99450_r8,0.99306_r8/ - data (bm3i( 1, 8,ibeta ), ibeta=1,10)/ & - 0.99842_r8,0.99848_r8,0.99858_r8,0.99861_r8,0.99850_r8,0.99819_r8,0.99762_r8,0.99674_r8, & - 0.99550_r8,0.99388_r8/ - data (bm3i( 1, 9,ibeta ), ibeta=1,10)/ & - 0.99951_r8,0.99951_r8,0.99949_r8,0.99939_r8,0.99915_r8,0.99872_r8,0.99805_r8,0.99709_r8, & - 0.99579_r8,0.99411_r8/ - data (bm3i( 1,10,ibeta ), ibeta=1,10)/ & - 0.99984_r8,0.99982_r8,0.99976_r8,0.99962_r8,0.99934_r8,0.99888_r8,0.99818_r8,0.99719_r8, & - 0.99587_r8,0.99417_r8/ - data (bm3i( 2, 1,ibeta ), ibeta=1,10)/ & - 0.72957_r8,0.73993_r8,0.76303_r8,0.79178_r8,0.82245_r8,0.85270_r8,0.88085_r8,0.90578_r8, & - 0.92691_r8,0.94415_r8/ - data (bm3i( 2, 2,ibeta ), ibeta=1,10)/ & - 0.72319_r8,0.73320_r8,0.75547_r8,0.78323_r8,0.81307_r8,0.84287_r8,0.87107_r8,0.89651_r8, & - 0.91852_r8,0.93683_r8/ - data (bm3i( 2, 3,ibeta ), ibeta=1,10)/ & - 0.74413_r8,0.75205_r8,0.76998_r8,0.79269_r8,0.81746_r8,0.84258_r8,0.86685_r8,0.88938_r8, & - 0.90953_r8,0.92695_r8/ - data (bm3i( 2, 4,ibeta ), ibeta=1,10)/ & - 0.82588_r8,0.83113_r8,0.84309_r8,0.85825_r8,0.87456_r8,0.89072_r8,0.90594_r8,0.91972_r8, & - 0.93178_r8,0.94203_r8/ - data (bm3i( 2, 5,ibeta ), ibeta=1,10)/ & - 0.91886_r8,0.92179_r8,0.92831_r8,0.93624_r8,0.94434_r8,0.95192_r8,0.95856_r8,0.96409_r8, & - 0.96845_r8,0.97164_r8/ - data (bm3i( 2, 6,ibeta ), ibeta=1,10)/ & - 0.97129_r8,0.97252_r8,0.97515_r8,0.97818_r8,0.98108_r8,0.98354_r8,0.98542_r8,0.98665_r8, & - 0.98721_r8,0.98709_r8/ - data (bm3i( 2, 7,ibeta ), ibeta=1,10)/ & - 0.99104_r8,0.99145_r8,0.99230_r8,0.99320_r8,0.99394_r8,0.99439_r8,0.99448_r8,0.99416_r8, & - 0.99340_r8,0.99217_r8/ - data (bm3i( 2, 8,ibeta ), ibeta=1,10)/ & - 0.99730_r8,0.99741_r8,0.99763_r8,0.99779_r8,0.99782_r8,0.99762_r8,0.99715_r8,0.99636_r8, & - 0.99519_r8,0.99363_r8/ - data (bm3i( 2, 9,ibeta ), ibeta=1,10)/ & - 0.99917_r8,0.99919_r8,0.99921_r8,0.99915_r8,0.99895_r8,0.99856_r8,0.99792_r8,0.99698_r8, & - 0.99570_r8,0.99404_r8/ - data (bm3i( 2,10,ibeta ), ibeta=1,10)/ & - 0.99973_r8,0.99973_r8,0.99968_r8,0.99955_r8,0.99928_r8,0.99883_r8,0.99814_r8,0.99716_r8, & - 0.99584_r8,0.99415_r8/ - data (bm3i( 3, 1,ibeta ), ibeta=1,10)/ & - 0.78358_r8,0.79304_r8,0.81445_r8,0.84105_r8,0.86873_r8,0.89491_r8,0.91805_r8,0.93743_r8, & - 0.95300_r8,0.96510_r8/ - data (bm3i( 3, 2,ibeta ), ibeta=1,10)/ & - 0.76412_r8,0.77404_r8,0.79635_r8,0.82404_r8,0.85312_r8,0.88101_r8,0.90610_r8,0.92751_r8, & - 0.94500_r8,0.95879_r8/ - data (bm3i( 3, 3,ibeta ), ibeta=1,10)/ & - 0.74239_r8,0.75182_r8,0.77301_r8,0.79956_r8,0.82809_r8,0.85639_r8,0.88291_r8,0.90658_r8, & - 0.92683_r8,0.94350_r8/ - data (bm3i( 3, 4,ibeta ), ibeta=1,10)/ & - 0.78072_r8,0.78758_r8,0.80317_r8,0.82293_r8,0.84437_r8,0.86589_r8,0.88643_r8,0.90526_r8, & - 0.92194_r8,0.93625_r8/ - data (bm3i( 3, 5,ibeta ), ibeta=1,10)/ & - 0.87627_r8,0.88044_r8,0.88981_r8,0.90142_r8,0.91357_r8,0.92524_r8,0.93585_r8,0.94510_r8, & - 0.95285_r8,0.95911_r8/ - data (bm3i( 3, 6,ibeta ), ibeta=1,10)/ & - 0.95176_r8,0.95371_r8,0.95796_r8,0.96297_r8,0.96792_r8,0.97233_r8,0.97599_r8,0.97880_r8, & - 0.98072_r8,0.98178_r8/ - data (bm3i( 3, 7,ibeta ), ibeta=1,10)/ & - 0.98453_r8,0.98523_r8,0.98670_r8,0.98833_r8,0.98980_r8,0.99092_r8,0.99160_r8,0.99179_r8, & - 0.99145_r8,0.99058_r8/ - data (bm3i( 3, 8,ibeta ), ibeta=1,10)/ & - 0.99534_r8,0.99555_r8,0.99597_r8,0.99637_r8,0.99662_r8,0.99663_r8,0.99633_r8,0.99569_r8, & - 0.99465_r8,0.99318_r8/ - data (bm3i( 3, 9,ibeta ), ibeta=1,10)/ & - 0.99859_r8,0.99864_r8,0.99872_r8,0.99873_r8,0.99860_r8,0.99827_r8,0.99768_r8,0.99679_r8, & - 0.99555_r8,0.99391_r8/ - data (bm3i( 3,10,ibeta ), ibeta=1,10)/ & - 0.99956_r8,0.99956_r8,0.99953_r8,0.99942_r8,0.99918_r8,0.99875_r8,0.99807_r8,0.99711_r8, & - 0.99580_r8,0.99412_r8/ - data (bm3i( 4, 1,ibeta ), ibeta=1,10)/ & - 0.84432_r8,0.85223_r8,0.86990_r8,0.89131_r8,0.91280_r8,0.93223_r8,0.94861_r8,0.96172_r8, & - 0.97185_r8,0.97945_r8/ - data (bm3i( 4, 2,ibeta ), ibeta=1,10)/ & - 0.82299_r8,0.83164_r8,0.85101_r8,0.87463_r8,0.89857_r8,0.92050_r8,0.93923_r8,0.95443_r8, & - 0.96629_r8,0.97529_r8/ - data (bm3i( 4, 3,ibeta ), ibeta=1,10)/ & - 0.77870_r8,0.78840_r8,0.81011_r8,0.83690_r8,0.86477_r8,0.89124_r8,0.91476_r8,0.93460_r8, & - 0.95063_r8,0.96316_r8/ - data (bm3i( 4, 4,ibeta ), ibeta=1,10)/ & - 0.76386_r8,0.77233_r8,0.79147_r8,0.81557_r8,0.84149_r8,0.86719_r8,0.89126_r8,0.91275_r8, & - 0.93116_r8,0.94637_r8/ - data (bm3i( 4, 5,ibeta ), ibeta=1,10)/ & - 0.82927_r8,0.83488_r8,0.84756_r8,0.86346_r8,0.88040_r8,0.89704_r8,0.91257_r8,0.92649_r8, & - 0.93857_r8,0.94874_r8/ - data (bm3i( 4, 6,ibeta ), ibeta=1,10)/ & - 0.92184_r8,0.92481_r8,0.93136_r8,0.93925_r8,0.94724_r8,0.95462_r8,0.96104_r8,0.96634_r8, & - 0.97048_r8,0.97348_r8/ - data (bm3i( 4, 7,ibeta ), ibeta=1,10)/ & - 0.97341_r8,0.97457_r8,0.97706_r8,0.97991_r8,0.98260_r8,0.98485_r8,0.98654_r8,0.98760_r8, & - 0.98801_r8,0.98777_r8/ - data (bm3i( 4, 8,ibeta ), ibeta=1,10)/ & - 0.99192_r8,0.99229_r8,0.99305_r8,0.99385_r8,0.99449_r8,0.99486_r8,0.99487_r8,0.99449_r8, & - 0.99367_r8,0.99239_r8/ - data (bm3i( 4, 9,ibeta ), ibeta=1,10)/ & - 0.99758_r8,0.99768_r8,0.99787_r8,0.99800_r8,0.99799_r8,0.99777_r8,0.99727_r8,0.99645_r8, & - 0.99527_r8,0.99369_r8/ - data (bm3i( 4,10,ibeta ), ibeta=1,10)/ & - 0.99926_r8,0.99928_r8,0.99928_r8,0.99921_r8,0.99900_r8,0.99860_r8,0.99795_r8,0.99701_r8, & - 0.99572_r8,0.99405_r8/ - data (bm3i( 5, 1,ibeta ), ibeta=1,10)/ & - 0.89577_r8,0.90190_r8,0.91522_r8,0.93076_r8,0.94575_r8,0.95876_r8,0.96932_r8,0.97751_r8, & - 0.98367_r8,0.98820_r8/ - data (bm3i( 5, 2,ibeta ), ibeta=1,10)/ & - 0.87860_r8,0.88547_r8,0.90052_r8,0.91828_r8,0.93557_r8,0.95075_r8,0.96319_r8,0.97292_r8, & - 0.98028_r8,0.98572_r8/ - data (bm3i( 5, 3,ibeta ), ibeta=1,10)/ & - 0.83381_r8,0.84240_r8,0.86141_r8,0.88425_r8,0.90707_r8,0.92770_r8,0.94510_r8,0.95906_r8, & - 0.96986_r8,0.97798_r8/ - data (bm3i( 5, 4,ibeta ), ibeta=1,10)/ & - 0.78530_r8,0.79463_r8,0.81550_r8,0.84127_r8,0.86813_r8,0.89367_r8,0.91642_r8,0.93566_r8, & - 0.95125_r8,0.96347_r8/ - data (bm3i( 5, 5,ibeta ), ibeta=1,10)/ & - 0.79614_r8,0.80332_r8,0.81957_r8,0.84001_r8,0.86190_r8,0.88351_r8,0.90368_r8,0.92169_r8, & - 0.93718_r8,0.95006_r8/ - data (bm3i( 5, 6,ibeta ), ibeta=1,10)/ & - 0.88192_r8,0.88617_r8,0.89565_r8,0.90728_r8,0.91931_r8,0.93076_r8,0.94107_r8,0.94997_r8, & - 0.95739_r8,0.96333_r8/ - data (bm3i( 5, 7,ibeta ), ibeta=1,10)/ & - 0.95509_r8,0.95698_r8,0.96105_r8,0.96583_r8,0.97048_r8,0.97460_r8,0.97796_r8,0.98050_r8, & - 0.98218_r8,0.98304_r8/ - data (bm3i( 5, 8,ibeta ), ibeta=1,10)/ & - 0.98596_r8,0.98660_r8,0.98794_r8,0.98943_r8,0.99074_r8,0.99172_r8,0.99227_r8,0.99235_r8, & - 0.99192_r8,0.99096_r8/ - data (bm3i( 5, 9,ibeta ), ibeta=1,10)/ & - 0.99581_r8,0.99600_r8,0.99637_r8,0.99672_r8,0.99691_r8,0.99687_r8,0.99653_r8,0.99585_r8, & - 0.99478_r8,0.99329_r8/ - data (bm3i( 5,10,ibeta ), ibeta=1,10)/ & - 0.99873_r8,0.99878_r8,0.99884_r8,0.99883_r8,0.99869_r8,0.99834_r8,0.99774_r8,0.99684_r8, & - 0.99558_r8,0.99394_r8/ - data (bm3i( 6, 1,ibeta ), ibeta=1,10)/ & - 0.93335_r8,0.93777_r8,0.94711_r8,0.95764_r8,0.96741_r8,0.97562_r8,0.98210_r8,0.98701_r8, & - 0.99064_r8,0.99327_r8/ - data (bm3i( 6, 2,ibeta ), ibeta=1,10)/ & - 0.92142_r8,0.92646_r8,0.93723_r8,0.94947_r8,0.96096_r8,0.97069_r8,0.97842_r8,0.98431_r8, & - 0.98868_r8,0.99186_r8/ - data (bm3i( 6, 3,ibeta ), ibeta=1,10)/ & - 0.88678_r8,0.89351_r8,0.90810_r8,0.92508_r8,0.94138_r8,0.95549_r8,0.96693_r8,0.97578_r8, & - 0.98243_r8,0.98731_r8/ - data (bm3i( 6, 4,ibeta ), ibeta=1,10)/ & - 0.83249_r8,0.84124_r8,0.86051_r8,0.88357_r8,0.90655_r8,0.92728_r8,0.94477_r8,0.95880_r8, & - 0.96964_r8,0.97779_r8/ - data (bm3i( 6, 5,ibeta ), ibeta=1,10)/ & - 0.79593_r8,0.80444_r8,0.82355_r8,0.84725_r8,0.87211_r8,0.89593_r8,0.91735_r8,0.93566_r8, & - 0.95066_r8,0.96255_r8/ - data (bm3i( 6, 6,ibeta ), ibeta=1,10)/ & - 0.84124_r8,0.84695_r8,0.85980_r8,0.87575_r8,0.89256_r8,0.90885_r8,0.92383_r8,0.93704_r8, & - 0.94830_r8,0.95761_r8/ - data (bm3i( 6, 7,ibeta ), ibeta=1,10)/ & - 0.92721_r8,0.93011_r8,0.93647_r8,0.94406_r8,0.95166_r8,0.95862_r8,0.96460_r8,0.96949_r8, & - 0.97326_r8,0.97595_r8/ - data (bm3i( 6, 8,ibeta ), ibeta=1,10)/ & - 0.97573_r8,0.97681_r8,0.97913_r8,0.98175_r8,0.98421_r8,0.98624_r8,0.98772_r8,0.98860_r8, & - 0.98885_r8,0.98847_r8/ - data (bm3i( 6, 9,ibeta ), ibeta=1,10)/ & - 0.99271_r8,0.99304_r8,0.99373_r8,0.99444_r8,0.99499_r8,0.99528_r8,0.99522_r8,0.99477_r8, & - 0.99390_r8,0.99258_r8/ - data (bm3i( 6,10,ibeta ), ibeta=1,10)/ & - 0.99782_r8,0.99791_r8,0.99807_r8,0.99817_r8,0.99813_r8,0.99788_r8,0.99737_r8,0.99653_r8, & - 0.99533_r8,0.99374_r8/ - data (bm3i( 7, 1,ibeta ), ibeta=1,10)/ & - 0.95858_r8,0.96158_r8,0.96780_r8,0.97460_r8,0.98073_r8,0.98575_r8,0.98963_r8,0.99252_r8, & - 0.99463_r8,0.99615_r8/ - data (bm3i( 7, 2,ibeta ), ibeta=1,10)/ & - 0.95091_r8,0.95438_r8,0.96163_r8,0.96962_r8,0.97688_r8,0.98286_r8,0.98751_r8,0.99099_r8, & - 0.99353_r8,0.99536_r8/ - data (bm3i( 7, 3,ibeta ), ibeta=1,10)/ & - 0.92751_r8,0.93233_r8,0.94255_r8,0.95406_r8,0.96473_r8,0.97366_r8,0.98070_r8,0.98602_r8, & - 0.98994_r8,0.99278_r8/ - data (bm3i( 7, 4,ibeta ), ibeta=1,10)/ & - 0.88371_r8,0.89075_r8,0.90595_r8,0.92351_r8,0.94028_r8,0.95474_r8,0.96642_r8,0.97544_r8, & - 0.98220_r8,0.98715_r8/ - data (bm3i( 7, 5,ibeta ), ibeta=1,10)/ & - 0.82880_r8,0.83750_r8,0.85671_r8,0.87980_r8,0.90297_r8,0.92404_r8,0.94195_r8,0.95644_r8, & - 0.96772_r8,0.97625_r8/ - data (bm3i( 7, 6,ibeta ), ibeta=1,10)/ & - 0.81933_r8,0.82655_r8,0.84279_r8,0.86295_r8,0.88412_r8,0.90449_r8,0.92295_r8,0.93890_r8, & - 0.95215_r8,0.96281_r8/ - data (bm3i( 7, 7,ibeta ), ibeta=1,10)/ & - 0.89099_r8,0.89519_r8,0.90448_r8,0.91577_r8,0.92732_r8,0.93820_r8,0.94789_r8,0.95616_r8, & - 0.96297_r8,0.96838_r8/ - data (bm3i( 7, 8,ibeta ), ibeta=1,10)/ & - 0.95886_r8,0.96064_r8,0.96448_r8,0.96894_r8,0.97324_r8,0.97701_r8,0.98004_r8,0.98228_r8, & - 0.98371_r8,0.98435_r8/ - data (bm3i( 7, 9,ibeta ), ibeta=1,10)/ & - 0.98727_r8,0.98786_r8,0.98908_r8,0.99043_r8,0.99160_r8,0.99245_r8,0.99288_r8,0.99285_r8, & - 0.99234_r8,0.99131_r8/ - data (bm3i( 7,10,ibeta ), ibeta=1,10)/ & - 0.99621_r8,0.99638_r8,0.99671_r8,0.99700_r8,0.99715_r8,0.99707_r8,0.99670_r8,0.99599_r8, & - 0.99489_r8,0.99338_r8/ - data (bm3i( 8, 1,ibeta ), ibeta=1,10)/ & - 0.97470_r8,0.97666_r8,0.98064_r8,0.98491_r8,0.98867_r8,0.99169_r8,0.99399_r8,0.99569_r8, & - 0.99691_r8,0.99779_r8/ - data (bm3i( 8, 2,ibeta ), ibeta=1,10)/ & - 0.96996_r8,0.97225_r8,0.97693_r8,0.98196_r8,0.98643_r8,0.99003_r8,0.99279_r8,0.99482_r8, & - 0.99630_r8,0.99735_r8/ - data (bm3i( 8, 3,ibeta ), ibeta=1,10)/ & - 0.95523_r8,0.95848_r8,0.96522_r8,0.97260_r8,0.97925_r8,0.98468_r8,0.98888_r8,0.99200_r8, & - 0.99427_r8,0.99590_r8/ - data (bm3i( 8, 4,ibeta ), ibeta=1,10)/ & - 0.92524_r8,0.93030_r8,0.94098_r8,0.95294_r8,0.96397_r8,0.97317_r8,0.98038_r8,0.98582_r8, & - 0.98981_r8,0.99270_r8/ - data (bm3i( 8, 5,ibeta ), ibeta=1,10)/ & - 0.87576_r8,0.88323_r8,0.89935_r8,0.91799_r8,0.93583_r8,0.95126_r8,0.96377_r8,0.97345_r8, & - 0.98072_r8,0.98606_r8/ - data (bm3i( 8, 6,ibeta ), ibeta=1,10)/ & - 0.83078_r8,0.83894_r8,0.85705_r8,0.87899_r8,0.90126_r8,0.92179_r8,0.93950_r8,0.95404_r8, & - 0.96551_r8,0.97430_r8/ - data (bm3i( 8, 7,ibeta ), ibeta=1,10)/ & - 0.85727_r8,0.86294_r8,0.87558_r8,0.89111_r8,0.90723_r8,0.92260_r8,0.93645_r8,0.94841_r8, & - 0.95838_r8,0.96643_r8/ - data (bm3i( 8, 8,ibeta ), ibeta=1,10)/ & - 0.93337_r8,0.93615_r8,0.94220_r8,0.94937_r8,0.95647_r8,0.96292_r8,0.96840_r8,0.97283_r8, & - 0.97619_r8,0.97854_r8/ - data (bm3i( 8, 9,ibeta ), ibeta=1,10)/ & - 0.97790_r8,0.97891_r8,0.98105_r8,0.98346_r8,0.98569_r8,0.98751_r8,0.98879_r8,0.98950_r8, & - 0.98961_r8,0.98912_r8/ - data (bm3i( 8,10,ibeta ), ibeta=1,10)/ & - 0.99337_r8,0.99367_r8,0.99430_r8,0.99493_r8,0.99541_r8,0.99562_r8,0.99551_r8,0.99501_r8, & - 0.99410_r8,0.99274_r8/ - data (bm3i( 9, 1,ibeta ), ibeta=1,10)/ & - 0.98470_r8,0.98594_r8,0.98844_r8,0.99106_r8,0.99334_r8,0.99514_r8,0.99650_r8,0.99749_r8, & - 0.99821_r8,0.99872_r8/ - data (bm3i( 9, 2,ibeta ), ibeta=1,10)/ & - 0.98184_r8,0.98330_r8,0.98624_r8,0.98934_r8,0.99205_r8,0.99420_r8,0.99582_r8,0.99701_r8, & - 0.99787_r8,0.99848_r8/ - data (bm3i( 9, 3,ibeta ), ibeta=1,10)/ & - 0.97288_r8,0.97498_r8,0.97927_r8,0.98385_r8,0.98789_r8,0.99113_r8,0.99360_r8,0.99541_r8, & - 0.99673_r8,0.99766_r8/ - data (bm3i( 9, 4,ibeta ), ibeta=1,10)/ & - 0.95403_r8,0.95741_r8,0.96440_r8,0.97202_r8,0.97887_r8,0.98444_r8,0.98872_r8,0.99190_r8, & - 0.99421_r8,0.99586_r8/ - data (bm3i( 9, 5,ibeta ), ibeta=1,10)/ & - 0.91845_r8,0.92399_r8,0.93567_r8,0.94873_r8,0.96076_r8,0.97079_r8,0.97865_r8,0.98457_r8, & - 0.98892_r8,0.99206_r8/ - data (bm3i( 9, 6,ibeta ), ibeta=1,10)/ & - 0.86762_r8,0.87533_r8,0.89202_r8,0.91148_r8,0.93027_r8,0.94669_r8,0.96013_r8,0.97062_r8, & - 0.97855_r8,0.98441_r8/ - data (bm3i( 9, 7,ibeta ), ibeta=1,10)/ & - 0.84550_r8,0.85253_r8,0.86816_r8,0.88721_r8,0.90671_r8,0.92490_r8,0.94083_r8,0.95413_r8, & - 0.96481_r8,0.97314_r8/ - data (bm3i( 9, 8,ibeta ), ibeta=1,10)/ & - 0.90138_r8,0.90544_r8,0.91437_r8,0.92513_r8,0.93602_r8,0.94615_r8,0.95506_r8,0.96258_r8, & - 0.96868_r8,0.97347_r8/ - data (bm3i( 9, 9,ibeta ), ibeta=1,10)/ & - 0.96248_r8,0.96415_r8,0.96773_r8,0.97187_r8,0.97583_r8,0.97925_r8,0.98198_r8,0.98394_r8, & - 0.98514_r8,0.98559_r8/ - data (bm3i( 9,10,ibeta ), ibeta=1,10)/ & - 0.98837_r8,0.98892_r8,0.99005_r8,0.99127_r8,0.99232_r8,0.99306_r8,0.99339_r8,0.99328_r8, & - 0.99269_r8,0.99161_r8/ - data (bm3i(10, 1,ibeta ), ibeta=1,10)/ & - 0.99080_r8,0.99158_r8,0.99311_r8,0.99471_r8,0.99607_r8,0.99715_r8,0.99795_r8,0.99853_r8, & - 0.99895_r8,0.99925_r8/ - data (bm3i(10, 2,ibeta ), ibeta=1,10)/ & - 0.98910_r8,0.99001_r8,0.99182_r8,0.99371_r8,0.99533_r8,0.99661_r8,0.99757_r8,0.99826_r8, & - 0.99876_r8,0.99912_r8/ - data (bm3i(10, 3,ibeta ), ibeta=1,10)/ & - 0.98374_r8,0.98506_r8,0.98772_r8,0.99051_r8,0.99294_r8,0.99486_r8,0.99630_r8,0.99736_r8, & - 0.99812_r8,0.99866_r8/ - data (bm3i(10, 4,ibeta ), ibeta=1,10)/ & - 0.97238_r8,0.97453_r8,0.97892_r8,0.98361_r8,0.98773_r8,0.99104_r8,0.99354_r8,0.99538_r8, & - 0.99671_r8,0.99765_r8/ - data (bm3i(10, 5,ibeta ), ibeta=1,10)/ & - 0.94961_r8,0.95333_r8,0.96103_r8,0.96941_r8,0.97693_r8,0.98303_r8,0.98772_r8,0.99119_r8, & - 0.99371_r8,0.99551_r8/ - data (bm3i(10, 6,ibeta ), ibeta=1,10)/ & - 0.90943_r8,0.91550_r8,0.92834_r8,0.94275_r8,0.95608_r8,0.96723_r8,0.97600_r8,0.98263_r8, & - 0.98751_r8,0.99103_r8/ - data (bm3i(10, 7,ibeta ), ibeta=1,10)/ & - 0.86454_r8,0.87200_r8,0.88829_r8,0.90749_r8,0.92630_r8,0.94300_r8,0.95687_r8,0.96785_r8, & - 0.97626_r8,0.98254_r8/ - data (bm3i(10, 8,ibeta ), ibeta=1,10)/ & - 0.87498_r8,0.88048_r8,0.89264_r8,0.90737_r8,0.92240_r8,0.93642_r8,0.94877_r8,0.95917_r8, & - 0.96762_r8,0.97429_r8/ - data (bm3i(10, 9,ibeta ), ibeta=1,10)/ & - 0.93946_r8,0.94209_r8,0.94781_r8,0.95452_r8,0.96111_r8,0.96704_r8,0.97203_r8,0.97602_r8, & - 0.97900_r8,0.98106_r8/ - data (bm3i(10,10,ibeta ), ibeta=1,10)/ & - 0.97977_r8,0.98071_r8,0.98270_r8,0.98492_r8,0.98695_r8,0.98858_r8,0.98970_r8,0.99027_r8, & - 0.99026_r8,0.98968_r8/ - -! fsb fm correction for intramodal m2 coagulation - data bm2ii / & - 0.707107_r8, 0.720583_r8, 0.745310_r8, 0.748056_r8, 0.696935_r8, & - 0.604164_r8, 0.504622_r8, 0.416559_r8, 0.343394_r8, 0.283641_r8/ - -! *** total correction for intramodal m2 coagulation - - data bm2iitt / & - 1.000000_r8, 0.907452_r8, 0.680931_r8, 0.409815_r8, 0.196425_r8, & - 0.078814_r8, 0.028473_r8, 0.009800_r8, 0.003322_r8, 0.001129_r8/ - - -! fsb fm correction for m2 i to j coagulation - - data (bm2ij ( 1, 1,ibeta), ibeta = 1,10) / & - 0.707107_r8, 0.716828_r8, 0.738240_r8, 0.764827_r8, 0.793610_r8, & - 0.822843_r8, 0.851217_r8, 0.877670_r8, 0.901404_r8, 0.921944_r8/ - data (bm2ij ( 1, 2,ibeta), ibeta = 1,10) / & - 0.719180_r8, 0.727975_r8, 0.747638_r8, 0.772334_r8, 0.799234_r8, & - 0.826666_r8, 0.853406_r8, 0.878482_r8, 0.901162_r8, 0.920987_r8/ - data (bm2ij ( 1, 3,ibeta), ibeta = 1,10) / & - 0.760947_r8, 0.767874_r8, 0.783692_r8, 0.803890_r8, 0.826015_r8, & - 0.848562_r8, 0.870498_r8, 0.891088_r8, 0.909823_r8, 0.926400_r8/ - data (bm2ij ( 1, 4,ibeta), ibeta = 1,10) / & - 0.830926_r8, 0.836034_r8, 0.847708_r8, 0.862528_r8, 0.878521_r8, & - 0.894467_r8, 0.909615_r8, 0.923520_r8, 0.935959_r8, 0.946858_r8/ - data (bm2ij ( 1, 5,ibeta), ibeta = 1,10) / & - 0.903643_r8, 0.907035_r8, 0.914641_r8, 0.924017_r8, 0.933795_r8, & - 0.943194_r8, 0.951806_r8, 0.959449_r8, 0.966087_r8, 0.971761_r8/ - data (bm2ij ( 1, 6,ibeta), ibeta = 1,10) / & - 0.954216_r8, 0.956094_r8, 0.960211_r8, 0.965123_r8, 0.970068_r8, & - 0.974666_r8, 0.978750_r8, 0.982277_r8, 0.985268_r8, 0.987775_r8/ - data (bm2ij ( 1, 7,ibeta), ibeta = 1,10) / & - 0.980546_r8, 0.981433_r8, 0.983343_r8, 0.985568_r8, 0.987751_r8, & - 0.989735_r8, 0.991461_r8, 0.992926_r8, 0.994150_r8, 0.995164_r8/ - data (bm2ij ( 1, 8,ibeta), ibeta = 1,10) / & - 0.992142_r8, 0.992524_r8, 0.993338_r8, 0.994272_r8, 0.995174_r8, & - 0.995981_r8, 0.996675_r8, 0.997257_r8, 0.997740_r8, 0.998137_r8/ - data (bm2ij ( 1, 9,ibeta), ibeta = 1,10) / & - 0.996868_r8, 0.997026_r8, 0.997361_r8, 0.997742_r8, 0.998106_r8, & - 0.998430_r8, 0.998705_r8, 0.998935_r8, 0.999125_r8, 0.999280_r8/ - data (bm2ij ( 1, 10,ibeta), ibeta = 1,10) / & - 0.998737_r8, 0.998802_r8, 0.998939_r8, 0.999094_r8, 0.999241_r8, & - 0.999371_r8, 0.999481_r8, 0.999573_r8, 0.999648_r8, 0.999709_r8/ - data (bm2ij ( 2, 1,ibeta), ibeta = 1,10) / & - 0.729600_r8, 0.739948_r8, 0.763059_r8, 0.791817_r8, 0.822510_r8, & - 0.852795_r8, 0.881000_r8, 0.905999_r8, 0.927206_r8, 0.944532_r8/ - data (bm2ij ( 2, 2,ibeta), ibeta = 1,10) / & - 0.727025_r8, 0.737116_r8, 0.759615_r8, 0.787657_r8, 0.817740_r8, & - 0.847656_r8, 0.875801_r8, 0.901038_r8, 0.922715_r8, 0.940643_r8/ - data (bm2ij ( 2, 3,ibeta), ibeta = 1,10) / & - 0.738035_r8, 0.746779_r8, 0.766484_r8, 0.791340_r8, 0.818324_r8, & - 0.845546_r8, 0.871629_r8, 0.895554_r8, 0.916649_r8, 0.934597_r8/ - data (bm2ij ( 2, 4,ibeta), ibeta = 1,10) / & - 0.784185_r8, 0.790883_r8, 0.806132_r8, 0.825501_r8, 0.846545_r8, & - 0.867745_r8, 0.888085_r8, 0.906881_r8, 0.923705_r8, 0.938349_r8/ - data (bm2ij ( 2, 5,ibeta), ibeta = 1,10) / & - 0.857879_r8, 0.862591_r8, 0.873238_r8, 0.886539_r8, 0.900645_r8, & - 0.914463_r8, 0.927360_r8, 0.939004_r8, 0.949261_r8, 0.958125_r8/ - data (bm2ij ( 2, 6,ibeta), ibeta = 1,10) / & - 0.925441_r8, 0.928304_r8, 0.934645_r8, 0.942324_r8, 0.950181_r8, & - 0.957600_r8, 0.964285_r8, 0.970133_r8, 0.975147_r8, 0.979388_r8/ - data (bm2ij ( 2, 7,ibeta), ibeta = 1,10) / & - 0.966728_r8, 0.968176_r8, 0.971323_r8, 0.975027_r8, 0.978705_r8, & - 0.982080_r8, 0.985044_r8, 0.987578_r8, 0.989710_r8, 0.991485_r8/ - data (bm2ij ( 2, 8,ibeta), ibeta = 1,10) / & - 0.986335_r8, 0.986980_r8, 0.988362_r8, 0.989958_r8, 0.991511_r8, & - 0.992912_r8, 0.994122_r8, 0.995143_r8, 0.995992_r8, 0.996693_r8/ - data (bm2ij ( 2, 9,ibeta), ibeta = 1,10) / & - 0.994547_r8, 0.994817_r8, 0.995391_r8, 0.996046_r8, 0.996677_r8, & - 0.997238_r8, 0.997719_r8, 0.998122_r8, 0.998454_r8, 0.998727_r8/ - data (bm2ij ( 2, 10,ibeta), ibeta = 1,10) / & - 0.997817_r8, 0.997928_r8, 0.998163_r8, 0.998429_r8, 0.998683_r8, & - 0.998908_r8, 0.999099_r8, 0.999258_r8, 0.999389_r8, 0.999497_r8/ - data (bm2ij ( 3, 1,ibeta), ibeta = 1,10) / & - 0.783612_r8, 0.793055_r8, 0.814468_r8, 0.841073_r8, 0.868769_r8, & - 0.894963_r8, 0.918118_r8, 0.937527_r8, 0.953121_r8, 0.965244_r8/ - data (bm2ij ( 3, 2,ibeta), ibeta = 1,10) / & - 0.772083_r8, 0.781870_r8, 0.803911_r8, 0.831238_r8, 0.859802_r8, & - 0.887036_r8, 0.911349_r8, 0.931941_r8, 0.948649_r8, 0.961751_r8/ - data (bm2ij ( 3, 3,ibeta), ibeta = 1,10) / & - 0.755766_r8, 0.765509_r8, 0.787380_r8, 0.814630_r8, 0.843526_r8, & - 0.871670_r8, 0.897443_r8, 0.919870_r8, 0.938557_r8, 0.953576_r8/ - data (bm2ij ( 3, 4,ibeta), ibeta = 1,10) / & - 0.763816_r8, 0.772145_r8, 0.790997_r8, 0.814784_r8, 0.840434_r8, & - 0.865978_r8, 0.890034_r8, 0.911671_r8, 0.930366_r8, 0.945963_r8/ - data (bm2ij ( 3, 5,ibeta), ibeta = 1,10) / & - 0.813597_r8, 0.819809_r8, 0.833889_r8, 0.851618_r8, 0.870640_r8, & - 0.889514_r8, 0.907326_r8, 0.923510_r8, 0.937768_r8, 0.950003_r8/ - data (bm2ij ( 3, 6,ibeta), ibeta = 1,10) / & - 0.886317_r8, 0.890437_r8, 0.899643_r8, 0.910955_r8, 0.922730_r8, & - 0.934048_r8, 0.944422_r8, 0.953632_r8, 0.961624_r8, 0.968444_r8/ - data (bm2ij ( 3, 7,ibeta), ibeta = 1,10) / & - 0.944565_r8, 0.946855_r8, 0.951872_r8, 0.957854_r8, 0.963873_r8, & - 0.969468_r8, 0.974438_r8, 0.978731_r8, 0.982372_r8, 0.985424_r8/ - data (bm2ij ( 3, 8,ibeta), ibeta = 1,10) / & - 0.976358_r8, 0.977435_r8, 0.979759_r8, 0.982467_r8, 0.985125_r8, & - 0.987540_r8, 0.989642_r8, 0.991425_r8, 0.992916_r8, 0.994150_r8/ - data (bm2ij ( 3, 9,ibeta), ibeta = 1,10) / & - 0.990471_r8, 0.990932_r8, 0.991917_r8, 0.993048_r8, 0.994142_r8, & - 0.995121_r8, 0.995964_r8, 0.996671_r8, 0.997258_r8, 0.997740_r8/ - data (bm2ij ( 3, 10,ibeta), ibeta = 1,10) / & - 0.996199_r8, 0.996389_r8, 0.996794_r8, 0.997254_r8, 0.997694_r8, & - 0.998086_r8, 0.998420_r8, 0.998699_r8, 0.998929_r8, 0.999117_r8/ - data (bm2ij ( 4, 1,ibeta), ibeta = 1,10) / & - 0.844355_r8, 0.852251_r8, 0.869914_r8, 0.891330_r8, 0.912823_r8, & - 0.932259_r8, 0.948642_r8, 0.961767_r8, 0.971897_r8, 0.979510_r8/ - data (bm2ij ( 4, 2,ibeta), ibeta = 1,10) / & - 0.831550_r8, 0.839954_r8, 0.858754_r8, 0.881583_r8, 0.904592_r8, & - 0.925533_r8, 0.943309_r8, 0.957647_r8, 0.968779_r8, 0.977185_r8/ - data (bm2ij ( 4, 3,ibeta), ibeta = 1,10) / & - 0.803981_r8, 0.813288_r8, 0.834060_r8, 0.859400_r8, 0.885285_r8, & - 0.909286_r8, 0.930084_r8, 0.947193_r8, 0.960714_r8, 0.971078_r8/ - data (bm2ij ( 4, 4,ibeta), ibeta = 1,10) / & - 0.781787_r8, 0.791080_r8, 0.811931_r8, 0.837749_r8, 0.864768_r8, & - 0.890603_r8, 0.913761_r8, 0.933477_r8, 0.949567_r8, 0.962261_r8/ - data (bm2ij ( 4, 5,ibeta), ibeta = 1,10) / & - 0.791591_r8, 0.799355_r8, 0.816916_r8, 0.838961_r8, 0.862492_r8, & - 0.885595_r8, 0.907003_r8, 0.925942_r8, 0.942052_r8, 0.955310_r8/ - data (bm2ij ( 4, 6,ibeta), ibeta = 1,10) / & - 0.844933_r8, 0.850499_r8, 0.863022_r8, 0.878593_r8, 0.895038_r8, & - 0.911072_r8, 0.925939_r8, 0.939227_r8, 0.950765_r8, 0.960550_r8/ - data (bm2ij ( 4, 7,ibeta), ibeta = 1,10) / & - 0.912591_r8, 0.916022_r8, 0.923607_r8, 0.932777_r8, 0.942151_r8, & - 0.951001_r8, 0.958976_r8, 0.965950_r8, 0.971924_r8, 0.976965_r8/ - data (bm2ij ( 4, 8,ibeta), ibeta = 1,10) / & - 0.959859_r8, 0.961617_r8, 0.965433_r8, 0.969924_r8, 0.974382_r8, & - 0.978472_r8, 0.982063_r8, 0.985134_r8, 0.987716_r8, 0.989865_r8/ - data (bm2ij ( 4, 9,ibeta), ibeta = 1,10) / & - 0.983377_r8, 0.984162_r8, 0.985844_r8, 0.987788_r8, 0.989681_r8, & - 0.991386_r8, 0.992860_r8, 0.994104_r8, 0.995139_r8, 0.995991_r8/ - data (bm2ij ( 4, 10,ibeta), ibeta = 1,10) / & - 0.993343_r8, 0.993672_r8, 0.994370_r8, 0.995169_r8, 0.995937_r8, & - 0.996622_r8, 0.997209_r8, 0.997700_r8, 0.998106_r8, 0.998439_r8/ - data (bm2ij ( 5, 1,ibeta), ibeta = 1,10) / & - 0.895806_r8, 0.901918_r8, 0.915233_r8, 0.930783_r8, 0.945768_r8, & - 0.958781_r8, 0.969347_r8, 0.977540_r8, 0.983697_r8, 0.988225_r8/ - data (bm2ij ( 5, 2,ibeta), ibeta = 1,10) / & - 0.885634_r8, 0.892221_r8, 0.906629_r8, 0.923540_r8, 0.939918_r8, & - 0.954213_r8, 0.965873_r8, 0.974951_r8, 0.981794_r8, 0.986840_r8/ - data (bm2ij ( 5, 3,ibeta), ibeta = 1,10) / & - 0.860120_r8, 0.867858_r8, 0.884865_r8, 0.904996_r8, 0.924724_r8, & - 0.942177_r8, 0.956602_r8, 0.967966_r8, 0.976616_r8, 0.983043_r8/ - data (bm2ij ( 5, 4,ibeta), ibeta = 1,10) / & - 0.827462_r8, 0.836317_r8, 0.855885_r8, 0.879377_r8, 0.902897_r8, & - 0.924232_r8, 0.942318_r8, 0.956900_r8, 0.968222_r8, 0.976774_r8/ - data (bm2ij ( 5, 5,ibeta), ibeta = 1,10) / & - 0.805527_r8, 0.814279_r8, 0.833853_r8, 0.857892_r8, 0.882726_r8, & - 0.906095_r8, 0.926690_r8, 0.943938_r8, 0.957808_r8, 0.968615_r8/ - data (bm2ij ( 5, 6,ibeta), ibeta = 1,10) / & - 0.820143_r8, 0.827223_r8, 0.843166_r8, 0.863002_r8, 0.883905_r8, & - 0.904128_r8, 0.922585_r8, 0.938687_r8, 0.952222_r8, 0.963255_r8/ - data (bm2ij ( 5, 7,ibeta), ibeta = 1,10) / & - 0.875399_r8, 0.880208_r8, 0.890929_r8, 0.904065_r8, 0.917699_r8, & - 0.930756_r8, 0.942656_r8, 0.953131_r8, 0.962113_r8, 0.969657_r8/ - data (bm2ij ( 5, 8,ibeta), ibeta = 1,10) / & - 0.934782_r8, 0.937520_r8, 0.943515_r8, 0.950656_r8, 0.957840_r8, & - 0.964516_r8, 0.970446_r8, 0.975566_r8, 0.979905_r8, 0.983534_r8/ - data (bm2ij ( 5, 9,ibeta), ibeta = 1,10) / & - 0.971369_r8, 0.972679_r8, 0.975505_r8, 0.978797_r8, 0.982029_r8, & - 0.984964_r8, 0.987518_r8, 0.989685_r8, 0.991496_r8, 0.992994_r8/ - data (bm2ij ( 5, 10,ibeta), ibeta = 1,10) / & - 0.988329_r8, 0.988893_r8, 0.990099_r8, 0.991485_r8, 0.992825_r8, & - 0.994025_r8, 0.995058_r8, 0.995925_r8, 0.996643_r8, 0.997234_r8/ - data (bm2ij ( 6, 1,ibeta), ibeta = 1,10) / & - 0.933384_r8, 0.937784_r8, 0.947130_r8, 0.957655_r8, 0.967430_r8, & - 0.975639_r8, 0.982119_r8, 0.987031_r8, 0.990657_r8, 0.993288_r8/ - data (bm2ij ( 6, 2,ibeta), ibeta = 1,10) / & - 0.926445_r8, 0.931227_r8, 0.941426_r8, 0.952975_r8, 0.963754_r8, & - 0.972845_r8, 0.980044_r8, 0.985514_r8, 0.989558_r8, 0.992498_r8/ - data (bm2ij ( 6, 3,ibeta), ibeta = 1,10) / & - 0.907835_r8, 0.913621_r8, 0.926064_r8, 0.940308_r8, 0.953745_r8, & - 0.965189_r8, 0.974327_r8, 0.981316_r8, 0.986510_r8, 0.990297_r8/ - data (bm2ij ( 6, 4,ibeta), ibeta = 1,10) / & - 0.879088_r8, 0.886306_r8, 0.901945_r8, 0.920079_r8, 0.937460_r8, & - 0.952509_r8, 0.964711_r8, 0.974166_r8, 0.981265_r8, 0.986484_r8/ - data (bm2ij ( 6, 5,ibeta), ibeta = 1,10) / & - 0.846500_r8, 0.854862_r8, 0.873189_r8, 0.894891_r8, 0.916264_r8, & - 0.935315_r8, 0.951197_r8, 0.963812_r8, 0.973484_r8, 0.980715_r8/ - data (bm2ij ( 6, 6,ibeta), ibeta = 1,10) / & - 0.828137_r8, 0.836250_r8, 0.854310_r8, 0.876287_r8, 0.898710_r8, & - 0.919518_r8, 0.937603_r8, 0.952560_r8, 0.964461_r8, 0.973656_r8/ - data (bm2ij ( 6, 7,ibeta), ibeta = 1,10) / & - 0.848595_r8, 0.854886_r8, 0.868957_r8, 0.886262_r8, 0.904241_r8, & - 0.921376_r8, 0.936799_r8, 0.950096_r8, 0.961172_r8, 0.970145_r8/ - data (bm2ij ( 6, 8,ibeta), ibeta = 1,10) / & - 0.902919_r8, 0.906922_r8, 0.915760_r8, 0.926427_r8, 0.937312_r8, & - 0.947561_r8, 0.956758_r8, 0.964747_r8, 0.971525_r8, 0.977175_r8/ - data (bm2ij ( 6, 9,ibeta), ibeta = 1,10) / & - 0.952320_r8, 0.954434_r8, 0.959021_r8, 0.964418_r8, 0.969774_r8, & - 0.974688_r8, 0.979003_r8, 0.982690_r8, 0.985789_r8, 0.988364_r8/ - data (bm2ij ( 6, 10,ibeta), ibeta = 1,10) / & - 0.979689_r8, 0.980650_r8, 0.982712_r8, 0.985093_r8, 0.987413_r8, & - 0.989502_r8, 0.991308_r8, 0.992831_r8, 0.994098_r8, 0.995142_r8/ - data (bm2ij ( 7, 1,ibeta), ibeta = 1,10) / & - 0.958611_r8, 0.961598_r8, 0.967817_r8, 0.974620_r8, 0.980752_r8, & - 0.985771_r8, 0.989650_r8, 0.992543_r8, 0.994653_r8, 0.996171_r8/ - data (bm2ij ( 7, 2,ibeta), ibeta = 1,10) / & - 0.954225_r8, 0.957488_r8, 0.964305_r8, 0.971795_r8, 0.978576_r8, & - 0.984144_r8, 0.988458_r8, 0.991681_r8, 0.994034_r8, 0.995728_r8/ - data (bm2ij ( 7, 3,ibeta), ibeta = 1,10) / & - 0.942147_r8, 0.946158_r8, 0.954599_r8, 0.963967_r8, 0.972529_r8, & - 0.979612_r8, 0.985131_r8, 0.989271_r8, 0.992301_r8, 0.994487_r8/ - data (bm2ij ( 7, 4,ibeta), ibeta = 1,10) / & - 0.921821_r8, 0.927048_r8, 0.938140_r8, 0.950598_r8, 0.962118_r8, & - 0.971752_r8, 0.979326_r8, 0.985046_r8, 0.989254_r8, 0.992299_r8/ - data (bm2ij ( 7, 5,ibeta), ibeta = 1,10) / & - 0.893419_r8, 0.900158_r8, 0.914598_r8, 0.931070_r8, 0.946584_r8, & - 0.959795_r8, 0.970350_r8, 0.978427_r8, 0.984432_r8, 0.988811_r8/ - data (bm2ij ( 7, 6,ibeta), ibeta = 1,10) / & - 0.863302_r8, 0.871111_r8, 0.888103_r8, 0.907990_r8, 0.927305_r8, & - 0.944279_r8, 0.958245_r8, 0.969211_r8, 0.977540_r8, 0.983720_r8/ - data (bm2ij ( 7, 7,ibeta), ibeta = 1,10) / & - 0.850182_r8, 0.857560_r8, 0.873890_r8, 0.893568_r8, 0.913408_r8, & - 0.931591_r8, 0.947216_r8, 0.960014_r8, 0.970121_r8, 0.977886_r8/ - data (bm2ij ( 7, 8,ibeta), ibeta = 1,10) / & - 0.875837_r8, 0.881265_r8, 0.893310_r8, 0.907936_r8, 0.922910_r8, & - 0.936977_r8, 0.949480_r8, 0.960154_r8, 0.968985_r8, 0.976111_r8/ - data (bm2ij ( 7, 9,ibeta), ibeta = 1,10) / & - 0.926228_r8, 0.929445_r8, 0.936486_r8, 0.944868_r8, 0.953293_r8, & - 0.961108_r8, 0.968028_r8, 0.973973_r8, 0.978974_r8, 0.983118_r8/ - data (bm2ij ( 7, 10,ibeta), ibeta = 1,10) / & - 0.965533_r8, 0.967125_r8, 0.970558_r8, 0.974557_r8, 0.978484_r8, & - 0.982050_r8, 0.985153_r8, 0.987785_r8, 0.989982_r8, 0.991798_r8/ - data (bm2ij ( 8, 1,ibeta), ibeta = 1,10) / & - 0.974731_r8, 0.976674_r8, 0.980660_r8, 0.984926_r8, 0.988689_r8, & - 0.991710_r8, 0.994009_r8, 0.995703_r8, 0.996929_r8, 0.997805_r8/ - data (bm2ij ( 8, 2,ibeta), ibeta = 1,10) / & - 0.972062_r8, 0.974192_r8, 0.978571_r8, 0.983273_r8, 0.987432_r8, & - 0.990780_r8, 0.993333_r8, 0.995218_r8, 0.996581_r8, 0.997557_r8/ - data (bm2ij ( 8, 3,ibeta), ibeta = 1,10) / & - 0.964662_r8, 0.967300_r8, 0.972755_r8, 0.978659_r8, 0.983921_r8, & - 0.988181_r8, 0.991444_r8, 0.993859_r8, 0.995610_r8, 0.996863_r8/ - data (bm2ij ( 8, 4,ibeta), ibeta = 1,10) / & - 0.951782_r8, 0.955284_r8, 0.962581_r8, 0.970559_r8, 0.977737_r8, & - 0.983593_r8, 0.988103_r8, 0.991454_r8, 0.993889_r8, 0.995635_r8/ - data (bm2ij ( 8, 5,ibeta), ibeta = 1,10) / & - 0.931947_r8, 0.936723_r8, 0.946751_r8, 0.957843_r8, 0.967942_r8, & - 0.976267_r8, 0.982734_r8, 0.987571_r8, 0.991102_r8, 0.993642_r8/ - data (bm2ij ( 8, 6,ibeta), ibeta = 1,10) / & - 0.905410_r8, 0.911665_r8, 0.924950_r8, 0.939908_r8, 0.953798_r8, & - 0.965469_r8, 0.974684_r8, 0.981669_r8, 0.986821_r8, 0.990556_r8/ - data (bm2ij ( 8, 7,ibeta), ibeta = 1,10) / & - 0.878941_r8, 0.886132_r8, 0.901679_r8, 0.919688_r8, 0.936970_r8, & - 0.951980_r8, 0.964199_r8, 0.973709_r8, 0.980881_r8, 0.986174_r8/ - data (bm2ij ( 8, 8,ibeta), ibeta = 1,10) / & - 0.871653_r8, 0.878218_r8, 0.892652_r8, 0.909871_r8, 0.927034_r8, & - 0.942592_r8, 0.955836_r8, 0.966604_r8, 0.975065_r8, 0.981545_r8/ - data (bm2ij ( 8, 9,ibeta), ibeta = 1,10) / & - 0.900693_r8, 0.905239_r8, 0.915242_r8, 0.927232_r8, 0.939335_r8, & - 0.950555_r8, 0.960420_r8, 0.968774_r8, 0.975651_r8, 0.981188_r8/ - data (bm2ij ( 8, 10,ibeta), ibeta = 1,10) / & - 0.944922_r8, 0.947435_r8, 0.952894_r8, 0.959317_r8, 0.965689_r8, & - 0.971529_r8, 0.976645_r8, 0.981001_r8, 0.984641_r8, 0.987642_r8/ - data (bm2ij ( 9, 1,ibeta), ibeta = 1,10) / & - 0.984736_r8, 0.985963_r8, 0.988453_r8, 0.991078_r8, 0.993357_r8, & - 0.995161_r8, 0.996519_r8, 0.997512_r8, 0.998226_r8, 0.998734_r8/ - data (bm2ij ( 9, 2,ibeta), ibeta = 1,10) / & - 0.983141_r8, 0.984488_r8, 0.987227_r8, 0.990119_r8, 0.992636_r8, & - 0.994632_r8, 0.996137_r8, 0.997238_r8, 0.998030_r8, 0.998595_r8/ - data (bm2ij ( 9, 3,ibeta), ibeta = 1,10) / & - 0.978726_r8, 0.980401_r8, 0.983819_r8, 0.987450_r8, 0.990626_r8, & - 0.993157_r8, 0.995071_r8, 0.996475_r8, 0.997486_r8, 0.998206_r8/ - data (bm2ij ( 9, 4,ibeta), ibeta = 1,10) / & - 0.970986_r8, 0.973224_r8, 0.977818_r8, 0.982737_r8, 0.987072_r8, & - 0.990546_r8, 0.993184_r8, 0.995124_r8, 0.996523_r8, 0.997521_r8/ - data (bm2ij ( 9, 5,ibeta), ibeta = 1,10) / & - 0.958579_r8, 0.961700_r8, 0.968149_r8, 0.975116_r8, 0.981307_r8, & - 0.986301_r8, 0.990112_r8, 0.992923_r8, 0.994954_r8, 0.996404_r8/ - data (bm2ij ( 9, 6,ibeta), ibeta = 1,10) / & - 0.940111_r8, 0.944479_r8, 0.953572_r8, 0.963506_r8, 0.972436_r8, & - 0.979714_r8, 0.985313_r8, 0.989468_r8, 0.992483_r8, 0.994641_r8/ - data (bm2ij ( 9, 7,ibeta), ibeta = 1,10) / & - 0.916127_r8, 0.921878_r8, 0.934003_r8, 0.947506_r8, 0.959899_r8, & - 0.970199_r8, 0.978255_r8, 0.984314_r8, 0.988755_r8, 0.991960_r8/ - data (bm2ij ( 9, 8,ibeta), ibeta = 1,10) / & - 0.893848_r8, 0.900364_r8, 0.914368_r8, 0.930438_r8, 0.945700_r8, & - 0.958824_r8, 0.969416_r8, 0.977603_r8, 0.983746_r8, 0.988262_r8/ - data (bm2ij ( 9, 9,ibeta), ibeta = 1,10) / & - 0.892161_r8, 0.897863_r8, 0.910315_r8, 0.925021_r8, 0.939523_r8, & - 0.952544_r8, 0.963544_r8, 0.972442_r8, 0.979411_r8, 0.984742_r8/ - data (bm2ij ( 9, 10,ibeta), ibeta = 1,10) / & - 0.922260_r8, 0.925966_r8, 0.934047_r8, 0.943616_r8, 0.953152_r8, & - 0.961893_r8, 0.969506_r8, 0.975912_r8, 0.981167_r8, 0.985394_r8/ - data (bm2ij ( 10, 1,ibeta), ibeta = 1,10) / & - 0.990838_r8, 0.991598_r8, 0.993128_r8, 0.994723_r8, 0.996092_r8, & - 0.997167_r8, 0.997969_r8, 0.998552_r8, 0.998969_r8, 0.999265_r8/ - data (bm2ij ( 10, 2,ibeta), ibeta = 1,10) / & - 0.989892_r8, 0.990727_r8, 0.992411_r8, 0.994167_r8, 0.995678_r8, & - 0.996864_r8, 0.997751_r8, 0.998396_r8, 0.998858_r8, 0.999186_r8/ - data (bm2ij ( 10, 3,ibeta), ibeta = 1,10) / & - 0.987287_r8, 0.988327_r8, 0.990428_r8, 0.992629_r8, 0.994529_r8, & - 0.996026_r8, 0.997148_r8, 0.997965_r8, 0.998551_r8, 0.998967_r8/ - data (bm2ij ( 10, 4,ibeta), ibeta = 1,10) / & - 0.982740_r8, 0.984130_r8, 0.986952_r8, 0.989926_r8, 0.992508_r8, & - 0.994551_r8, 0.996087_r8, 0.997208_r8, 0.998012_r8, 0.998584_r8/ - data (bm2ij ( 10, 5,ibeta), ibeta = 1,10) / & - 0.975380_r8, 0.977330_r8, 0.981307_r8, 0.985529_r8, 0.989216_r8, & - 0.992147_r8, 0.994358_r8, 0.995975_r8, 0.997136_r8, 0.997961_r8/ - data (bm2ij ( 10, 6,ibeta), ibeta = 1,10) / & - 0.963911_r8, 0.966714_r8, 0.972465_r8, 0.978614_r8, 0.984022_r8, & - 0.988346_r8, 0.991620_r8, 0.994020_r8, 0.995747_r8, 0.996974_r8/ - data (bm2ij ( 10, 7,ibeta), ibeta = 1,10) / & - 0.947187_r8, 0.951161_r8, 0.959375_r8, 0.968258_r8, 0.976160_r8, & - 0.982540_r8, 0.987409_r8, 0.991000_r8, 0.993592_r8, 0.995441_r8/ - data (bm2ij ( 10, 8,ibeta), ibeta = 1,10) / & - 0.926045_r8, 0.931270_r8, 0.942218_r8, 0.954297_r8, 0.965273_r8, & - 0.974311_r8, 0.981326_r8, 0.986569_r8, 0.990394_r8, 0.993143_r8/ - data (bm2ij ( 10, 9,ibeta), ibeta = 1,10) / & - 0.908092_r8, 0.913891_r8, 0.926288_r8, 0.940393_r8, 0.953667_r8, & - 0.964987_r8, 0.974061_r8, 0.981038_r8, 0.986253_r8, 0.990078_r8/ - data (bm2ij ( 10, 10,ibeta), ibeta = 1,10) / & - 0.911143_r8, 0.915972_r8, 0.926455_r8, 0.938721_r8, 0.950701_r8, & - 0.961370_r8, 0.970329_r8, 0.977549_r8, 0.983197_r8, 0.987518_r8/ - - -! fsb total correction factor for m2 coagulation j from i - - data (bm2ji( 1, 1,ibeta), ibeta = 1,10) / & - 0.753466_r8, 0.756888_r8, 0.761008_r8, 0.759432_r8, 0.748675_r8, & - 0.726951_r8, 0.693964_r8, 0.650915_r8, 0.600227_r8, 0.545000_r8/ - data (bm2ji( 1, 2,ibeta), ibeta = 1,10) / & - 0.824078_r8, 0.828698_r8, 0.835988_r8, 0.838943_r8, 0.833454_r8, & - 0.817148_r8, 0.789149_r8, 0.750088_r8, 0.701887_r8, 0.647308_r8/ - data (bm2ji( 1, 3,ibeta), ibeta = 1,10) / & - 1.007389_r8, 1.014362_r8, 1.028151_r8, 1.041011_r8, 1.047939_r8, & - 1.045707_r8, 1.032524_r8, 1.007903_r8, 0.972463_r8, 0.927667_r8/ - data (bm2ji( 1, 4,ibeta), ibeta = 1,10) / & - 1.246157_r8, 1.255135_r8, 1.274249_r8, 1.295351_r8, 1.313362_r8, & - 1.325187_r8, 1.329136_r8, 1.324491_r8, 1.311164_r8, 1.289459_r8/ - data (bm2ji( 1, 5,ibeta), ibeta = 1,10) / & - 1.450823_r8, 1.459551_r8, 1.478182_r8, 1.499143_r8, 1.518224_r8, & - 1.533312_r8, 1.543577_r8, 1.548882_r8, 1.549395_r8, 1.545364_r8/ - data (bm2ji( 1, 6,ibeta), ibeta = 1,10) / & - 1.575248_r8, 1.581832_r8, 1.595643_r8, 1.610866_r8, 1.624601_r8, & - 1.635690_r8, 1.643913_r8, 1.649470_r8, 1.652688_r8, 1.653878_r8/ - data (bm2ji( 1, 7,ibeta), ibeta = 1,10) / & - 1.638426_r8, 1.642626_r8, 1.651293_r8, 1.660641_r8, 1.668926_r8, & - 1.675571_r8, 1.680572_r8, 1.684147_r8, 1.686561_r8, 1.688047_r8/ - data (bm2ji( 1, 8,ibeta), ibeta = 1,10) / & - 1.669996_r8, 1.672392_r8, 1.677283_r8, 1.682480_r8, 1.687028_r8, & - 1.690651_r8, 1.693384_r8, 1.695372_r8, 1.696776_r8, 1.697734_r8/ - data (bm2ji( 1, 9,ibeta), ibeta = 1,10) / & - 1.686148_r8, 1.687419_r8, 1.689993_r8, 1.692704_r8, 1.695057_r8, & - 1.696922_r8, 1.698329_r8, 1.699359_r8, 1.700099_r8, 1.700621_r8/ - data (bm2ji( 1,10,ibeta), ibeta = 1,10) / & - 1.694364_r8, 1.695010_r8, 1.696313_r8, 1.697676_r8, 1.698853_r8, & - 1.699782_r8, 1.700482_r8, 1.700996_r8, 1.701366_r8, 1.701631_r8/ - data (bm2ji( 2, 1,ibeta), ibeta = 1,10) / & - 0.783166_r8, 0.779369_r8, 0.768044_r8, 0.747572_r8, 0.716709_r8, & - 0.675422_r8, 0.624981_r8, 0.567811_r8, 0.507057_r8, 0.445975_r8/ - data (bm2ji( 2, 2,ibeta), ibeta = 1,10) / & - 0.848390_r8, 0.847100_r8, 0.840874_r8, 0.826065_r8, 0.800296_r8, & - 0.762625_r8, 0.713655_r8, 0.655545_r8, 0.591603_r8, 0.525571_r8/ - data (bm2ji( 2, 3,ibeta), ibeta = 1,10) / & - 1.039894_r8, 1.043786_r8, 1.049445_r8, 1.049664_r8, 1.039407_r8, & - 1.015322_r8, 0.975983_r8, 0.922180_r8, 0.856713_r8, 0.783634_r8/ - data (bm2ji( 2, 4,ibeta), ibeta = 1,10) / & - 1.345995_r8, 1.356064_r8, 1.376947_r8, 1.398304_r8, 1.412685_r8, & - 1.414611_r8, 1.400652_r8, 1.369595_r8, 1.322261_r8, 1.260993_r8/ - data (bm2ji( 2, 5,ibeta), ibeta = 1,10) / & - 1.675575_r8, 1.689859_r8, 1.720957_r8, 1.756659_r8, 1.788976_r8, & - 1.812679_r8, 1.824773_r8, 1.824024_r8, 1.810412_r8, 1.784630_r8/ - data (bm2ji( 2, 6,ibeta), ibeta = 1,10) / & - 1.919835_r8, 1.933483_r8, 1.962973_r8, 1.996810_r8, 2.028377_r8, & - 2.054172_r8, 2.072763_r8, 2.083963_r8, 2.088190_r8, 2.086052_r8/ - data (bm2ji( 2, 7,ibeta), ibeta = 1,10) / & - 2.064139_r8, 2.074105_r8, 2.095233_r8, 2.118909_r8, 2.140688_r8, & - 2.158661_r8, 2.172373_r8, 2.182087_r8, 2.188330_r8, 2.191650_r8/ - data (bm2ji( 2, 8,ibeta), ibeta = 1,10) / & - 2.144871_r8, 2.150990_r8, 2.163748_r8, 2.177731_r8, 2.190364_r8, & - 2.200712_r8, 2.208687_r8, 2.214563_r8, 2.218716_r8, 2.221502_r8/ - data (bm2ji( 2, 9,ibeta), ibeta = 1,10) / & - 2.189223_r8, 2.192595_r8, 2.199540_r8, 2.207033_r8, 2.213706_r8, & - 2.219125_r8, 2.223297_r8, 2.226403_r8, 2.228660_r8, 2.230265_r8/ - data (bm2ji( 2,10,ibeta), ibeta = 1,10) / & - 2.212595_r8, 2.214342_r8, 2.217912_r8, 2.221723_r8, 2.225082_r8, & - 2.227791_r8, 2.229869_r8, 2.231417_r8, 2.232551_r8, 2.233372_r8/ - data (bm2ji( 3, 1,ibeta), ibeta = 1,10) / & - 0.837870_r8, 0.824476_r8, 0.793119_r8, 0.750739_r8, 0.700950_r8, & - 0.646691_r8, 0.590508_r8, 0.534354_r8, 0.479532_r8, 0.426856_r8/ - data (bm2ji( 3, 2,ibeta), ibeta = 1,10) / & - 0.896771_r8, 0.885847_r8, 0.859327_r8, 0.821694_r8, 0.775312_r8, & - 0.722402_r8, 0.665196_r8, 0.605731_r8, 0.545742_r8, 0.486687_r8/ - data (bm2ji( 3, 3,ibeta), ibeta = 1,10) / & - 1.076089_r8, 1.071727_r8, 1.058845_r8, 1.036171_r8, 1.002539_r8, & - 0.957521_r8, 0.901640_r8, 0.836481_r8, 0.764597_r8, 0.689151_r8/ - data (bm2ji( 3, 4,ibeta), ibeta = 1,10) / & - 1.409571_r8, 1.415168_r8, 1.425346_r8, 1.432021_r8, 1.428632_r8, & - 1.409696_r8, 1.371485_r8, 1.312958_r8, 1.236092_r8, 1.145293_r8/ - data (bm2ji( 3, 5,ibeta), ibeta = 1,10) / & - 1.862757_r8, 1.880031_r8, 1.918394_r8, 1.963456_r8, 2.004070_r8, & - 2.030730_r8, 2.036144_r8, 2.016159_r8, 1.970059_r8, 1.900079_r8/ - data (bm2ji( 3, 6,ibeta), ibeta = 1,10) / & - 2.289741_r8, 2.313465_r8, 2.366789_r8, 2.431612_r8, 2.495597_r8, & - 2.549838_r8, 2.588523_r8, 2.608665_r8, 2.609488_r8, 2.591662_r8/ - data (bm2ji( 3, 7,ibeta), ibeta = 1,10) / & - 2.597157_r8, 2.618731_r8, 2.666255_r8, 2.722597_r8, 2.777531_r8, & - 2.825187_r8, 2.862794_r8, 2.889648_r8, 2.906199_r8, 2.913380_r8/ - data (bm2ji( 3, 8,ibeta), ibeta = 1,10) / & - 2.797975_r8, 2.813116_r8, 2.845666_r8, 2.882976_r8, 2.918289_r8, & - 2.948461_r8, 2.972524_r8, 2.990687_r8, 3.003664_r8, 3.012284_r8/ - data (bm2ji( 3, 9,ibeta), ibeta = 1,10) / & - 2.920832_r8, 2.929843_r8, 2.948848_r8, 2.970057_r8, 2.989632_r8, & - 3.006057_r8, 3.019067_r8, 3.028979_r8, 3.036307_r8, 3.041574_r8/ - data (bm2ji( 3,10,ibeta), ibeta = 1,10) / & - 2.989627_r8, 2.994491_r8, 3.004620_r8, 3.015720_r8, 3.025789_r8, & - 3.034121_r8, 3.040664_r8, 3.045641_r8, 3.049347_r8, 3.052066_r8/ - data (bm2ji( 4, 1,ibeta), ibeta = 1,10) / & - 0.893179_r8, 0.870897_r8, 0.820996_r8, 0.759486_r8, 0.695488_r8, & - 0.634582_r8, 0.579818_r8, 0.532143_r8, 0.490927_r8, 0.454618_r8/ - data (bm2ji( 4, 2,ibeta), ibeta = 1,10) / & - 0.948355_r8, 0.927427_r8, 0.880215_r8, 0.821146_r8, 0.758524_r8, & - 0.697680_r8, 0.641689_r8, 0.591605_r8, 0.546919_r8, 0.506208_r8/ - data (bm2ji( 4, 3,ibeta), ibeta = 1,10) / & - 1.109562_r8, 1.093648_r8, 1.056438_r8, 1.007310_r8, 0.951960_r8, & - 0.894453_r8, 0.837364_r8, 0.781742_r8, 0.727415_r8, 0.673614_r8/ - data (bm2ji( 4, 4,ibeta), ibeta = 1,10) / & - 1.423321_r8, 1.417557_r8, 1.402442_r8, 1.379079_r8, 1.347687_r8, & - 1.308075_r8, 1.259703_r8, 1.201983_r8, 1.134778_r8, 1.058878_r8/ - data (bm2ji( 4, 5,ibeta), ibeta = 1,10) / & - 1.933434_r8, 1.944347_r8, 1.968765_r8, 1.997653_r8, 2.023054_r8, & - 2.036554_r8, 2.029949_r8, 1.996982_r8, 1.934982_r8, 1.845473_r8/ - data (bm2ji( 4, 6,ibeta), ibeta = 1,10) / & - 2.547772_r8, 2.577105_r8, 2.645918_r8, 2.735407_r8, 2.830691_r8, & - 2.917268_r8, 2.981724_r8, 3.013684_r8, 3.007302_r8, 2.961560_r8/ - data (bm2ji( 4, 7,ibeta), ibeta = 1,10) / & - 3.101817_r8, 3.139271_r8, 3.225851_r8, 3.336402_r8, 3.453409_r8, & - 3.563116_r8, 3.655406_r8, 3.724014_r8, 3.766113_r8, 3.781394_r8/ - data (bm2ji( 4, 8,ibeta), ibeta = 1,10) / & - 3.540920_r8, 3.573780_r8, 3.647439_r8, 3.737365_r8, 3.828468_r8, & - 3.911436_r8, 3.981317_r8, 4.036345_r8, 4.076749_r8, 4.103751_r8/ - data (bm2ji( 4, 9,ibeta), ibeta = 1,10) / & - 3.856771_r8, 3.879363_r8, 3.928579_r8, 3.986207_r8, 4.042173_r8, & - 4.091411_r8, 4.132041_r8, 4.164052_r8, 4.188343_r8, 4.206118_r8/ - data (bm2ji( 4,10,ibeta), ibeta = 1,10) / & - 4.053923_r8, 4.067191_r8, 4.095509_r8, 4.127698_r8, 4.158037_r8, & - 4.184055_r8, 4.205135_r8, 4.221592_r8, 4.234115_r8, 4.243463_r8/ - data (bm2ji( 5, 1,ibeta), ibeta = 1,10) / & - 0.935846_r8, 0.906814_r8, 0.843358_r8, 0.768710_r8, 0.695885_r8, & - 0.631742_r8, 0.579166_r8, 0.538471_r8, 0.508410_r8, 0.486863_r8/ - data (bm2ji( 5, 2,ibeta), ibeta = 1,10) / & - 0.988308_r8, 0.959524_r8, 0.896482_r8, 0.821986_r8, 0.748887_r8, & - 0.684168_r8, 0.630908_r8, 0.589516_r8, 0.558676_r8, 0.536056_r8/ - data (bm2ji( 5, 3,ibeta), ibeta = 1,10) / & - 1.133795_r8, 1.107139_r8, 1.048168_r8, 0.977258_r8, 0.906341_r8, & - 0.842477_r8, 0.789093_r8, 0.746731_r8, 0.713822_r8, 0.687495_r8/ - data (bm2ji( 5, 4,ibeta), ibeta = 1,10) / & - 1.405692_r8, 1.385781_r8, 1.340706_r8, 1.284776_r8, 1.227085_r8, & - 1.173532_r8, 1.127008_r8, 1.087509_r8, 1.052712_r8, 1.018960_r8/ - data (bm2ji( 5, 5,ibeta), ibeta = 1,10) / & - 1.884992_r8, 1.879859_r8, 1.868463_r8, 1.854995_r8, 1.841946_r8, & - 1.829867_r8, 1.816972_r8, 1.799319_r8, 1.771754_r8, 1.729406_r8/ - data (bm2ji( 5, 6,ibeta), ibeta = 1,10) / & - 2.592275_r8, 2.612268_r8, 2.661698_r8, 2.731803_r8, 2.815139_r8, & - 2.901659_r8, 2.978389_r8, 3.031259_r8, 3.048045_r8, 3.021122_r8/ - data (bm2ji( 5, 7,ibeta), ibeta = 1,10) / & - 3.390321_r8, 3.435519_r8, 3.545615_r8, 3.698419_r8, 3.876958_r8, & - 4.062790_r8, 4.236125_r8, 4.378488_r8, 4.475619_r8, 4.519170_r8/ - data (bm2ji( 5, 8,ibeta), ibeta = 1,10) / & - 4.161376_r8, 4.216558_r8, 4.346896_r8, 4.519451_r8, 4.711107_r8, & - 4.902416_r8, 5.077701_r8, 5.226048_r8, 5.341423_r8, 5.421764_r8/ - data (bm2ji( 5, 9,ibeta), ibeta = 1,10) / & - 4.843961_r8, 4.892035_r8, 5.001492_r8, 5.138515_r8, 5.281684_r8, & - 5.416805_r8, 5.535493_r8, 5.634050_r8, 5.712063_r8, 5.770996_r8/ - data (bm2ji( 5,10,ibeta), ibeta = 1,10) / & - 5.352093_r8, 5.385119_r8, 5.458056_r8, 5.545311_r8, 5.632162_r8, & - 5.710566_r8, 5.777005_r8, 5.830863_r8, 5.873123_r8, 5.905442_r8/ - data (bm2ji( 6, 1,ibeta), ibeta = 1,10) / & - 0.964038_r8, 0.930794_r8, 0.859433_r8, 0.777776_r8, 0.700566_r8, & - 0.634671_r8, 0.582396_r8, 0.543656_r8, 0.517284_r8, 0.501694_r8/ - data (bm2ji( 6, 2,ibeta), ibeta = 1,10) / & - 1.013416_r8, 0.979685_r8, 0.907197_r8, 0.824135_r8, 0.745552_r8, & - 0.678616_r8, 0.625870_r8, 0.587348_r8, 0.561864_r8, 0.547674_r8/ - data (bm2ji( 6, 3,ibeta), ibeta = 1,10) / & - 1.145452_r8, 1.111457_r8, 1.038152_r8, 0.953750_r8, 0.873724_r8, & - 0.805955_r8, 0.753621_r8, 0.717052_r8, 0.694920_r8, 0.684910_r8/ - data (bm2ji( 6, 4,ibeta), ibeta = 1,10) / & - 1.376547_r8, 1.345004_r8, 1.276415_r8, 1.196704_r8, 1.121091_r8, & - 1.058249_r8, 1.012197_r8, 0.983522_r8, 0.970323_r8, 0.968933_r8/ - data (bm2ji( 6, 5,ibeta), ibeta = 1,10) / & - 1.778801_r8, 1.755897_r8, 1.706074_r8, 1.649008_r8, 1.597602_r8, & - 1.560087_r8, 1.540365_r8, 1.538205_r8, 1.549738_r8, 1.568333_r8/ - data (bm2ji( 6, 6,ibeta), ibeta = 1,10) / & - 2.447603_r8, 2.445172_r8, 2.443762_r8, 2.451842_r8, 2.475877_r8, & - 2.519039_r8, 2.580118_r8, 2.653004_r8, 2.727234_r8, 2.789738_r8/ - data (bm2ji( 6, 7,ibeta), ibeta = 1,10) / & - 3.368490_r8, 3.399821_r8, 3.481357_r8, 3.606716_r8, 3.772101_r8, & - 3.969416_r8, 4.184167_r8, 4.396163_r8, 4.582502_r8, 4.721838_r8/ - data (bm2ji( 6, 8,ibeta), ibeta = 1,10) / & - 4.426458_r8, 4.489861_r8, 4.648250_r8, 4.877510_r8, 5.160698_r8, & - 5.477495_r8, 5.803123_r8, 6.111250_r8, 6.378153_r8, 6.586050_r8/ - data (bm2ji( 6, 9,ibeta), ibeta = 1,10) / & - 5.568061_r8, 5.644988_r8, 5.829837_r8, 6.081532_r8, 6.371214_r8, & - 6.672902_r8, 6.963737_r8, 7.226172_r8, 7.449199_r8, 7.627886_r8/ - data (bm2ji( 6,10,ibeta), ibeta = 1,10) / & - 6.639152_r8, 6.707020_r8, 6.863974_r8, 7.065285_r8, 7.281744_r8, & - 7.492437_r8, 7.683587_r8, 7.847917_r8, 7.983296_r8, 8.090977_r8/ - data (bm2ji( 7, 1,ibeta), ibeta = 1,10) / & - 0.980853_r8, 0.945724_r8, 0.871244_r8, 0.787311_r8, 0.708818_r8, & - 0.641987_r8, 0.588462_r8, 0.547823_r8, 0.518976_r8, 0.500801_r8/ - data (bm2ji( 7, 2,ibeta), ibeta = 1,10) / & - 1.026738_r8, 0.990726_r8, 0.914306_r8, 0.828140_r8, 0.747637_r8, & - 0.679351_r8, 0.625127_r8, 0.584662_r8, 0.556910_r8, 0.540749_r8/ - data (bm2ji( 7, 3,ibeta), ibeta = 1,10) / & - 1.146496_r8, 1.108808_r8, 1.028695_r8, 0.938291_r8, 0.854101_r8, & - 0.783521_r8, 0.728985_r8, 0.690539_r8, 0.667272_r8, 0.657977_r8/ - data (bm2ji( 7, 4,ibeta), ibeta = 1,10) / & - 1.344846_r8, 1.306434_r8, 1.224543_r8, 1.132031_r8, 1.046571_r8, & - 0.976882_r8, 0.926488_r8, 0.896067_r8, 0.884808_r8, 0.891027_r8/ - data (bm2ji( 7, 5,ibeta), ibeta = 1,10) / & - 1.670227_r8, 1.634583_r8, 1.558421_r8, 1.472939_r8, 1.396496_r8, & - 1.339523_r8, 1.307151_r8, 1.300882_r8, 1.319622_r8, 1.360166_r8/ - data (bm2ji( 7, 6,ibeta), ibeta = 1,10) / & - 2.224548_r8, 2.199698_r8, 2.148284_r8, 2.095736_r8, 2.059319_r8, & - 2.050496_r8, 2.075654_r8, 2.136382_r8, 2.229641_r8, 2.347958_r8/ - data (bm2ji( 7, 7,ibeta), ibeta = 1,10) / & - 3.104483_r8, 3.105947_r8, 3.118398_r8, 3.155809_r8, 3.230427_r8, & - 3.350585_r8, 3.519071_r8, 3.731744_r8, 3.976847_r8, 4.235616_r8/ - data (bm2ji( 7, 8,ibeta), ibeta = 1,10) / & - 4.288426_r8, 4.331456_r8, 4.447024_r8, 4.633023_r8, 4.891991_r8, & - 5.221458_r8, 5.610060_r8, 6.036467_r8, 6.471113_r8, 6.880462_r8/ - data (bm2ji( 7, 9,ibeta), ibeta = 1,10) / & - 5.753934_r8, 5.837061_r8, 6.048530_r8, 6.363800_r8, 6.768061_r8, & - 7.241280_r8, 7.755346_r8, 8.276666_r8, 8.771411_r8, 9.210826_r8/ - data (bm2ji( 7,10,ibeta), ibeta = 1,10) / & - 7.466219_r8, 7.568810_r8, 7.819032_r8, 8.168340_r8, 8.582973_r8, & - 9.030174_r8, 9.478159_r8, 9.899834_r8, 10.275940_r8, 10.595910_r8/ - data (bm2ji( 8, 1,ibeta), ibeta = 1,10) / & - 0.990036_r8, 0.954782_r8, 0.880531_r8, 0.797334_r8, 0.719410_r8, & - 0.652220_r8, 0.596923_r8, 0.552910_r8, 0.519101_r8, 0.494529_r8/ - data (bm2ji( 8, 2,ibeta), ibeta = 1,10) / & - 1.032428_r8, 0.996125_r8, 0.919613_r8, 0.833853_r8, 0.753611_r8, & - 0.684644_r8, 0.628260_r8, 0.583924_r8, 0.550611_r8, 0.527407_r8/ - data (bm2ji( 8, 3,ibeta), ibeta = 1,10) / & - 1.141145_r8, 1.102521_r8, 1.021017_r8, 0.929667_r8, 0.844515_r8, & - 0.772075_r8, 0.714086_r8, 0.670280_r8, 0.639824_r8, 0.621970_r8/ - data (bm2ji( 8, 4,ibeta), ibeta = 1,10) / & - 1.314164_r8, 1.273087_r8, 1.186318_r8, 1.089208_r8, 0.999476_r8, & - 0.924856_r8, 0.867948_r8, 0.829085_r8, 0.807854_r8, 0.803759_r8/ - data (bm2ji( 8, 5,ibeta), ibeta = 1,10) / & - 1.580611_r8, 1.538518_r8, 1.449529_r8, 1.350459_r8, 1.260910_r8, & - 1.190526_r8, 1.143502_r8, 1.121328_r8, 1.124274_r8, 1.151974_r8/ - data (bm2ji( 8, 6,ibeta), ibeta = 1,10) / & - 2.016773_r8, 1.977721_r8, 1.895727_r8, 1.806974_r8, 1.732891_r8, & - 1.685937_r8, 1.673026_r8, 1.697656_r8, 1.761039_r8, 1.862391_r8/ - data (bm2ji( 8, 7,ibeta), ibeta = 1,10) / & - 2.750093_r8, 2.723940_r8, 2.672854_r8, 2.628264_r8, 2.612250_r8, & - 2.640406_r8, 2.723211_r8, 2.866599_r8, 3.071893_r8, 3.335217_r8/ - data (bm2ji( 8, 8,ibeta), ibeta = 1,10) / & - 3.881905_r8, 3.887143_r8, 3.913667_r8, 3.981912_r8, 4.111099_r8, & - 4.316575_r8, 4.608146_r8, 4.988157_r8, 5.449592_r8, 5.974848_r8/ - data (bm2ji( 8, 9,ibeta), ibeta = 1,10) / & - 5.438870_r8, 5.492742_r8, 5.640910_r8, 5.886999_r8, 6.241641_r8, & - 6.710609_r8, 7.289480_r8, 7.960725_r8, 8.693495_r8, 9.446644_r8/ - data (bm2ji( 8,10,ibeta), ibeta = 1,10) / & - 7.521152_r8, 7.624621_r8, 7.892039_r8, 8.300444_r8, 8.839787_r8, & - 9.493227_r8, 10.231770_r8, 11.015642_r8, 11.799990_r8, 12.542260_r8/ - data (bm2ji( 9, 1,ibeta), ibeta = 1,10) / & - 0.994285_r8, 0.960012_r8, 0.887939_r8, 0.807040_r8, 0.730578_r8, & - 0.663410_r8, 0.606466_r8, 0.559137_r8, 0.520426_r8, 0.489429_r8/ - data (bm2ji( 9, 2,ibeta), ibeta = 1,10) / & - 1.033505_r8, 0.998153_r8, 0.923772_r8, 0.840261_r8, 0.761383_r8, & - 0.692242_r8, 0.633873_r8, 0.585709_r8, 0.546777_r8, 0.516215_r8/ - data (bm2ji( 9, 3,ibeta), ibeta = 1,10) / & - 1.132774_r8, 1.094907_r8, 1.015161_r8, 0.925627_r8, 0.841293_r8, & - 0.767888_r8, 0.706741_r8, 0.657439_r8, 0.619135_r8, 0.591119_r8/ - data (bm2ji( 9, 4,ibeta), ibeta = 1,10) / & - 1.286308_r8, 1.245273_r8, 1.158809_r8, 1.061889_r8, 0.971208_r8, & - 0.893476_r8, 0.830599_r8, 0.782561_r8, 0.748870_r8, 0.729198_r8/ - data (bm2ji( 9, 5,ibeta), ibeta = 1,10) / & - 1.511105_r8, 1.467141_r8, 1.374520_r8, 1.271162_r8, 1.175871_r8, & - 1.096887_r8, 1.037243_r8, 0.997820_r8, 0.978924_r8, 0.980962_r8/ - data (bm2ji( 9, 6,ibeta), ibeta = 1,10) / & - 1.857468_r8, 1.812177_r8, 1.717002_r8, 1.612197_r8, 1.519171_r8, & - 1.448660_r8, 1.405871_r8, 1.393541_r8, 1.413549_r8, 1.467532_r8/ - data (bm2ji( 9, 7,ibeta), ibeta = 1,10) / & - 2.430619_r8, 2.388452_r8, 2.301326_r8, 2.210241_r8, 2.139724_r8, & - 2.104571_r8, 2.114085_r8, 2.174696_r8, 2.291294_r8, 2.467500_r8/ - data (bm2ji( 9, 8,ibeta), ibeta = 1,10) / & - 3.385332_r8, 3.357690_r8, 3.306611_r8, 3.269804_r8, 3.274462_r8, & - 3.340862_r8, 3.484609_r8, 3.717740_r8, 4.048748_r8, 4.481588_r8/ - data (bm2ji( 9, 9,ibeta), ibeta = 1,10) / & - 4.850497_r8, 4.858280_r8, 4.896008_r8, 4.991467_r8, 5.171511_r8, & - 5.459421_r8, 5.873700_r8, 6.426128_r8, 7.119061_r8, 7.942603_r8/ - data (bm2ji( 9,10,ibeta), ibeta = 1,10) / & - 6.957098_r8, 7.020164_r8, 7.197272_r8, 7.499331_r8, 7.946554_r8, & - 8.555048_r8, 9.330503_r8, 10.263610_r8, 11.327454_r8, 12.478332_r8/ - data (bm2ji(10, 1,ibeta), ibeta = 1,10) / & - 0.994567_r8, 0.961842_r8, 0.892854_r8, 0.814874_r8, 0.740198_r8, & - 0.673303_r8, 0.615105_r8, 0.565139_r8, 0.522558_r8, 0.486556_r8/ - data (bm2ji(10, 2,ibeta), ibeta = 1,10) / & - 1.031058_r8, 0.997292_r8, 0.926082_r8, 0.845571_r8, 0.768501_r8, & - 0.699549_r8, 0.639710_r8, 0.588538_r8, 0.545197_r8, 0.508894_r8/ - data (bm2ji(10, 3,ibeta), ibeta = 1,10) / & - 1.122535_r8, 1.086287_r8, 1.009790_r8, 0.923292_r8, 0.840626_r8, & - 0.766982_r8, 0.703562_r8, 0.650004_r8, 0.605525_r8, 0.569411_r8/ - data (bm2ji(10, 4,ibeta), ibeta = 1,10) / & - 1.261142_r8, 1.221555_r8, 1.137979_r8, 1.043576_r8, 0.953745_r8, & - 0.874456_r8, 0.807292_r8, 0.752109_r8, 0.708326_r8, 0.675477_r8/ - data (bm2ji(10, 5,ibeta), ibeta = 1,10) / & - 1.456711_r8, 1.413432_r8, 1.322096_r8, 1.219264_r8, 1.122319_r8, & - 1.038381_r8, 0.969743_r8, 0.916811_r8, 0.879544_r8, 0.858099_r8/ - data (bm2ji(10, 6,ibeta), ibeta = 1,10) / & - 1.741792_r8, 1.695157_r8, 1.596897_r8, 1.487124_r8, 1.385734_r8, & - 1.301670_r8, 1.238638_r8, 1.198284_r8, 1.181809_r8, 1.190689_r8/ - data (bm2ji(10, 7,ibeta), ibeta = 1,10) / & - 2.190197_r8, 2.141721_r8, 2.040226_r8, 1.929245_r8, 1.832051_r8, & - 1.760702_r8, 1.721723_r8, 1.719436_r8, 1.757705_r8, 1.840677_r8/ - data (bm2ji(10, 8,ibeta), ibeta = 1,10) / & - 2.940764_r8, 2.895085_r8, 2.801873_r8, 2.707112_r8, 2.638603_r8, & - 2.613764_r8, 2.644686_r8, 2.741255_r8, 2.912790_r8, 3.168519_r8/ - data (bm2ji(10, 9,ibeta), ibeta = 1,10) / & - 4.186191_r8, 4.155844_r8, 4.101953_r8, 4.069102_r8, 4.089886_r8, & - 4.189530_r8, 4.389145_r8, 4.707528_r8, 5.161567_r8, 5.765283_r8/ - data (bm2ji(10,10,ibeta), ibeta = 1,10) / & - 6.119526_r8, 6.127611_r8, 6.171174_r8, 6.286528_r8, 6.508738_r8, & - 6.869521_r8, 7.396912_r8, 8.113749_r8, 9.034683_r8, 10.162190_r8/ - -! *** end of data statements. - - -! *** start calculations: - - constii = abs( half * ( two ) ** two3rds - one ) - sqrttwo = sqrt(two) - dlgsqt2 = one / log( sqrttwo ) - - esat01 = exp( 0.125_r8 * xxlsgat * xxlsgat ) - esac01 = exp( 0.125_r8 * xxlsgac * xxlsgac ) - - esat04 = esat01 ** 4 - esac04 = esac01 ** 4 - - esat05 = esat04 * esat01 - esac05 = esac04 * esac01 - - esat08 = esat04 * esat04 - esac08 = esac04 * esac04 - - esat09 = esat08 * esat01 - esac09 = esac08 * esac01 - - esat16 = esat08 * esat08 - esac16 = esac08 * esac08 - - esat20 = esat16 * esat04 - esac20 = esac16 * esac04 - - esat24 = esat20 * esat04 - esac24 = esac20 * esac04 - - esat25 = esat20 * esat05 - esac25 = esac20 * esac05 - - esat36 = esat20 * esat16 - esac36 = esac20 * esac16 - - esat49 = esat24 * esat25 - - esat64 = esat20 * esat20 * esat24 - esac64 = esac20 * esac20 * esac24 - - esat100 = esat64 * esat36 - - dgat2 = dgatk * dgatk - dgat3 = dgatk * dgatk * dgatk - dgac2 = dgacc * dgacc - dgac3 = dgacc * dgacc * dgacc - - sqdgat = sqrt( dgatk ) - sqdgac = sqrt( dgacc ) - sqdgat5 = dgat2 * sqdgat - sqdgac5 = dgac2 * sqdgac - sqdgat7 = dgat3 * sqdgat - - xm2at = dgat2 * esat16 - xm3at = dgat3 * esat36 - - xm2ac = dgac2 * esac16 - xm3ac = dgac3 * esac36 - -! *** for the free molecular regime: page h.3 of whitby et al. (1991) - - r = sqdgac / sqdgat - r2 = r * r - r3 = r2 * r - rx4 = r2 * r2 - r5 = r3 * r2 - r6 = r3 * r3 - rx8 = rx4 * rx4 - ri1 = one / r - ri2 = one / r2 - ri3 = one / r3 - ri4 = ri2 * ri2 - kngat = two * lamda / dgatk - kngac = two * lamda / dgacc - - -! *** calculate ratio of geometric mean diameters - rat = dgacc / dgatk -! *** trap subscripts for bm0 and bm0i, between 1 and 10 -! see page h.5 of whitby et al. (1991) - - n2n = max( 1, min( 10, & - nint( 4.0_r8 * ( sgatk - 0.75_r8 ) ) ) ) - - n2a = max( 1, min( 10, & - nint( 4.0_r8 * ( sgacc - 0.75_r8 ) ) ) ) - - n1 = max( 1, min( 10, & - 1 + nint( dlgsqt2 * log( rat ) ) ) ) - -! *** intermodal coagulation - - -! *** set up for zeroeth moment - -! *** near-continuum form: equation h.10a of whitby et al. (1991) - - coagnc0 = knc * ( & - two + a * ( kngat * ( esat04 + r2 * esat16 * esac04 ) & - + kngac * ( esac04 + ri2 * esac16 * esat04 ) ) & - + ( r2 + ri2 ) * esat04 * esac04 ) - - -! *** free-molecular form: equation h.7a of whitby et al. (1991) - - coagfm0 = kfmatac * sqdgat * bm0ij(n1,n2n,n2a) * ( & - esat01 + r * esac01 + two * r2 * esat01 * esac04 & - + rx4 * esat09 * esac16 + ri3 * esat16 * esac09 & - + two * ri1 * esat04 + esac01 ) - - -! *** loss to accumulation mode - -! *** harmonic mean - - coagatac0 = coagnc0 * coagfm0 / ( coagnc0 + coagfm0 ) - - qn12 = coagatac0 - - -! *** set up for second moment -! the second moment equations are new and begin with equations a1 -! through a4 of binkowski and shankar (1995). after some algebraic -! rearrangement and application of the extended mean value theorem -! of integral calculus, equations are obtained that can be solved -! analytically with correction factors as has been done by -! whitby et al. (1991) - -! *** the term ( dp1 + dp2 ) ** (2/3) in equations a3 and a4 of -! binkowski and shankar (1995) is approximated by -! (dgat ** 3 + dgac **3 ) ** 2/3 - -! *** near-continuum form - - i1nc = knc * dgat2 * ( & - two * esat16 & - + r2 * esat04 * esac04 & - + ri2 * esat36 * esac04 & - + a * kngat * ( & - esat04 & - + ri2 * esat16 * esac04 & - + ri4 * esat36 * esac16 & - + r2 * esac04 ) ) - - - - -! *** free-molecular form - - i1fm = kfmatac * sqdgat5 * bm2ij(n1,n2n,n2a) * ( & - esat25 & - + two * r2 * esat09 * esac04 & - + rx4 * esat01 * esac16 & - + ri3 * esat64 * esac09 & - + two * ri1 * esat36 * esac01 & - + r * esat16 * esac01 ) - - - -! *** loss to accumulation mode - -! *** harmonic mean - - i1 = ( i1fm * i1nc ) / ( i1fm + i1nc ) - - coagatac2 = i1 - - qs12 = coagatac2 - - -! *** gain by accumulation mode - - coagacat2 = ( ( one + r6 ) ** two3rds - rx4 ) * i1 - - qs21 = coagacat2 * bm2ji(n1,n2n,n2a) - -! *** set up for third moment - -! *** near-continuum form: equation h.10b of whitby et al. (1991) - - coagnc3 = knc * dgat3 * ( & - two * esat36 & - + a * kngat * ( esat16 + r2 * esat04 * esac04 ) & - + a * kngac * ( esat36 * esac04 + ri2 * esat64 * esac16 ) & - + r2 * esat16 * esac04 + ri2 * esat64 * esac04 ) - - -! *** free_molecular form: equation h.7b of whitby et al. (1991) - - coagfm3 = kfmatac * sqdgat7 * bm3i( n1, n2n, n2a ) * ( & - esat49 & - + r * esat36 * esac01 & - + two * r2 * esat25 * esac04 & - + rx4 * esat09 * esac16 & - + ri3 * esat100 * esac09 & - + two * ri1 * esat64 * esac01 ) - -! *** gain by accumulation mode = loss from aitken mode - -! *** harmonic mean - - coagatac3 = coagnc3 * coagfm3 / ( coagnc3 + coagfm3 ) - - qv12 = coagatac3 - -! *** intramodal coagulation - -! *** zeroeth moment - -! *** aitken mode - -! *** near-continuum form: equation h.12a of whitby et al. (1991) - - coagnc_at = knc * (one + esat08 + a * kngat * (esat20 + esat04)) - -! *** free-molecular form: equation h.11a of whitby et al. (1991) - - coagfm_at = kfmat * sqdgat * bm0(n2n) * & - ( esat01 + esat25 + two * esat05 ) - - -! *** harmonic mean - - coagatat0 = coagfm_at * coagnc_at / ( coagfm_at + coagnc_at ) - - qn11 = coagatat0 - - -! *** accumulation mode - -! *** near-continuum form: equation h.12a of whitby et al. (1991) - - coagnc_ac = knc * (one + esac08 + a * kngac * (esac20 + esac04)) - -! *** free-molecular form: equation h.11a of whitby et al. (1991) - - coagfm_ac = kfmac * sqdgac * bm0(n2a) * & - ( esac01 + esac25 + two * esac05 ) - -! *** harmonic mean - - coagacac0 = coagfm_ac * coagnc_ac / ( coagfm_ac + coagnc_ac ) - - qn22 = coagacac0 - - -! *** set up for second moment -! the second moment equations are new and begin with 3.11a on page -! 45 of whitby et al. (1991). after some algebraic rearrangement and -! application of the extended mean value theorem of integral calculus -! equations are obtained that can be solved analytically with -! correction factors as has been done by whitby et al. (1991) - -! *** aitken mode - -! *** near-continuum - - i1nc_at = knc * dgat2 * ( & - two * esat16 & - + esat04 * esat04 & - + esat36 * esat04 & - + a * kngat * ( & - two * esat04 & - + esat16 * esat04 & - + esat36 * esat16 ) ) - -! *** free- molecular form - - i1fm_at = kfmat * sqdgat5 * bm2ii(n2n) * ( & - esat25 & - + two * esat09 * esat04 & - + esat01 * esat16 & - + esat64 * esat09 & - + two * esat36 * esat01 & - + esat16 * esat01 ) - - i1_at = ( i1nc_at * i1fm_at ) / ( i1nc_at + i1fm_at ) - - coagatat2 = constii * i1_at - - qs11 = coagatat2 * bm2iitt(n2n) - -! *** accumulation mode - -! *** near-continuum - - i1nc_ac = knc * dgac2 * ( & - two * esac16 & - + esac04 * esac04 & - + esac36 * esac04 & - + a * kngac * ( & - two * esac04 & - + esac16 * esac04 & - + esac36 * esac16 ) ) - -! *** free- molecular form - - i1fm_ac = kfmac * sqdgac5 * bm2ii(n2a) * ( & - esac25 & - + two * esac09 * esac04 & - + esac01 * esac16 & - + esac64 * esac09 & - + two * esac36 * esac01 & - + esac16 * esac01 ) - - i1_ac = ( i1nc_ac * i1fm_ac ) / ( i1nc_ac + i1fm_ac ) - - coagacac2 = constii * i1_ac - - qs22 = coagacac2 * bm2iitt(n2a) - - - return - - end subroutine getcoags - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- - - end module modal_aero_coag - - - diff --git a/src/chemistry/modal_aero/modal_aero_gasaerexch.F90 b/src/chemistry/modal_aero/modal_aero_gasaerexch.F90 deleted file mode 100644 index dcc1b19c5b..0000000000 --- a/src/chemistry/modal_aero/modal_aero_gasaerexch.F90 +++ /dev/null @@ -1,1440 +0,0 @@ -! Portable code for modal aerosol gas-aerosol exchange. -! RCE 07.04.13: Adapted from MIRAGE2 code -module modal_aero_gasaerexch - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - save - - public :: modal_aero_gasaerexch_init - public :: modal_aero_gasaerexch_run - - ! Primary-carbon aging (pcage) configuration: species are transferred from - ! the primary-carbon mode (modefrm) to the accumulation mode (modetoo) when - ! enough sulfate monolayers coat the particle. - integer, protected, public :: maxspec_pcage ! max number of species that can be aged - - integer, protected, public :: modefrm_pcage ! source mode index for aging transfer - integer, protected, public :: nspecfrm_pcage ! number of species transferred during aging - - integer, protected, allocatable, public :: lspecfrm_pcage(:) ! pcnst indices of species in source mode - integer, protected, allocatable, public :: lspectoo_pcage(:) ! pcnst indices of corresponding species in dest mode - - real(r8), parameter, public :: n_so4_monolayers_pcage = 8.0_r8 - - ! number of so4(+nh4) monolayers needed to "age" a carbon particle - ! 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 - real(r8), parameter, public :: & - dr_so4_monolayers_pcage = n_so4_monolayers_pcage * 4.76e-10_r8 - - ! this factor converts an soa volume to a volume of so4(+nh4) - ! having same hygroscopicity as the soa - real(r8), protected, allocatable, public :: soa_equivso4_factor(:) - - ! Private module-level storage: - - ! Mode configuration - integer :: ntot_amode_m, nsoa_m, npoa_m, nspec_max_m - integer, allocatable :: nspec_amode_m(:) - - ! Species indices in pcnst-space (set by _init, converted to vmr-space in _run) - integer :: idx_h2so4_m, idx_nh3_m, idx_msa_m - integer, allocatable :: idx_soag_m(:) - integer, allocatable :: idx_so4_a_m(:), idx_nh4_a_m(:) - integer, allocatable :: idx_soa_a_m(:,:), idx_pom_a_m(:,:) - integer, allocatable :: idx_num_m(:), idx_mass_m(:,:) - - ! Mode metadata - real(r8), allocatable :: alnsg_amode_m(:), sigmag_amode_m(:) - real(r8), allocatable :: specmw_amode_m(:,:), specdens_amode_m(:,:) - - ! Flags - logical :: do_nh4g_m, do_msag_m, do_soag_any_m - logical, allocatable :: do_soag_m(:) - - ! Species presence in modes - integer, allocatable :: ido_so4a_m(:), ido_nh4a_m(:), ido_soaa_m(:,:) - integer :: ntot_soamode_m - - ! pcage and pcarbon - integer :: modetoo_pcage - integer :: modeptr_pcarbon_m - - ! Mass-to-volume conversion factors - real (r8) :: fac_m2v_nh4, fac_m2v_so4 - real (r8), allocatable :: fac_m2v_soa(:) - - real (r8), allocatable :: fac_m2v_pcarbon(:) - - ! SOA/POA molecular weights from host model - real(r8), allocatable :: mw_soa_host_m(:), mw_poa_host_m(:) - - ! Host-provided physical constants: - real(r8) :: rair_m, mwdry_m - real(r8) :: rgas_m - -contains - -subroutine modal_aero_gasaerexch_init( & - ntot_amode, nsoa, npoa, nspec_max, & - nspec_amode, & - modeptr_pcarbon, modeptr_accum, & - alnsg_amode, sigmag_amode, & - specmw_amode, specdens_amode, spechygro, & - idx_h2so4, idx_nh3, idx_msa, & - idx_soag, & - idx_so4_a, idx_nh4_a, & - idx_soa_a, idx_pom_a, & - idx_num, idx_mass, pcnst_in, & - nspecfrm_pcage_in, & - lspecfrm_pcage_in, lspectoo_pcage_in, & - mw_soa_host, mw_poa_host, & - rair, mwdry, r_universal, & - errmsg, errflg) - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! initialize gas-aerosol exchange module - ! store species indices and mode metadata - ! compute aging/MW conversion factors - ! - ! Author: R. Easter - ! - !----------------------------------------------------------------------- - - ! arguments - integer, intent(in) :: ntot_amode - integer, intent(in) :: nsoa - integer, intent(in) :: npoa - integer, intent(in) :: nspec_max - integer, intent(in) :: nspec_amode(:) - integer, intent(in) :: modeptr_pcarbon - integer, intent(in) :: modeptr_accum - real(r8), intent(in) :: alnsg_amode(:) - real(r8), intent(in) :: sigmag_amode(:) - real(r8), intent(in) :: specmw_amode(:,:) - real(r8), intent(in) :: specdens_amode(:,:) - real(r8), intent(in) :: spechygro(:,:) - integer, intent(in) :: idx_h2so4 - integer, intent(in) :: idx_nh3 - integer, intent(in) :: idx_msa - integer, intent(in) :: idx_soag(:) - integer, intent(in) :: idx_so4_a(:) - integer, intent(in) :: idx_nh4_a(:) - integer, intent(in) :: idx_soa_a(:,:) - integer, intent(in) :: idx_pom_a(:,:) - integer, intent(in) :: idx_num(:) - integer, intent(in) :: idx_mass(:,:) - integer, intent(in) :: pcnst_in ! total number of constituents (for range checks) - integer, intent(in) :: nspecfrm_pcage_in - integer, intent(in) :: lspecfrm_pcage_in(:) ! pcnst-space - integer, intent(in) :: lspectoo_pcage_in(:) ! pcnst-space - real(r8), intent(in) :: mw_soa_host(:) - real(r8), intent(in) :: mw_poa_host(:) - real(r8), intent(in) :: rair ! dry-air gas constant from host (J/K/kg) - real(r8), intent(in) :: mwdry ! dry-air molecular weight from host (kg/kmol) - real(r8), intent(in) :: r_universal ! universal gas constant from host (J/K/kmol) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local - integer :: jsoa, l, l1, l2, n - real(r8) :: tmp2 - -!----------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - - ! Store configuration - ntot_amode_m = ntot_amode - nsoa_m = nsoa - npoa_m = npoa - nspec_max_m = nspec_max - - ! Allocate and store mode configuration arrays - allocate(nspec_amode_m(ntot_amode)) - nspec_amode_m(:) = nspec_amode(1:ntot_amode) - - allocate(alnsg_amode_m(ntot_amode)) - alnsg_amode_m(:) = alnsg_amode(1:ntot_amode) - - allocate(sigmag_amode_m(ntot_amode)) - sigmag_amode_m(:) = sigmag_amode(1:ntot_amode) - - allocate(specmw_amode_m(nspec_max, ntot_amode)) - specmw_amode_m(:,:) = specmw_amode(1:nspec_max, 1:ntot_amode) - - allocate(specdens_amode_m(nspec_max, ntot_amode)) - specdens_amode_m(:,:) = specdens_amode(1:nspec_max, 1:ntot_amode) - - ! Store species indices - idx_h2so4_m = idx_h2so4 - idx_nh3_m = idx_nh3 - idx_msa_m = idx_msa - - allocate(idx_soag_m(nsoa)) - idx_soag_m(:) = idx_soag(1:nsoa) - - allocate(idx_so4_a_m(ntot_amode)) - idx_so4_a_m(:) = idx_so4_a(1:ntot_amode) - - allocate(idx_nh4_a_m(ntot_amode)) - idx_nh4_a_m(:) = idx_nh4_a(1:ntot_amode) - - allocate(idx_soa_a_m(ntot_amode, nsoa)) - idx_soa_a_m(:,:) = idx_soa_a(1:ntot_amode, 1:nsoa) - - allocate(idx_pom_a_m(ntot_amode, npoa)) - idx_pom_a_m(:,:) = idx_pom_a(1:ntot_amode, 1:npoa) - - allocate(idx_num_m(ntot_amode)) - idx_num_m(:) = idx_num(1:ntot_amode) - - allocate(idx_mass_m(nspec_max, ntot_amode)) - idx_mass_m(:,:) = idx_mass(1:nspec_max, 1:ntot_amode) - - ! Store pcarbon mode pointer - modeptr_pcarbon_m = modeptr_pcarbon - - ! Store molecular weights - allocate(mw_soa_host_m(nsoa)) - mw_soa_host_m(:) = mw_soa_host(1:nsoa) - - allocate(mw_poa_host_m(npoa)) - mw_poa_host_m(:) = mw_poa_host(1:npoa) - - ! Store host physical constants - rair_m = rair - mwdry_m = mwdry - rgas_m = r_universal * 1.0e-3_r8 ! J/K/kmol -> J/K/mol - - ! Validate H2SO4 index (required species) - if ((idx_h2so4 <= 0) .or. (idx_h2so4 > pcnst_in)) then - write(errmsg, '(a,i7)') & - 'modal_aero_gasaerexch_init -- cannot find H2SO4 species, idx=', idx_h2so4 - errflg = 1 - return - end if - - ! Compute species presence flags - do_nh4g_m = .false. - if ((idx_nh3 > 0) .and. (idx_nh3 <= pcnst_in)) do_nh4g_m = .true. - - do_msag_m = .false. - if ((idx_msa > 0) .and. (idx_msa <= pcnst_in)) do_msag_m = .true. - - allocate(do_soag_m(nsoa)) - do_soag_any_m = .false. - do_soag_m(:) = .false. - do jsoa = 1, nsoa - if ((idx_soag(jsoa) > 0) .and. (idx_soag(jsoa) <= pcnst_in)) then - do_soag_any_m = .true. - do_soag_m(jsoa) = .true. - end if - end do - - ! Compute ido arrays (species presence in modes) - allocate(ido_so4a_m(ntot_amode)) - allocate(ido_nh4a_m(ntot_amode)) - allocate(ido_soaa_m(ntot_amode, nsoa)) - ido_so4a_m(:) = 0 - ido_nh4a_m(:) = 0 - ido_soaa_m(:,:) = 0 - - ntot_soamode_m = 0 - do n = 1, ntot_amode - l = idx_so4_a(n) - if ((l > 0) .and. (l <= pcnst_in)) then - ido_so4a_m(n) = 1 - if ( do_nh4g_m ) then - l = idx_nh4_a(n) - if ((l > 0) .and. (l <= pcnst_in)) then - ido_nh4a_m(n) = 1 - end if - end if - end if - - do jsoa = 1, nsoa - if ( do_soag_m(jsoa) ) then - l = idx_soa_a(n,jsoa) - if ((l > 0) .and. (l <= pcnst_in)) then - ido_soaa_m(n,jsoa) = 1 - ntot_soamode_m = n - end if - end if - end do ! jsoa - end do ! n - - ! - ! define "from mode" and "to mode" for primary carbon aging - ! - ! skip (turn off) aging if either is absent, - ! or if accum mode so4 is absent - ! - maxspec_pcage = nspec_max - allocate(lspecfrm_pcage(maxspec_pcage)) - allocate(lspectoo_pcage(maxspec_pcage)) - allocate(soa_equivso4_factor(nsoa)) - allocate(fac_m2v_soa(nsoa)) - allocate(fac_m2v_pcarbon(nspec_max)) - - lspecfrm_pcage(:) = 0 - lspectoo_pcage(:) = 0 - - modefrm_pcage = -999888777 - modetoo_pcage = -999888777 - nspecfrm_pcage = 0 - - if ((modeptr_pcarbon > 0) .and. (modeptr_accum > 0)) then - l = idx_so4_a(modeptr_accum) - if ((l > 0) .and. (l <= pcnst_in)) then - modefrm_pcage = modeptr_pcarbon - modetoo_pcage = modeptr_accum - - nspecfrm_pcage = nspecfrm_pcage_in - lspecfrm_pcage(1:nspecfrm_pcage) = lspecfrm_pcage_in(1:nspecfrm_pcage) - lspectoo_pcage(1:nspecfrm_pcage) = lspectoo_pcage_in(1:nspecfrm_pcage) - end if - end if - - if ( do_soag_any_m ) ntot_soamode_m = max( ntot_soamode_m, modefrm_pcage ) - - ! Modify ido arrays for pcage mode - if (modefrm_pcage > 0) then - ido_so4a_m(modefrm_pcage) = 2 - if (ido_nh4a_m(modetoo_pcage) == 1) ido_nh4a_m(modefrm_pcage) = 2 - do jsoa = 1, nsoa - if (ido_soaa_m(modetoo_pcage,jsoa) == 1) ido_soaa_m(modefrm_pcage,jsoa) = 2 - end do - end if - - ! set for used in aging calcs: - ! fac_m2v_so4, fac_m2v_nh4, fac_m2v_soa(:) - ! soa_equivso4_factor(:) - soa_equivso4_factor = 0.0_r8 - if (modefrm_pcage > 0) then - n = modeptr_accum - l2 = -1 - do l1 = 1, nspec_amode(n) - if (idx_mass(l1,n) == idx_so4_a(n)) then -! l2 = lspectype_amode(l1,n) - l2 = l1 -! fac_m2v_so4 = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_so4 = specmw_amode(l1,n) / specdens_amode(l1,n) -! tmp2 = spechygro(l2) - tmp2 = spechygro(l1,n) - - end if - end do - if (l2 <= 0) then - errmsg = 'modal_aero_gasaerexch_init error a002 finding accum. so4' - errflg = 1 - return - end if - - l2 = -1 - if (idx_nh4_a(n) > 0) then - do l1 = 1, nspec_amode(n) - if (idx_mass(l1,n) == idx_nh4_a(n)) then -! l2 = lspectype_amode(l1,n) - l2 = l1 -! fac_m2v_nh4 = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_nh4 = specmw_amode(l1,n) / specdens_amode(l1,n) - - end if - end do - if (l2 <= 0) then - errmsg = 'modal_aero_gasaerexch_init error a002 finding accum. nh4' - errflg = 1 - return - end if - else - fac_m2v_nh4 = fac_m2v_so4 - end if - - do jsoa = 1, nsoa - l2 = -1 - if (idx_soa_a(n,jsoa) <= 0) then - write( errmsg, '(a,i4)') 'modal_aero_gasaerexch_init error a001 finding accum. jsoa =', jsoa - errflg = 1 - return - end if - do l1 = 1, nspec_amode(n) - if (idx_mass(l1,n) == idx_soa_a(n,jsoa)) then -! l2 = lspectype_amode(l1,n) - l2 = l1 -! fac_m2v_soa(jsoa) = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_soa(jsoa) = specmw_amode(l1,n) / specdens_amode(l1,n) -! soa_equivso4_factor(jsoa) = spechygro(l2)/tmp2 - soa_equivso4_factor(jsoa) = spechygro(l1,n)/tmp2 - end if - end do - if (l2 <= 0) then - write( errmsg, '(a,i4)') 'modal_aero_gasaerexch_init error a002 finding accum. jsoa =', jsoa - errflg = 1 - return - end if - end do - - fac_m2v_pcarbon(:) = 0.0_r8 - n = modeptr_pcarbon - do l = 1, nspec_amode(n) -! l2 = lspectype_amode(l,n) -! fac_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) -! [m3-AP/kmol-AP] = [kg-AP/kmol-AP] / [kg-AP/m3-AP] -! fac_m2v_pcarbon(l) = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_pcarbon(l) = specmw_amode(l,n) / specdens_amode(l,n) - end do - end if - -end subroutine modal_aero_gasaerexch_init - -subroutine modal_aero_gasaerexch_run( & - ncol, pver, deltat, top_lev, & - loffset, & - t, pmid, pdel, gravit, & - troplev, & - dgncur_a, dgncur_awet, & - use_sulfeq, sulfeq, & - num_q, & - q, & - dqdt, dotend, qsrflx_gaexch, & - errmsg, errflg) - integer, intent(in) :: ncol ! # of atmospheric columns - integer, intent(in) :: pver ! # of vertical levels - real(r8), intent(in) :: deltat ! time step [s] - integer, intent(in) :: top_lev ! top level for aerosol processes - integer, intent(in) :: loffset ! offset to convert pcnst-space to vmr-space [index] - integer, intent(in) :: troplev(:) ! (ncol) tropopause vertical index [index] - real(r8), intent(in) :: t(:,:) ! (ncol,pver) temperature [K] - real(r8), intent(in) :: pmid(:,:) ! (ncol,pver) pressure [Pa] - real(r8), intent(in) :: pdel(:,:) ! (ncol,pver) pressure thickness [Pa] - real(r8), intent(in) :: gravit ! gravitational acceleration [m s-2] - real(r8), intent(in) :: dgncur_a(:,:,:) ! (ncol,pver,ntot_amode) dry diameter - real(r8), intent(in) :: dgncur_awet(:,:,:) ! (ncol,pver,ntot_amode) wet diameter - logical, intent(in) :: use_sulfeq ! whether to use strat equilibrium - real(r8), intent(in) :: sulfeq(:,:,:) ! (ncol,pver,ntot_amode) sulfeq values - integer, intent(in) :: num_q ! # of species in vmr array (= gas_pcnst) - real(r8), intent(in) :: q(:,:,:) ! (ncol,pver,num_q) tracer VMR - ! *** MUST BE #/kmol-air for number - ! *** MUST BE mol/mol-air for mass - real(r8), intent(out) :: dqdt(:,:,:) ! (ncol,pver,num_q) tendencies - logical, intent(out) :: dotend(:) ! (num_q) which species have tendencies - real(r8), intent(out) :: qsrflx_gaexch(:,:) ! (ncol,num_q) column-integrated gas-aerosol - ! exchange source/sink (kg/m2/s, pre adv_mass/mwdry - ! scaling) for the _sfgaex1 diagnostic. - ! Accumulated per-term here because the per-mode - ! and primary-carbon-aging contributions must be - ! summed separately to stay bfb with CAM. - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! computes TMR (tracer mixing ratio) tendencies for gas condensation - ! onto aerosol particles - ! - ! this version does condensation of H2SO4, NH3, and MSA, both treated as - ! completely non-volatile (gas --> aerosol, but no aerosol --> gas) - ! gas H2SO4 goes to aerosol SO4 - ! gas MSA (if present) goes to aerosol SO4 - ! aerosol MSA is not distinguished from aerosol SO4 - ! gas NH3 (if present) goes to aerosol NH4 - ! if gas NH3 is not present, then ???? - - ! local variables - 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, iq, itmpa - integer :: ido_so4a(ntot_amode_m), ido_nh4a(ntot_amode_m) - integer :: ido_soaa(ntot_amode_m,nsoa_m) - integer :: j, jsoa - integer :: k - integer :: l, lsfrm, lstoo - integer :: l_so4g, l_nh4g, l_msag - integer :: l_soag(nsoa_m) - integer :: n, niter, niter_max, ntot_soamode - - ! Local offset-adjusted index arrays (pcnst-space - loffset = vmr space) - integer :: idx_so4_a_q(ntot_amode_m), idx_nh4_a_q(ntot_amode_m) - integer :: idx_soa_a_q(ntot_amode_m,nsoa_m), idx_pom_a_q(ntot_amode_m,npoa_m) - integer :: idx_num_q(ntot_amode_m), idx_mass_q(nspec_max_m,ntot_amode_m) - integer :: lspecfrm_q(maxspec_pcage), lspectoo_q(maxspec_pcage) - - real (r8) :: avg_uprt_nh4, avg_uprt_so4, avg_uprt_soa(nsoa_m) - real (r8) :: deltatxx - real (r8) :: dqdt_nh4(ntot_amode_m), dqdt_so4(ntot_amode_m) - real (r8) :: dqdt_soa(ntot_amode_m,nsoa_m) - real (r8) :: dqdt_soag(nsoa_m) - real (r8) :: fac_volsfc_pcarbon - real (r8) :: fgain_nh4(ntot_amode_m), fgain_so4(ntot_amode_m) - real (r8) :: fgain_soa(ntot_amode_m,nsoa_m) - real(r8) :: mw_poa_host(npoa_m) ! molec wght of poa used in host code - real(r8) :: mw_soa_host(nsoa_m) ! molec wght of poa used in host code - real (r8) :: qmax_nh4, qnew_nh4, qnew_so4 - real (r8) :: qold_nh4(ntot_amode_m), qold_so4(ntot_amode_m) - real (r8) :: qold_poa(ntot_amode_m,npoa_m) - real (r8) :: qold_soa(ntot_amode_m,nsoa_m) - real (r8) :: qold_soag(nsoa_m) - real (r8) :: sum_dqdt_msa, sum_dqdt_so4 - real (r8) :: sum_dqdt_soa(nsoa_m) - real (r8) :: sum_dqdt_nh4, sum_dqdt_nh4_b - real (r8) :: sum_uprt_nh4, sum_uprt_so4 - real (r8) :: sum_uprt_soa(nsoa_m) - real (r8) :: pdel_fac ! pdel/gravit (kg/m2 per Pa), for column-integrated diagnostics - real (r8) :: tmp1, tmp2, tmpa - real (r8) :: tmp_kxt, tmp_pxt - real (r8) :: tmp_so4a_bgn, tmp_so4a_end - real (r8) :: tmp_so4g_avg, tmp_so4g_bgn, tmp_so4g_equ - real (r8) :: uptkrate(ntot_amode_m,ncol,pver) - real (r8) :: uptkratebb(ntot_amode_m) - real (r8) :: uptkrate_soa(ntot_amode_m,nsoa_m) - ! gas-to-aerosol mass transfer rates (1/s) - real (r8) :: vol_core, vol_shell - real (r8) :: xferfrac_pcage, xferfrac_max - real (r8) :: xferrate - - logical :: do_msag ! true if msa gas is a species - logical :: do_nh4g ! true if nh3 gas is a species - logical :: do_soag_any ! true if soa gas is a species - logical :: do_soag(nsoa_m) ! true if soa gas is a species - - -!---------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - -! set gas species indices from module-level storage, applying -loffset -! to convert pcnst-space to vmr (gas_pcnst) space - l_so4g = idx_h2so4_m - loffset - l_nh4g = idx_nh3_m - loffset - l_msag = idx_msa_m - loffset - do_nh4g = do_nh4g_m - do_msag = do_msag_m - do_soag_any = do_soag_any_m - do_soag(:) = do_soag_m(:) - do jsoa = 1, nsoa_m - l_soag(jsoa) = idx_soag_m(jsoa) - loffset - end do - -! compute offset-adjusted per-mode index arrays - idx_so4_a_q(:) = idx_so4_a_m(:) - loffset - idx_nh4_a_q(:) = idx_nh4_a_m(:) - loffset - idx_soa_a_q(:,:) = idx_soa_a_m(:,:) - loffset - idx_pom_a_q(:,:) = idx_pom_a_m(:,:) - loffset - idx_num_q(:) = idx_num_m(:) - loffset - idx_mass_q(:,:) = idx_mass_m(:,:) - loffset - do iq = 1, nspecfrm_pcage - lspecfrm_q(iq) = lspecfrm_pcage(iq) - loffset - lspectoo_q(iq) = lspectoo_pcage(iq) - if (lspectoo_q(iq) > 0) lspectoo_q(iq) = lspectoo_q(iq) - loffset - end do - -! copy ido arrays from module-level storage - ido_so4a(:) = ido_so4a_m(:) - ido_nh4a(:) = ido_nh4a_m(:) - ido_soaa(:,:) = ido_soaa_m(:,:) - ntot_soamode = ntot_soamode_m - -! set molecular weights from module-level storage - mw_soa_host(:) = mw_soa_host_m(:) - mw_poa_host(:) = mw_poa_host_m(:) - -! set tendency flags - dotend(:) = .false. - - dotend(l_so4g) = .true. - if ( do_nh4g ) dotend(l_nh4g) = .true. - if ( do_msag ) dotend(l_msag) = .true. - do jsoa = 1, nsoa_m - if ( do_soag(jsoa) ) dotend(l_soag(jsoa)) = .true. - end do - - do n = 1, ntot_amode_m - if (ido_so4a(n) == 1) then - l = idx_so4_a_q(n) - dotend(l) = .true. - if ( do_nh4g ) then - if (ido_nh4a(n) == 1) then - l = idx_nh4_a_q(n) - dotend(l) = .true. - end if - end if - end if - - do jsoa = 1, nsoa_m - if ( do_soag(jsoa) ) then - if (ido_soaa(n,jsoa) == 1) then - l = idx_soa_a_q(n,jsoa) - dotend(l) = .true. - end if - end if - end do ! jsoa - end do ! n - - - if (modefrm_pcage > 0) then - do iq = 1, nspecfrm_pcage - lsfrm = lspecfrm_q(iq) - lstoo = lspectoo_q(iq) - if ((lsfrm > 0) .and. (lsfrm <= num_q)) then - dotend(lsfrm) = .true. - if ((lstoo > 0) .and. (lstoo <= num_q)) then - dotend(lstoo) = .true. - end if - end if - end do - - - n = modeptr_pcarbon_m - fac_volsfc_pcarbon = exp( 2.5_r8*(alnsg_amode_m(n)**2) ) - xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps - end if - - -! zero out tendencies - dqdt(:,:,:) = 0.0_r8 - qsrflx_gaexch(:,:) = 0.0_r8 - -! compute gas-to-aerosol mass transfer rates - call gas_aer_uptkrates( ncol, pver, top_lev, & - loffset, & - q, t, pmid, & - dgncur_awet, uptkrate ) - - -! use this for tendency calcs to avoid generating very small negative values - deltatxx = deltat * (1.0_r8 + 1.0e-15_r8) - - - do k=top_lev,pver - do i=1,ncol - -! fgain_so4(n) = fraction of total h2so4 uptake going to mode n -! fgain_nh4(n) = fraction of total nh3 uptake going to mode n - sum_uprt_so4 = 0.0_r8 - sum_uprt_nh4 = 0.0_r8 - sum_uprt_soa = 0.0_r8 - do n = 1, ntot_amode_m - uptkratebb(n) = uptkrate(n,i,k) - if (ido_so4a(n) > 0) then - fgain_so4(n) = uptkratebb(n) - sum_uprt_so4 = sum_uprt_so4 + fgain_so4(n) - if (ido_so4a(n) == 1) then - qold_so4(n) = q(i,k,idx_so4_a_q(n)) - else - qold_so4(n) = 0.0_r8 - end if - else - fgain_so4(n) = 0.0_r8 - qold_so4(n) = 0.0_r8 - end if - - if (ido_nh4a(n) > 0) then - ! 2.08 factor is for gas diffusivity (nh3/h2so4) - ! differences in fuch-sutugin and accom coef ignored - fgain_nh4(n) = uptkratebb(n)*2.08_r8 - sum_uprt_nh4 = sum_uprt_nh4 + fgain_nh4(n) - if (ido_nh4a(n) == 1) then - qold_nh4(n) = q(i,k,idx_nh4_a_q(n)) - else - qold_nh4(n) = 0.0_r8 - end if - else - fgain_nh4(n) = 0.0_r8 - qold_nh4(n) = 0.0_r8 - end if - - do j = 1, npoa_m - l = idx_pom_a_q(n,j) - if (l > 0) then - qold_poa(n,j) = q(i,k,l) - else - qold_poa(n,j) = 0.0_r8 - end if - end do - - itmpa = 0 - do jsoa = 1, nsoa_m - if (ido_soaa(n,jsoa) > 0) then - ! 0.81 factor is for gas diffusivity (soa/h2so4) - ! (differences in fuch-sutugin and accom coef ignored) - fgain_soa(n,jsoa) = uptkratebb(n)*0.81_r8 - sum_uprt_soa(jsoa) = sum_uprt_soa(jsoa) + fgain_soa(n,jsoa) - if (ido_soaa(n,jsoa) == 1) then - l = idx_soa_a_q(n,jsoa) - qold_soa(n,jsoa) = q(i,k,l) - itmpa = itmpa + 1 - else - qold_soa(n,jsoa) = 0.0_r8 - end if - else - fgain_soa(n,jsoa) = 0.0_r8 - qold_soa(n,jsoa) = 0.0_r8 - end if - uptkrate_soa(n,jsoa) = fgain_soa(n,jsoa) - end do ! jsoa - ! in previous code versions with nsoa=1, - ! qold_poa was non-zero (i.e., loaded from q) only when ido_soaa(n)=1 - ! thus qold_poa=0 for the primary carbon mode which has ido_soaa=2 - ! this is probably not how it should be - if (itmpa == 0) qold_poa(n,:) = 0.0_r8 - - end do ! n - - if (sum_uprt_so4 > 0.0_r8) then - do n = 1, ntot_amode_m - fgain_so4(n) = fgain_so4(n) / sum_uprt_so4 - end do - end if -! at this point (sum_uprt_so4 <= 0.0) only when all the fgain_so4 are zero - if (sum_uprt_nh4 > 0.0_r8) then - do n = 1, ntot_amode_m - fgain_nh4(n) = fgain_nh4(n) / sum_uprt_nh4 - end do - end if - - do jsoa = 1, nsoa_m - if (sum_uprt_soa(jsoa) > 0.0_r8) then - do n = 1, ntot_amode_m - fgain_soa(n,jsoa) = fgain_soa(n,jsoa) / sum_uprt_soa(jsoa) - end do - end if - end do - -! uptake amount (fraction of gas uptaken) over deltat - avg_uprt_so4 = (1.0_r8 - exp(-deltatxx*sum_uprt_so4))/deltatxx - avg_uprt_nh4 = (1.0_r8 - exp(-deltatxx*sum_uprt_nh4))/deltatxx - - do jsoa = 1, nsoa_m - avg_uprt_soa(jsoa) = (1.0_r8 - exp(-deltatxx*sum_uprt_soa(jsoa)))/deltatxx - end do - -! sum_dqdt_so4 = so4_a tendency from h2so4 gas uptake (mol/mol/s) -! sum_dqdt_msa = msa_a tendency from msa gas uptake (mol/mol/s) -! sum_dqdt_nh4 = nh4_a tendency from nh3 gas uptake (mol/mol/s) -! sum_dqdt_soa = soa_a tendency from soa gas uptake (mol/mol/s) - sum_dqdt_so4 = q(i,k,l_so4g) * avg_uprt_so4 - if ( do_msag ) then - sum_dqdt_msa = q(i,k,l_msag) * avg_uprt_so4 - else - sum_dqdt_msa = 0.0_r8 - end if - if ( do_nh4g ) then - sum_dqdt_nh4 = q(i,k,l_nh4g) * avg_uprt_nh4 - else - sum_dqdt_nh4 = 0.0_r8 - end if - - do jsoa = 1, nsoa_m - if ( do_soag(jsoa) ) then - sum_dqdt_soa(jsoa) = q(i,k,l_soag(jsoa)) * avg_uprt_soa(jsoa) - else - sum_dqdt_soa(jsoa) = 0.0_r8 - end if - end do - - if ( use_sulfeq .and. (k <= troplev(i)) ) then - ! compute TMR tendencies for so4 interstial aerosol due to reversible gas uptake - ! only above the tropopause - - tmp_kxt = deltatxx*sum_uprt_so4 ! sum over modes of uptake_rate*deltat - tmp_pxt = 0.0_r8 - do n = 1, ntot_amode_m - if (ido_so4a(n) <= 0) cycle - tmp_pxt = tmp_pxt + uptkratebb(n)*sulfeq(i,k,n) - end do - tmp_pxt = max( 0.0_r8, tmp_pxt*deltatxx ) ! sum over modes of uptake_rate*sulfeq*deltat - tmp_so4g_bgn = q(i,k,l_so4g) - ! calc avg h2so4(g) over deltat - if (tmp_kxt >= 1.0e-5_r8) then - ! exponential decay towards equilibrium value solution - tmp_so4g_equ = tmp_pxt/tmp_kxt - tmp_so4g_avg = tmp_so4g_equ + (tmp_so4g_bgn-tmp_so4g_equ)*(1.0_r8-exp(-tmp_kxt))/tmp_kxt - else - ! first order approx for tmp_kxt small - tmp_so4g_avg = tmp_so4g_bgn*(1.0_r8-0.5_r8*tmp_kxt) + 0.5_r8*tmp_pxt - end if - sum_dqdt_so4 = 0.0_r8 - do n = 1, ntot_amode_m - if (ido_so4a(n) <= 0) cycle - ! calc change to so4(a) in mode n - if (ido_so4a(n) == 1) then - l = idx_so4_a_q(n) - tmp_so4a_bgn = q(i,k,l) - else - tmp_so4a_bgn = 0.0_r8 - end if - tmp_so4a_end = tmp_so4a_bgn + deltatxx*uptkratebb(n)*(tmp_so4g_avg-sulfeq(i,k,n)) - tmp_so4a_end = max( 0.0_r8, tmp_so4a_end ) - dqdt_so4(n) = (tmp_so4a_end - tmp_so4a_bgn)/deltatxx - sum_dqdt_so4 = sum_dqdt_so4 + dqdt_so4(n) - end do - ! do not allow msa condensation in stratosphere - ! ( Note that the code for msa has never been used. - ! The plan was to simulate msa(g), treat it as non-volatile (like h2so4(g)), - ! and treat condensed msa as sulfate, so just one additional tracer. ) - if ( do_msag ) sum_dqdt_msa = 0.0_r8 - - else - ! compute TMR tendencies for so4 interstial aerosol due to simple gas uptake - do n = 1, ntot_amode_m - dqdt_so4(n) = fgain_so4(n)*(sum_dqdt_so4 + sum_dqdt_msa) - end do - end if - - ! compute TMR tendencies for nh4 interstial aerosol due to simple gas uptake - ! but force nh4/so4 molar ratio <= 2 - sum_dqdt_nh4_b = 0.0_r8 - dqdt_nh4(:) = 0._r8 - if ( do_nh4g ) then - do n = 1, ntot_amode_m - dqdt_nh4(n) = fgain_nh4(n)*sum_dqdt_nh4 - qnew_nh4 = qold_nh4(n) + dqdt_nh4(n)*deltat - qnew_so4 = qold_so4(n) + dqdt_so4(n)*deltat - qmax_nh4 = 2.0_r8*qnew_so4 - if (qnew_nh4 > qmax_nh4) then - dqdt_nh4(n) = (qmax_nh4 - qold_nh4(n))/deltatxx - end if - sum_dqdt_nh4_b = sum_dqdt_nh4_b + dqdt_nh4(n) - end do - end if - - if (( do_soag_any ) .and. (method_soa > 1)) then -! compute TMR tendencies for soag and soa interstial aerosol -! using soa parameterization - niter_max = 1000 - dqdt_soa(:,:) = 0.0_r8 - dqdt_soag(:) = 0.0_r8 - do jsoa = 1, nsoa_m - qold_soag(jsoa) = q(i,k,l_soag(jsoa)) - end do - - call modal_aero_soaexch( deltat, t(i,k), pmid(i,k), & - niter, niter_max, ntot_amode_m, ntot_soamode, npoa_m, nsoa_m, & - mw_poa_host, mw_soa_host, & - qold_soag, qold_soa, qold_poa, uptkrate_soa, & - dqdt_soag, dqdt_soa ) - sum_dqdt_soa(:) = -dqdt_soag(:) - - else if ( do_soag_any ) then -! compute TMR tendencies for soa interstial aerosol -! due to simple gas uptake - - do jsoa = 1, nsoa_m - do n = 1, ntot_amode_m - dqdt_soa(n,jsoa) = fgain_soa(n,jsoa)*sum_dqdt_soa(jsoa) - end do - end do - else ! method_soa is neither 1 nor 2, no uptake - dqdt_soa(:,:) = 0.0_r8 - end if - - pdel_fac = pdel(i,k)/gravit - do n = 1, ntot_amode_m - if (ido_so4a(n) == 1) then - l = idx_so4_a_q(n) - dqdt(i,k,l) = dqdt_so4(n) - qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_so4(n)*pdel_fac - end if - - if ( do_nh4g ) then - if (ido_nh4a(n) == 1) then - l = idx_nh4_a_q(n) - dqdt(i,k,l) = dqdt_nh4(n) - qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_nh4(n)*pdel_fac - end if - end if - - do jsoa = 1, nsoa_m - if ( do_soag(jsoa) ) then - if (ido_soaa(n,jsoa) == 1) then - l = idx_soa_a_q(n,jsoa) - dqdt(i,k,l) = dqdt_soa(n,jsoa) !calculated by modal_aero_soaexch for method_soa=2 - qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_soa(n,jsoa)*pdel_fac - end if - end if - end do - end do ! n - -! compute TMR tendencies for h2so4, nh3, and msa gas -! due to simple gas uptake - l = l_so4g - dqdt(i,k,l) = -sum_dqdt_so4 - qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt(i,k,l)*pdel_fac - - if ( do_msag ) then - l = l_msag - dqdt(i,k,l) = -sum_dqdt_msa - qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt(i,k,l)*pdel_fac - end if - - if ( do_nh4g ) then - l = l_nh4g - dqdt(i,k,l) = -sum_dqdt_nh4_b - qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt(i,k,l)*pdel_fac - end if - - do jsoa = 1, nsoa_m - if ( do_soag(jsoa) ) then - l = l_soag(jsoa) - dqdt(i,k,l) = -sum_dqdt_soa(jsoa) -! dqdt for gas is negative of the sum of dqdt for aerosol soa species in each mode: Manish - qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt(i,k,l)*pdel_fac - end if - end do - -! compute TMR tendencies associated with primary carbon aging - if (modefrm_pcage > 0) then - n = modeptr_pcarbon_m - tmpa = 0.0_r8 - do jsoa = 1, nsoa_m - tmpa = tmpa + dqdt_soa(n,jsoa)*fac_m2v_soa(jsoa)*soa_equivso4_factor(jsoa) - end do - vol_shell = deltat * & - ( dqdt_so4(n)*fac_m2v_so4 + dqdt_nh4(n)*fac_m2v_nh4 + tmpa ) - vol_core = 0.0_r8 - do l = 1, nspec_amode_m(n) - vol_core = vol_core + & - q(i,k,idx_mass_q(l,n))*fac_m2v_pcarbon(l) - 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_pcarbon) -! = (shell-volume corresponding to n_so4_monolayers_pcage)/core-volume -! The 6.0/(dgncur_a*fac_volsfc_pcarbon) = (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 -! - tmp1 = vol_shell*dgncur_a(i,k,n)*fac_volsfc_pcarbon - 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 - - if (xferfrac_pcage > 0.0_r8) then - do iq = 1, nspecfrm_pcage - lsfrm = lspecfrm_q(iq) - lstoo = lspectoo_q(iq) - xferrate = (xferfrac_pcage/deltat)*q(i,k,lsfrm) - dqdt(i,k,lsfrm) = dqdt(i,k,lsfrm) - xferrate - qsrflx_gaexch(i,lsfrm) = qsrflx_gaexch(i,lsfrm) - xferrate*pdel_fac - if ((lstoo > 0) .and. (lstoo <= num_q)) then - dqdt(i,k,lstoo) = dqdt(i,k,lstoo) + xferrate - qsrflx_gaexch(i,lstoo) = qsrflx_gaexch(i,lstoo) + xferrate*pdel_fac - end if - end do - - if (ido_so4a(modetoo_pcage) > 0) then - l = idx_so4_a_q(modetoo_pcage) - dqdt(i,k,l) = dqdt(i,k,l) + dqdt_so4(modefrm_pcage) - qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_so4(modefrm_pcage)*pdel_fac - end if - - if (ido_nh4a(modetoo_pcage) > 0) then - l = idx_nh4_a_q(modetoo_pcage) - dqdt(i,k,l) = dqdt(i,k,l) + dqdt_nh4(modefrm_pcage) - qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_nh4(modefrm_pcage)*pdel_fac - end if - - do jsoa = 1, nsoa_m - if (ido_soaa(modetoo_pcage,jsoa) > 0) then - l = idx_soa_a_q(modetoo_pcage,jsoa) - dqdt(i,k,l) = dqdt(i,k,l) + dqdt_soa(modefrm_pcage,jsoa) - qsrflx_gaexch(i,l) = qsrflx_gaexch(i,l) + dqdt_soa(modefrm_pcage,jsoa)*pdel_fac - end if - end do - - end if - - end if - - end do ! "i = 1, ncol" - end do ! "k = top_lev, pver" - -end subroutine modal_aero_gasaerexch_run - - -subroutine gas_aer_uptkrates( ncol, pver, top_lev, & - loffset, & - q, t, pmid, & - dgncur_awet, 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 - ! - - integer, intent(in) :: ncol ! number of atmospheric column - integer, intent(in) :: pver ! number of vertical levels - integer, intent(in) :: top_lev ! top level for aerosol processes - integer, intent(in) :: loffset ! offset to convert pcnst-space to vmr space - real(r8), intent(in) :: q(:,:,:) ! (ncol,pver,num_q) Tracer array (mol,#/mol-air) - real(r8), intent(in) :: t(:,:) ! (ncol,pver) Temperature in Kelvin - real(r8), intent(in) :: pmid(:,:) ! (ncol,pver) Air pressure in Pa - real(r8), intent(in) :: dgncur_awet(:,:,:) ! (ncol,pver,ntot_amode_m) - - real(r8), intent(out) :: uptkrate(:,:,:) ! (ntot_amode_m,ncol,pver) - ! gas-to-aerosol mass transfer rates (1/s) - - -! local - integer, parameter :: nghq = 2 - integer :: i, iq, k, n - - ! Can use sqrt here once Lahey is gone. - real(r8), parameter :: tworootpi = 3.5449077_r8 - real(r8), parameter :: root2 = 1.4142135_r8 - real(r8), parameter :: beta = 2.0_r8 - - real(r8) :: aircon - real(r8) :: const - real(r8) :: dp - real(r8) :: gasdiffus, gasspeed - real(r8) :: freepathx2, fuchs_sutugin - real(r8) :: knudsen - real(r8) :: lndp, lndpgn, lnsg - real(r8) :: num_a - real(r8) :: rhoair - real(r8) :: sumghq - real(r8), save :: xghq(nghq), wghq(nghq) ! quadrature abscissae and weights - - data xghq / 0.70710678_r8, -0.70710678_r8 / - data wghq / 0.88622693_r8, 0.88622693_r8 / - - -! outermost loop over all modes - do n = 1, ntot_amode_m - -! 22-aug-2007 rc easter - get number from q array rather -! than computing a "bounded" number conc. -!! compute dry volume = sum_over_components{ component_mass / density } -!! (m3-AP/mol-air) -!! compute it for all i,k to improve accessing q array -! dryvol_a(1:ncol,:) = 0.0_r8 -! do l1 = 1, nspec_amode(n) -! l2 = lspectype_amode(l1,n) -!! dum_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) -!! [m3-AP/kmol-AP]= [kg-AP/kmol-AP] / [kg-AP/m3-AP] -! dum_m2v = specmw_amode(l2) / specdens_amode(l2) -! la = lmassptr_amode(l1,n) -! dryvol_a(1:ncol,:) = dryvol_a(1:ncol,:) & -! + max(0.0_r8,q(1:ncol,:,la))*dum_m2v -! end do - -! loops k and i - do k=top_lev,pver - do i=1,ncol - - rhoair = pmid(i,k)/(rair_m*t(i,k)) ! (kg-air/m3) -! aircon = 1.0e3*rhoair/mwdry ! (mol-air/m3) - -!! "bounded" number conc. (#/m3) -! num_a = dryvol_a(i,k)*v2ncur_a(i,k,n)*aircon - -! number conc. (#/m3) -- note q(i,k,numptr) is (#/kmol-air) -! so need aircon in (kmol-air/m3) - aircon = rhoair/mwdry_m ! (kmol-air/m3) - num_a = q(i,k,idx_num_m(n)-loffset)*aircon - -! gasdiffus = h2so4 gas diffusivity from mosaic code (m^2/s) -! (pmid must be Pa) - gasdiffus = 0.557e-4_r8 * (t(i,k)**1.75_r8) / pmid(i,k) -! gasspeed = h2so4 gas mean molecular speed from mosaic code (m/s) - gasspeed = 1.470e1_r8 * sqrt(t(i,k)) -! freepathx2 = 2 * (h2so4 mean free path) (m) - freepathx2 = 6.0_r8*gasdiffus/gasspeed - - lnsg = log( sigmag_amode_m(n) ) - lndpgn = log( dgncur_awet(i,k,n) ) ! (m) - const = tworootpi * num_a * exp(beta*lndpgn + 0.5_r8*(beta*lnsg)**2) - -! sum over gauss-hermite quadrature points - sumghq = 0.0_r8 - do iq = 1, nghq - lndp = lndpgn + beta*lnsg**2 + root2*lnsg*xghq(iq) - dp = exp(lndp) - -! knudsen number - knudsen = freepathx2/dp -! Changed by Manish Shrivastava on 7/17/2013 to use accom=1; because we do not know better -! following assumes accomodation coefficient = ac = 1. instead 0.65 ! answer change needs to be tested -! (Adams & Seinfeld, 2002, JGR, and references therein) -! fuchs_sutugin = (0.75*ac*(1. + knudsen)) / -! (knudsen*(1.0 + knudsen + 0.283*ac) + 0.75*ac) - fuchs_sutugin = (0.4875_r8*(1._r8 + knudsen)) / & - (knudsen*(1.184_r8 + knudsen) + 0.4875_r8) - sumghq = sumghq + wghq(iq)*dp*fuchs_sutugin/(dp**beta) - end do - uptkrate(n,i,k) = const * gasdiffus * sumghq - - end do ! "do i = 1, ncol" - end do ! "do k = 1, pver" - - end do ! "do n = 1, ntot_soamode" - -end subroutine gas_aer_uptkrates - -!---------------------------------------------------------------------- - -subroutine modal_aero_soaexch( dtfull, temp, pres, & - niter, niter_max, ntot_amode, ntot_soamode, ntot_poaspec, ntot_soaspec, & - mw_poa_host, mw_soa_host, & - g_soa_in, a_soa_in, a_poa_in, xferrate_in, & - g_soa_tend, a_soa_tend ) -! g_soa_tend, a_soa_tend, g0_soa, idiagss ) - -!----------------------------------------------------------------------- -! -! Purpose: -! -! calculates condensation/evaporation of "soa gas" -! to/from multiple aerosol modes in 1 grid cell -! -! key assumptions -! (1) ambient equilibrium vapor pressure of soa gas -! is given by p0_soa_298 and delh_vap_soa -! (2) equilibrium vapor pressure of soa gas at aerosol -! particle surface is given by raoults law in the form -! g_star = g0_soa*[a_soa/(a_soa + a_opoa)] -! (3) (oxidized poa)/(total poa) is equal to frac_opoa (constant) -! -! -! Author: R. Easter and R. Zaveri -! Additions to run with multiple BC, SOA and POM's: Shrivastava et al., 2015 -!----------------------------------------------------------------------- - - implicit none - - real(r8), intent(in) :: dtfull ! full integration time step (s) - real(r8), intent(in) :: temp ! air temperature (K) - real(r8), intent(in) :: pres ! air pressure (Pa) - integer, intent(out) :: niter ! number of iterations performed - integer, intent(in) :: niter_max ! max allowed number of iterations - integer, intent(in) :: ntot_amode ! number of modes - integer, intent(in) :: ntot_soamode ! number of modes having soa - integer, intent(in) :: ntot_poaspec ! number of poa species - integer, intent(in) :: ntot_soaspec ! number of soa species - real(r8), intent(in) :: mw_poa_host(ntot_poaspec) ! molec wght of poa used in host code - real(r8), intent(in) :: mw_soa_host(ntot_soaspec) ! molec wght of poa used in host code - real(r8), intent(in) :: g_soa_in(ntot_soaspec) ! initial soa gas mixrat (mol/mol at host mw) - real(r8), intent(in) :: a_soa_in(ntot_amode,ntot_soaspec) ! initial soa aerosol mixrat (mol/mol at host mw) - real(r8), intent(in) :: a_poa_in(ntot_amode,ntot_poaspec) ! initial poa aerosol mixrat (mol/mol at host mw) - real(r8), intent(in) :: xferrate_in(ntot_amode,ntot_soaspec) ! gas-aerosol mass transfer rate (1/s) - real(r8), intent(out) :: g_soa_tend(ntot_soaspec) ! soa gas mixrat tendency (mol/mol/s at host mw) - real(r8), intent(out) :: a_soa_tend(ntot_amode,ntot_soaspec) ! soa aerosol mixrat tendency (mol/mol/s at host mw) -! integer, intent(in) :: idiagss - - integer :: ll - integer :: m,k - - logical :: skip_soamode(ntot_amode) ! true if this mode does not have soa - - real(r8) :: rgas - real(r8), parameter :: a_min1 = 1.0e-20_r8 - real(r8), parameter :: g_min1 = 1.0e-20_r8 - real(r8), parameter :: alpha = 0.05_r8 ! parameter used in calc of time step - real(r8), parameter :: dtsub_fixed = -1.0_r8 ! fixed sub-step for time integration (s) - - real(r8) :: a_ooa_sum_tmp(ntot_soamode) ! total ooa (=soa+opoa) in a mode - real(r8) :: a_opoa(ntot_soamode) ! oxidized-poa aerosol mixrat (mol/mol at actual mw) - real(r8) :: a_soa(ntot_soamode,ntot_soaspec) ! soa aerosol mixrat (mol/mol at actual mw) - real(r8) :: a_soa_tmp(ntot_soamode,ntot_soaspec) ! temporary soa aerosol mixrat (mol/mol) - real(r8) :: beta(ntot_soamode,ntot_soaspec) ! 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) :: dtmax ! = (dtfull-tcur) - 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_soamode,ntot_soaspec) ! 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) ! fraction of poa that is opoa - real(r8) :: phi(ntot_soamode,ntot_soaspec) ! "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_soamode,ntot_soaspec) ! 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, tmpf - real(r8) :: tot_soa(ntot_soaspec) ! g_soa + sum( a_soa(:) ) - real(r8) :: xferrate(ntot_amode,ntot_soaspec) ! gas-aerosol mass transfer rate (1/s) - - rgas = rgas_m - - ! Changed by Manish Shrivastava - opoa_frac(:) = 0.0_r8 !POA does not form solution with SOA for all runs; set opoa_frac=0.0_r8 by Manish Shrivastava - mw_poa(:) = 250.0_r8 - mw_soa(:) = 250.0_r8 - - ! New SOA properties added by Manish Shrivastava on 09/27/2012 - if (ntot_soaspec ==1) then - p0_soa_298(:) = 9.7831E-11_r8 - delh_vap_soa(:) = 131.0e3_r8 - opoa_frac(:) = 0.0_r8 - elseif (ntot_soaspec ==2) then - ! same for anthropogenic and biomass burning species - p0_soa_298 (1) = 1.0e-10_r8 - p0_soa_298 (2) = 1.0e-10_r8 - delh_vap_soa(:) = 156.0e3_r8 - elseif(ntot_soaspec ==5) then - ! 5 volatility bins for each of the a combined SOA classes ( including biomass burning, fossil fuel, biogenic) - p0_soa_298 (1) = 9.7831E-13_r8 !soaff0 C*=0.01ug/m3 - p0_soa_298 (2) = 9.7831E-12_r8 !soaff1 C*=0.10ug/m3 - p0_soa_298 (3) = 9.7831E-11_r8 !soaff2 C*=1.0ug/m3 - p0_soa_298 (4) = 9.7831E-10_r8 !soaff3 C*=10.0ug/m3 - p0_soa_298 (5) = 9.7831E-9_r8 !soaff4 C*=100.0ug/m3 - - delh_vap_soa(1) = 153.0e3_r8 - delh_vap_soa(2) = 142.0e3_r8 - delh_vap_soa(3) = 131.0e3_r8 - delh_vap_soa(4) = 120.0e3_r8 - delh_vap_soa(5) = 109.0e3_r8 - elseif(ntot_soaspec ==15) then - ! - ! 5 volatility bins for each of the 3 SOA classes ( biomass burning, fossil fuel, biogenic) - ! SOA species 1-5 are for anthropogenic while 6-10 are for biomass burning SOA - ! SOA species 11-15 are for biogenic SOA, based on Cappa et al., Reference needs to be updated - ! For MW=250.0 - p0_soa_298 (1) = 9.7831E-13_r8 !soaff0 C*=0.01ug/m3 - p0_soa_298 (2) = 9.7831E-12_r8 !soaff1 C*=0.10ug/m3 - p0_soa_298 (3) = 9.7831E-11_r8 !soaff2 C*=1.0ug/m3 - p0_soa_298 (4) = 9.7831E-10_r8 !soaff3 C*=10.0ug/m3 - p0_soa_298 (5) = 9.7831E-9_r8 !soaff4 C*=100.0ug/m3 - p0_soa_298 (6) = 9.7831E-13_r8 !soabb0 C*=0.01ug/m3 - p0_soa_298 (7) = 9.7831E-12_r8 !soabb1 C*=0.10ug/m3 - p0_soa_298 (8) = 9.7831E-11_r8 !soabb2 C*=1.0ug/m3 - p0_soa_298 (9) = 9.7831E-10_r8 !soabb3 C*=10.0ug/m3 - p0_soa_298 (10) = 9.7831E-9_r8 !soabb4 C*=100.0ug/m3 - p0_soa_298 (11) = 9.7831E-13_r8 !soabg0 C*=0.01ug/m3 - p0_soa_298 (12) = 9.7831E-12_r8 !soabg1 C*=0.1ug/m3 - p0_soa_298 (13) = 9.7831E-11_r8 !soabg2 C*=1.0ug/m3 - p0_soa_298 (14) = 9.7831E-10_r8 !soabg3 C*=10.0ug/m3 - p0_soa_298 (15) = 9.7831E-9_r8 !soabg4 C*=100.0ug/m3 - - ! - ! have to be adjusted to 15 species, following the numbers by Epstein et al., 2012 - ! - delh_vap_soa(1) = 153.0e3_r8 - delh_vap_soa(2) = 142.0e3_r8 - delh_vap_soa(3) = 131.0e3_r8 - delh_vap_soa(4) = 120.0e3_r8 - delh_vap_soa(5) = 109.0e3_r8 - delh_vap_soa(6) = 153.0e3_r8 - delh_vap_soa(7) = 142.0e3_r8 - delh_vap_soa(8) = 131.0e3_r8 - delh_vap_soa(9) = 120.0e3_r8 - delh_vap_soa(10) = 109.0e3_r8 - delh_vap_soa(11) = 153.0e3_r8 - delh_vap_soa(12) = 142.0e3_r8 - delh_vap_soa(13) = 131.0e3_r8 - delh_vap_soa(14) = 120.0e3_r8 - delh_vap_soa(15) = 109.0e3_r8 - endif - - !BSINGH - Initialized g_soa_tend and a_soa_tend to circumvent the undefined behavior (04/16/12) - g_soa_tend(:) = 0.0_r8 - a_soa_tend(:,:) = 0.0_r8 - - ! 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 m = 1, ntot_soamode - skip_soamode(m) = .true. - do ll = 1, ntot_soaspec - xferrate(m,ll) = xferrate_in(m,ll) - skip_soamode(m) = .false. - end do - end do - - ! convert incoming mixing ratios from mol/mol at the "host-code" molec. weight (12.0 in cam5) - ! to mol/mol at the "actual" molec. weight (currently assumed to be 250.0) - ! also - ! force things to be non-negative - ! calc tot_soa(ll) - ! calc a_opoa (always slightly >0) - do ll = 1, ntot_soaspec - tmpf = mw_soa_host(ll)/mw_soa(ll) - g_soa(ll) = max( g_soa_in(ll), 0.0_r8 ) * tmpf - tot_soa(ll) = g_soa(ll) - do m = 1, ntot_soamode - if ( skip_soamode(m) ) cycle - a_soa(m,ll) = max( a_soa_in(m,ll), 0.0_r8 ) * tmpf - tot_soa(ll) = tot_soa(ll) + a_soa(m,ll) - end do - end do - - do m = 1, ntot_soamode - if ( skip_soamode(m) ) cycle - a_opoa(m) = 0.0_r8 - do ll = 1, ntot_poaspec - a_opoa(m) = opoa_frac(ll)*a_poa_in(m,ll) - end do - end do - - ! 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_r8/temp)-(1.0_r8/298.0_r8)) ) - g0_soa(ll) = 1.01325e5_r8*p0_soa(ll)/pres - end do - - niter = 0 - tcur = 0.0_r8 - dtcur = 0.0_r8 - phi(:,:) = 0.0_r8 - g_star(:,:) = 0.0_r8 - -! if (idiagss > 0) then -! write(luna,'(a,1p,10e11.3)') 'p0, g0_soa', p0_soa, g0_soa -! write(luna,'(3a)') & -! 'niter, tcur, dtcur, phi(:), ', & -! 'g_star(:), ', & -! 'a_soa(:), g_soa' -! write(luna,'(3a)') & -! ' sat(:), ', & -! 'sat(:)*a_soa(:) ', & -! 'a_opoa(:)' -! write(luna,'(i3,1p,20e10.2)') niter, tcur, dtcur, & -! phi(:), g_star(:), a_soa(:), g_soa -! end if - - -! integration loop -- does multiple substeps to reach dtfull -time_loop: & - do while (tcur < dtfull-1.0e-3_r8 ) - - niter = niter + 1 - if (niter > niter_max) exit - - tmpa = 0.0_r8 ! time integration parameter for all soa species - do m = 1, ntot_soamode - if ( skip_soamode(m) ) cycle - a_ooa_sum_tmp(m) = a_opoa(m) + sum( a_soa(m,1:ntot_soaspec) ) - end do - do ll = 1, ntot_soaspec - tmpb = 0.0_r8 ! time integration parameter for a single soa species - do m = 1, ntot_soamode - if ( skip_soamode(m) ) cycle - sat(m,ll) = g0_soa(ll)/max( a_ooa_sum_tmp(m), a_min1 ) - g_star(m,ll) = sat(m,ll)*a_soa(m,ll) - phi(m,ll) = (g_soa(ll) - g_star(m,ll))/max( g_soa(ll), g_star(m,ll), g_min1 ) - tmpb = tmpb + xferrate(m,ll)*abs(phi(m,ll)) - 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) then -! here alpha/tmpa >= dtmax, so this is final substep - dtcur = dtmax - tcur = dtfull - else - dtcur = alpha/tmpa - tcur = tcur + dtcur - end if - end if - -! step 1 - for modes where soa is condensing, estimate "new" a_soa(m,ll) -! using an explicit calculation with "old" g_soa -! and g_star(m,ll) calculated using "old" a_soa(m,ll) -! do this to get better estimate of "new" a_soa(m,ll) and sat(m,ll) - do m = 1, ntot_soamode - if ( skip_soamode(m) ) cycle - do ll = 1, ntot_soaspec - ! first ll loop calcs a_soa_tmp(m,ll) & a_ooa_sum_tmp - a_soa_tmp(m,ll) = a_soa(m,ll) - beta(m,ll) = dtcur*xferrate(m,ll) - del_g_soa_tmp(ll) = g_soa(ll) - g_star(m,ll) - if (del_g_soa_tmp(ll) > 0.0_r8) then - a_soa_tmp(m,ll) = a_soa(m,ll) + beta(m,ll)*del_g_soa_tmp(ll) - end if - end do - a_ooa_sum_tmp(m) = a_opoa(m) + sum( a_soa_tmp(m,1:ntot_soaspec) ) - do ll = 1, ntot_soaspec - ! second ll loop calcs sat & g_star - if (del_g_soa_tmp(ll) > 0.0_r8) then - sat(m,ll) = g0_soa(ll)/max( a_ooa_sum_tmp(m), a_min1 ) - g_star(m,ll) = sat(m,ll)*a_soa_tmp(m,ll) ! 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(m,ll) calculated semi-implicitly - do ll = 1, ntot_soaspec - tmpa = 0.0_r8 - tmpb = 0.0_r8 - do m = 1, ntot_soamode - if ( skip_soamode(m) ) cycle - tmpa = tmpa + a_soa(m,ll)/(1.0_r8 + beta(m,ll)*sat(m,ll)) - tmpb = tmpb + beta(m,ll)/(1.0_r8 + beta(m,ll)*sat(m,ll)) - end do - - g_soa(ll) = (tot_soa(ll) - tmpa)/(1.0_r8 + tmpb) - g_soa(ll) = max( 0.0_r8, g_soa(ll) ) - do m = 1, ntot_soamode - if ( skip_soamode(m) ) cycle - a_soa(m,ll) = (a_soa(m,ll) + beta(m,ll)*g_soa(ll))/ & - (1.0_r8 + beta(m,ll)*sat(m,ll)) - end do - end do - -! if (idiagss > 0) then -! write(luna,'(i3,1p,20e10.2)') niter, tcur, dtcur, & -! phi(:), g_star(:), a_soa(:), g_soa -! write(luna,'(23x,1p,20e10.2)') & -! sat(:), sat(:)*a_soa(:), a_opoa(:) -! end if - -! if (niter > 9992000) then -! write(luna,'(a)') '*** to many iterations' -! exit -! end if - - end do time_loop - - -! calculate outgoing tendencies (at the host-code molec. weight) -! (a_soa & g_soa are at actual mw, but a_soa_in & g_soa_in are at host-code mw) - do ll = 1, ntot_soaspec - tmpf = mw_soa(ll)/mw_soa_host(ll) - g_soa_tend(ll) = (g_soa(ll)*tmpf - g_soa_in(ll))/dtfull - do m = 1, ntot_soamode - if ( skip_soamode(m) ) cycle - a_soa_tend(m,ll) = (a_soa(m,ll)*tmpf - a_soa_in(m,ll))/dtfull - end do - end do - -end subroutine modal_aero_soaexch - -end module modal_aero_gasaerexch diff --git a/src/chemistry/modal_aero/modal_aero_newnuc.F90 b/src/chemistry/modal_aero/modal_aero_newnuc.F90 deleted file mode 100644 index d4007f476d..0000000000 --- a/src/chemistry/modal_aero/modal_aero_newnuc.F90 +++ /dev/null @@ -1,1631 +0,0 @@ -! modal_aero_newnuc.F90 - - -!---------------------------------------------------------------------- -!BOP -! -! !MODULE: modal_aero_newnuc --- modal aerosol new-particle nucleation -! -! !INTERFACE: -module modal_aero_newnuc - -! !USES: - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - save - -! !PUBLIC MEMBER FUNCTIONS: - public modal_aero_newnuc_run, modal_aero_newnuc_init - -! !PUBLIC DATA MEMBERS: -! species indices in the host constituent space, set by modal_aero_newnuc_init; -! default 0 = bypass (host found no h2so4 or no aitken so4/num species) - integer :: l_h2so4_sv = 0, l_nh3_sv = 0, lnumait_sv = 0, lnh4ait_sv = 0, lso4ait_sv = 0 - -! 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 - - real(r8) :: dens_so4a_host - real(r8) :: mw_nh4a_host, mw_so4a_host - -! aitken-mode geometry (nominal size + dry-diameter limits) from host mode metadata - real(r8) :: dgnum_aitken, dgnumhi_aitken, dgnumlo_aitken - -! host physical constants, set by modal_aero_newnuc_init (passed from the host -! rather than hardcoded so the values stay bit-identical with the host's) - real(r8) :: pi - real(r8) :: rgas ! gas constant (J/K/mol) - real(r8) :: avogad ! Avogadro's number (1/mol) - real(r8) :: mw_so4a ! molecular weight of sulfate (g/mol) - real(r8) :: mw_nh4a ! molecular weight of ammonium (g/mol) - real(r8) :: r_universal ! universal gas constant (J/K/kmol) - -! !DESCRIPTION: This module implements ... -! -! !REVISION HISTORY: -! -! R.Easter 2007.09.14: Adapted from MIRAGE2 code -! -!EOP -!---------------------------------------------------------------------- -!BOC - -! list private module data here - -!EOC -!---------------------------------------------------------------------- - - - contains - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -!BOP -! !ROUTINE: modal_aero_newnuc_run --- ... -! -! !INTERFACE: - subroutine modal_aero_newnuc_run( & - ncol, pver, top_lev, & - num_q, loffset, deltat, & - t, pmid, pdel, & - zm, pblh, & - qv, cld, & - q, gravit, & - del_h2so4_gasprod, del_h2so4_aeruptk, & - dqdt, dotend, qsrflx, & - errmsg, errflg ) - - -! !USES: - use wv_saturation, only: qsat - - implicit none - -! !PARAMETERS: - integer, intent(in) :: ncol ! number of columns in chunk - integer, intent(in) :: pver ! number of vertical levels - integer, intent(in) :: top_lev ! top level for modal aerosol calculations - integer, intent(in) :: num_q ! number of species in q/dqdt (= gas_pcnst) - integer, intent(in) :: loffset ! offset applied to modal aero "pointers" - real(r8), intent(in) :: deltat ! model timestep (s) - - real(r8), intent(in) :: t(:,:) ! (ncol,pver) temperature (K) - real(r8), intent(in) :: pmid(:,:) ! (ncol,pver) pressure at model levels (Pa) - real(r8), intent(in) :: pdel(:,:) ! (ncol,pver) pressure thickness of levels (Pa) - real(r8), intent(in) :: zm(:,:) ! (ncol,pver) midpoint height above surface (m) - real(r8), intent(in) :: pblh(:) ! (ncol) pbl height (m) - real(r8), intent(in) :: qv(:,:) ! (ncol,pver) specific humidity (kg/kg) - real(r8), intent(in) :: cld(:,:) ! (ncol,pver) stratiform cloud fraction - real(r8), intent(in) :: q(:,:,:) ! (ncol,pver,num_q) - ! tracer mixing ratio (TMR) array - ! *** MUST BE mol/mol-air or #/mol-air - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - real(r8), intent(in) :: del_h2so4_gasprod(:,:) - ! (ncol,pver) h2so4 gas-phase production - ! change over deltat (mol/mol) - real(r8), intent(in) :: del_h2so4_aeruptk(:,:) - ! (ncol,pver) h2so4 gas-phase loss to - ! aerosol over deltat (mol/mol) - real(r8), intent(out) :: dqdt(:,:,:) ! (ncol,pver,num_q) TMR tendency array - logical, intent(out) :: dotend(:) ! (num_q) flag for doing tendency - real(r8), intent(out) :: qsrflx(:,:,:) ! (ncol,num_q,1) - ! process-specific column tracer tendencies - ! 1 = nucleation (for aerocom) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! !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 -! -!EOP -!---------------------------------------------------------------------- -!BOC - -! local variables - integer :: i, itmp, k, lun - integer :: lnumait, lso4ait, lnh4ait - integer :: l_h2so4, l_nh3 - integer :: ldiagveh02 - 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 - - real(r8) :: adjust_factor - real(r8) :: aircon - real(r8) :: cldx - 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) :: dndt(ncol,pver) ! nucleation rate (#/m3/s) - real(r8) :: dnh4dt_ait, dso4dt_ait - real(r8) :: dpnuc - real(r8) :: dplom_mode(1), dphim_mode(1) - real(r8) :: ev_sat(ncol,pver) - real(r8) :: mass1p - real(r8) :: mass1p_aithi, mass1p_aitlo - real(r8) :: pdel_fac - 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) :: qv_sat(ncol,pver) - real(r8) :: qvswtr - real(r8) :: relhum, relhumav, relhumnn - real(r8) :: tmpa, tmpb, tmpc - real(r8) :: tmp_q1, tmp_q2, tmp_q3 - real(r8) :: tmp_frso4, tmp_uptkrate - - logical :: do_nh3 ! flag for doing nh3/nh4 - - - character(len=1) :: tmpch1, tmpch2, tmpch3 - - -! begin - errmsg = ' ' - errflg = 0 - - lun = 6 - -!-------------------------------------------------------------------------------- -!!$ if (ldiag1 > 0) then -!!$ do i = 1, ncol -!!$ if (lonndx(i) /= 37) cycle -!!$ if (latndx(i) /= 23) cycle -!!$ if (nstep > 3) cycle -!!$ write( lun, '(/a,i7,3i5,f10.2)' ) & -!!$ '*** modal_aero_newnuc_sub -- nstep, iam, lat, lon =', & -!!$ nstep, iam, latndx(i), lonndx(i) -!!$ end do -!!$ if (nstep > 3) call endrun( '*** modal_aero_newnuc_sub -- testing halt after step 3' ) -!!$! if (ncol /= -999888777) return -!!$ end if -!-------------------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! zero the tendency outputs up front: they are intent(out) and the caller -! applies/outputs them unconditionally, including on the bypass path below - dotend(:) = .false. - dqdt(1:ncol,:,:) = 0.0_r8 - qsrflx(1:ncol,:,:) = 0.0_r8 - dndt(1:ncol,:) = 0.0_r8 - - l_h2so4 = l_h2so4_sv - loffset - l_nh3 = l_nh3_sv - loffset - lnumait = lnumait_sv - loffset - lnh4ait = lnh4ait_sv - loffset - lso4ait = lso4ait_sv - loffset - -! skip if no aitken mode OR if no h2so4 species - if ((l_h2so4 <= 0) .or. (lso4ait <= 0) .or. (lnumait <= 0)) return - -! set dotend - dotend(lnumait) = .true. - dotend(lso4ait) = .true. - dotend(l_h2so4) = .true. - - if ((l_nh3 > 0) .and. (l_nh3 <= num_q) .and. & - (lnh4ait > 0) .and. (lnh4ait <= num_q)) then - do_nh3 = .true. - dotend(lnh4ait) = .true. - dotend(l_nh3) = .true. - else - do_nh3 = .false. - end if - - -! dry-diameter limits for "grown" new particles - dplom_mode(1) = exp( 0.67_r8*log(dgnumlo_aitken) & - + 0.33_r8*log(dgnum_aitken) ) - dphim_mode(1) = dgnumhi_aitken - -! 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) - -! compute qv_sat = saturation specific humidity - do k = 1, pver - call qsat(t(1:ncol,k), pmid(1:ncol,k), ev_sat(1:ncol,k), qv_sat(1:ncol,k), ncol) - end do -! -! loop over levels and columns to calc the renaming -! -main_k: do k = top_lev, pver -main_i: do i = 1, ncol - -! skip if completely cloudy, -! because all h2so4 vapor should be cloud-borne - if (cld(i,k) >= 0.99_r8) 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 - - tmpa = max( 0.0_r8, del_h2so4_gasprod(i,k) ) - 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(i,k) ) - -! *** temporary -- in order to get more nucleation -! qh2so4_cur = qh2so4_cur*1.0e1 -! tmp_q3 = tmp_q3*1.0e1 -! tmp_q2 = tmp_q2*1.0e1 -! tmpa = tmpa *1.0e1 - -! tmpb = log( tmp_q2/tmp_q3 ) BUT with some checks added -! tmp_uptkrate = tmpb/deltat - 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 - if (qh2so4_avg <= qh2so4_cutoff) cycle main_i - - - if ( do_nh3 ) then - qnh3_cur = max( 0.0_r8, q(i,k,l_nh3) ) - else - qnh3_cur = 0.0_r8 - end if - - -! relhumav = grid average RH - qvswtr = qv_sat(i,k) - 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 - 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 ) ) -! limit RH to between 0.1% and 99% - relhumnn = relhum - relhumnn = max( 0.01_r8, min( 0.99_r8, relhumnn ) ) - -! aircon = air concentration (mol-air/m3) - aircon = 1.0e3_r8*pmid(i,k)/(r_universal*t(i,k)) - - -! call ... routine to get nucleation rates - ldiagveh02 = -1 -!!$ if (ldiag2 > 0) then -!!$ if ((lonndx(i) == 37) .and. (latndx(i) == 23)) then -!!$ if ((k >= 24) .or. (mod(k,4) == 0)) then -!!$ ldiagveh02 = +1 -!!$ write(lun,'(/a,i8,3i4,f8.2,1p,4e10.2)') & -!!$ 'veh02 call - nstep,lat,lon,k; tk,rh,p,cair', & -!!$ nstep, latndx(i), lonndx(i), k, & -!!$ t(i,k), relhumnn, pmid(k,k), aircon -!!$ end if -!!$ end if -!!$ end if - call mer07_veh02_nuc_mosaic_1box( & - newnuc_method_flagaa, & - deltat, t(i,k), relhumnn, pmid(i,k), & - zm(i,k), pblh(i), & - 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 ) -! qh2so4_del, qnh3_del, dens_nh4so4a ) -!---------------------------------------------------------------------- -! 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 -! 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 - tmpb = tmpa + qnh4a_del*mw_nh4a_host - tmp_frso4 = max( tmpa, 1.0e-35_r8 )/max( tmpb, 1.0e-35_r8 ) -! mass nuc rate (kg/kmol-air/s or g/mol...) hhfrom mass nuc amts - dmdt_ait = max( 0.0_r8, (tmpb/deltat) ) - - dndt_aitsv1 = dndt_ait - dmdt_aitsv1 = dmdt_ait - dndt_aitsv2 = 0.0_r8 - dmdt_aitsv2 = 0.0_r8 - dndt_aitsv3 = 0.0_r8 - dmdt_aitsv3 = 0.0_r8 - tmpch1 = ' ' - tmpch2 = ' ' - - if (dndt_ait < 1.0e2_r8) then -! ignore newnuc if number rate < 100 #/kmol-air/s ~= 0.3 #/mg-air/d - dndt_ait = 0.0_r8 - dmdt_ait = 0.0_r8 - 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 -! adjust_factor = 0.5 -! dndt_ait = dndt_ait * adjust_factor -! dmdt_ait = dmdt_ait * adjust_factor - -! set tendencies - pdel_fac = pdel(i,k)/gravit - -! 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 - -! dqdt tendencies are returned to the caller, which applies q = q + dqdt*deltat - dqdt(i,k,l_h2so4) = -dso4dt_ait*(1.0_r8-cldx) - qsrflx(i,l_h2so4,1) = qsrflx(i,l_h2so4,1) + dqdt(i,k,l_h2so4)*pdel_fac - - dqdt(i,k,lso4ait) = dso4dt_ait*(1.0_r8-cldx) - qsrflx(i,lso4ait,1) = qsrflx(i,lso4ait,1) + dqdt(i,k,lso4ait)*pdel_fac - if (lnumait > 0) then - dqdt(i,k,lnumait) = dndt_ait*(1.0_r8-cldx) -! dndt is (#/m3/s), dqdt(:,:,lnumait) is (#/kmol-air/s), aircon is (mol-air/m3) - dndt(i,k) = dqdt(i,k,lnumait)*aircon*1.0e-3_r8 - qsrflx(i,lnumait,1) = qsrflx(i,lnumait,1) & - + dqdt(i,k,lnumait)*pdel_fac - end if - - if (( do_nh3 ) .and. (dnh4dt_ait > 0.0_r8)) then - dqdt(i,k,l_nh3) = -dnh4dt_ait*(1.0_r8-cldx) - qsrflx(i,l_nh3,1) = qsrflx(i,l_nh3,1) + dqdt(i,k,l_nh3)*pdel_fac - - dqdt(i,k,lnh4ait) = dnh4dt_ait*(1.0_r8-cldx) - qsrflx(i,lnh4ait,1) = qsrflx(i,lnh4ait,1) + dqdt(i,k,lnh4ait)*pdel_fac - end if - -!! temporary diagnostic -! if (ldiag3 > 0) then -! if ((dndt_ait /= 0.0_r8) .or. (dmdt_ait /= 0.0_r8)) then -! write(lun,'(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 - - -! diagnostic output start ---------------------------------------- -!!$ if (ldiag4 > 0) then -!!$ if ((lonndx(i) == 37) .and. (latndx(i) == 23)) then -!!$ if ((k >= 24) .or. (mod(k,4) == 0)) then -!!$ write(lun,97010) nstep, latndx(i), lonndx(i), k, t(i,k), aircon -!!$ write(lun,97020) 'pmid, pdel ', & -!!$ pmid(i,k), pdel(i,k) -!!$ write(lun,97030) 'qv,qvsw, cld, rh_av, rh_clr ', & -!!$ qv(i,k), qvswtr, cldx, relhumav, relhum -!!$ write(lun,97020) 'h2so4_cur, _pre, _av, nh3_cur', & -!!$ qh2so4_cur, tmp_q2, qh2so4_avg, qnh3_cur -!!$ write(lun,97020) 'del_h2so4_gasprod, _aeruptk ', & -!!$ del_h2so4_gasprod(i,k), del_h2so4_aeruptk(i,k), & -!!$ tmp_uptkrate*3600.0_r8 -!!$ write(lun,97020) ' ' -!!$ write(lun,97050) 'tmpch1, tmpch2 ', tmpch1, tmpch2 -!!$ write(lun,97020) 'dndt_, dmdt_aitsv1 ', & -!!$ dndt_aitsv1, dmdt_aitsv1 -!!$ write(lun,97020) 'dndt_, dmdt_aitsv2 ', & -!!$ dndt_aitsv2, dmdt_aitsv2 -!!$ write(lun,97020) 'dndt_, dmdt_aitsv3 ', & -!!$ dndt_aitsv3, dmdt_aitsv3 -!!$ write(lun,97020) 'dndt_, dmdt_ait ', & -!!$ dndt_ait, dmdt_ait -!!$ write(lun,97020) 'dso4dt_, dnh4dt_ait ', & -!!$ dso4dt_ait, dnh4dt_ait -!!$ write(lun,97020) 'qso4a_del, qh2so4_del ', & -!!$ qso4a_del, qh2so4_del -!!$ write(lun,97020) 'qnh4a_del, qnh3_del ', & -!!$ qnh4a_del, qnh3_del -!!$ write(lun,97020) 'dqdt(h2so4), (nh3) ', & -!!$ dqdt(i,k,l_h2so4), dqdt(i,k,l_nh3) -!!$ write(lun,97020) 'dqdt(so4a), (nh4a), (numa) ', & -!!$ dqdt(i,k,lso4ait), dqdt(i,k,lnh4ait), dqdt(i,k,lnumait) -!!$ -!!$ dpnuc = 0.0_r8 -!!$ if (dndt_aitsv1 > 1.0e-5_r8) dpnuc = (6.0_r8*dmdt_aitsv1/ & -!!$ (pi*dens_so4a_host*dndt_aitsv1))**0.3333333_r8 -!!$ if (dpnuc > 0.0_r8) then -!!$ write(lun,97020) 'dpnuc, dp_aitlo, _aithi ', & -!!$ dpnuc, dplom_mode(1), dphim_mode(1) -!!$ write(lun,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 -!!$ end if -!!$ end if -! diagnostic output end ------------------------------------------ - - - end do main_i - end do main_k - - -! history file column-tendency fields (adv_mass/mwdry scaling + outfld of -! qsrflx) are done by the caller, which owns the host constituent metadata - - - return -!EOC - end subroutine modal_aero_newnuc_run - - - -!---------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine mer07_veh02_nuc_mosaic_1box( & - newnuc_method_flagaa, dtnuc, temp_in, rh_in, press_in, & - zm_in, pblh_in, & - qh2so4_cur, qh2so4_avg, qnh3_cur, h2so4_uptkrate, & - 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 ) -! (rgas, avogad, mw_so4a, mw_nh4a are module-level host constants -! set by modal_aero_newnuc_init) -!....................................................................... -! -! calculates new particle production from homogeneous nucleation -! over timestep dtnuc, using nucleation rates from either -! merikanto et al. (2007) h2so4-nh3-h2o ternary parameterization -! vehkamaki et al. (2002) h2so4-h2o binary parameterization -! -! the new particles are "grown" to the lower-bound size of the host code's -! smallest size bin. (this "growth" is somewhat ad hoc, and would not be -! necessary if the host code's size bins extend down to ~1 nm.) -! -! if the h2so4 and nh3 mass mixing ratios (mixrats) of the grown new -! particles exceed the current gas mixrats, the new particle production -! is reduced so that the new particle mass mixrats match the gas mixrats. -! -! the correction of kerminen and kulmala (2002) is applied to account -! for loss of the new particles by coagulation as they are -! growing to the "host code mininum size" -! -! revision history -! coded by rc easter, pnnl, xx-apr-2007 -! -! key routines called: subr ternary_nuc_napari -! -! references: -! merikanto, j., i. napari, h. vehkamaki, t. anttila, -! and m. kulmala, 2007, new parameterization of -! sulfuric acid-ammonia-water ternary nucleation -! rates at tropospheric conditions, -! j. geophys. res., 112, d15207, doi:10.1029/2006jd0027977 -! -! vehkamäki, h., m. kulmala, i. napari, k.e.j. lehtinen, -! c. timmreck, m. noppel and a. laaksonen, 2002, -! an improved parameterization for sulfuric acid-water nucleation -! rates for tropospheric and stratospheric conditions, -! j. geophys. res., 107, 4622, doi:10.1029/2002jd002184 -! -! kerminen, v., and m. kulmala, 2002, -! analytical formulae connecting the "real" and the "apparent" -! nucleation rate and the nuclei number concentration -! for atmospheric nucleation events -! -!....................................................................... - implicit none - -! 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) :: zm_in ! layer midpoint height (m) - real(r8), intent(in) :: pblh_in ! pbl height (m) - - 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) - real(r8), intent(in) :: mw_so4a_host ! mw of so4 aerosol in host code (g/mol) - - integer, intent(in) :: newnuc_method_flagaa ! 1=merikanto et al (2007) ternary - ! 2=vehkamaki et al (2002) binary - 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) - integer, intent(in) :: ldiagaa - -! 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) - -! subr arguments (out) passed via common block -! these are used to duplicate the outputs of yang zhang's original test driver -! they are not really needed in wrf-chem - real(r8) :: ratenuclt ! j = ternary nucleation rate from napari param. (cm-3 s-1) - real(r8) :: rateloge ! ln (j) - real(r8) :: cnum_h2so4 ! number of h2so4 molecules in the critical nucleus - real(r8) :: cnum_nh3 ! number of nh3 molecules in the critical nucleus - real(r8) :: cnum_tot ! total number of molecules in the critical nucleus - real(r8) :: radius_cluster ! the radius of cluster (nm) - - -! local variables - integer :: i - integer :: igrow - integer, save :: icase = 0, icase_reldiffmax = 0 -! integer, parameter :: ldiagaa = -1 - integer :: lun - integer :: newnuc_method_flagaa2 - - real(r8), parameter :: onethird = 1.0_r8/3.0_r8 - - real(r8), parameter :: accom_coef_h2so4 = 0.65_r8 ! accomodation coef for h2so4 conden - -! dry densities (kg/m3) molecular weights of aerosol -! ammsulf, ammbisulf, and sulfacid (from mosaic dens_electrolyte values) -! real(r8), parameter :: dens_ammsulf = 1.769e3 -! real(r8), parameter :: dens_ammbisulf = 1.78e3 -! real(r8), parameter :: dens_sulfacid = 1.841e3 -! use following to match cam3 modal_aero densities - real(r8), parameter :: dens_ammsulf = 1.770e3_r8 - real(r8), parameter :: dens_ammbisulf = 1.770e3_r8 - real(r8), parameter :: dens_sulfacid = 1.770e3_r8 - -! molecular weights (g/mol) of aerosol ammsulf, ammbisulf, and sulfacid -! for ammbisulf and sulfacid, use 114 & 96 here rather than 115 & 98 -! because we don't keep track of aerosol hion mass - real(r8), parameter :: mw_ammsulf = 132.0_r8 - real(r8), parameter :: mw_ammbisulf = 114.0_r8 - real(r8), parameter :: mw_sulfacid = 96.0_r8 - - real(r8), save :: reldiffmax = 0.0_r8 - - real(r8) cair ! dry-air molar density (mol/m3) - real(r8) cs_prime_kk ! kk2002 "cs_prime" parameter (1/m2) - real(r8) cs_kk ! kk2002 "cs" parameter (1/s) - real(r8) dens_part ! "grown" single-particle dry density (kg/m3) - real(r8) dfin_kk, dnuc_kk ! kk2002 final/initial new particle wet diameter (nm) - real(r8) dpdry_clus ! critical cluster diameter (m) - real(r8) dpdry_part ! "grown" single-particle dry diameter (m) - real(r8) tmpa, tmpb, tmpc, tmpe, tmpq - real(r8) tmpa1, tmpb1 - real(r8) tmp_m1, tmp_m2, tmp_m3, tmp_n1, tmp_n2, tmp_n3 - real(r8) tmp_spd ! h2so4 vapor molecular speed (m/s) - real(r8) factor_kk - real(r8) fogas, foso4a, fonh4a, fonuma - real(r8) freduce ! reduction factor applied to nucleation rate - ! due to limited availability of h2so4 & nh3 gases - real(r8) freducea, freduceb - real(r8) gamma_kk ! kk2002 "gamma" parameter (nm2*m2/h) - real(r8) gr_kk ! kk2002 "gr" parameter (nm/h) - real(r8) kgaero_per_moleso4a ! (kg dry aerosol)/(mol aerosol so4) - real(r8) mass_part ! "grown" single-particle dry mass (kg) - real(r8) molenh4a_per_moleso4a ! (mol aerosol nh4)/(mol aerosol so4) - real(r8) nh3ppt, nh3ppt_bb ! actual and bounded nh3 (ppt) - real(r8) nu_kk ! kk2002 "nu" parameter (nm) - real(r8) qmolnh4a_del_max ! max production of aerosol nh4 over dtnuc (mol/mol-air) - real(r8) qmolso4a_del_max ! max production of aerosol so4 over dtnuc (mol/mol-air) - real(r8) ratenuclt_bb ! nucleation rate (#/m3/s) - real(r8) ratenuclt_kk ! nucleation rate after kk2002 adjustment (#/m3/s) - real(r8) rh_bb ! bounded value of rh_in - real(r8) so4vol_in ! concentration of h2so4 for nucl. calc., molecules cm-3 - real(r8) so4vol_bb ! bounded value of so4vol_in - real(r8) temp_bb ! bounded value of temp_in - real(r8) voldry_clus ! critical-cluster dry volume (m3) - real(r8) voldry_part ! "grown" single-particle dry volume (m3) - real(r8) wetvol_dryvol ! grown particle (wet-volume)/(dry-volume) - real(r8) wet_volfrac_so4a ! grown particle (dry-volume-from-so4)/(wet-volume) - - - -! -! if h2so4 vapor < qh2so4_cutoff -! exit with new particle formation = 0 -! - isize_nuc = 1 - qnuma_del = 0.0_r8 - qso4a_del = 0.0_r8 - qnh4a_del = 0.0_r8 - qh2so4_del = 0.0_r8 - qnh3_del = 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 - - if ((newnuc_method_flagaa /= 1) .and. & - (newnuc_method_flagaa /= 2) .and. & - (newnuc_method_flagaa /= 11) .and. & - (newnuc_method_flagaa /= 12)) return - - -! -! make call to parameterization routine -! - -! calc h2so4 in molecules/cm3 and nh3 in ppt - cair = press_in/(temp_in*rgas) - so4vol_in = qh2so4_avg * cair * avogad * 1.0e-6_r8 - nh3ppt = qnh3_cur * 1.0e12_r8 - ratenuclt = 1.0e-38_r8 - rateloge = log( ratenuclt ) - - if ( (newnuc_method_flagaa /= 2) .and. & - (nh3ppt >= 0.1_r8) ) then -! make call to merikanto ternary parameterization routine -! (when nh3ppt < 0.1, use binary param instead) - - if (so4vol_in >= 5.0e4_r8) then - temp_bb = max( 235.0_r8, min( 295.0_r8, temp_in ) ) - rh_bb = max( 0.05_r8, min( 0.95_r8, rh_in ) ) - so4vol_bb = max( 5.0e4_r8, min( 1.0e9_r8, so4vol_in ) ) - nh3ppt_bb = max( 0.1_r8, min( 1.0e3_r8, nh3ppt ) ) - call ternary_nuc_merik2007( & - temp_bb, rh_bb, so4vol_bb, nh3ppt_bb, & - rateloge, & - cnum_tot, cnum_h2so4, cnum_nh3, radius_cluster ) - end if - newnuc_method_flagaa2 = 1 - - else -! make call to vehkamaki binary parameterization routine - - if (so4vol_in >= 1.0e4_r8) then - temp_bb = max( 230.15_r8, min( 305.15_r8, temp_in ) ) - rh_bb = max( 1.0e-4_r8, min( 1.0_r8, rh_in ) ) - so4vol_bb = max( 1.0e4_r8, min( 1.0e11_r8, so4vol_in ) ) - call binary_nuc_vehk2002( & - temp_bb, rh_bb, so4vol_bb, & - ratenuclt, rateloge, & - cnum_h2so4, cnum_tot, radius_cluster ) - end if - cnum_nh3 = 0.0_r8 - newnuc_method_flagaa2 = 2 - - end if - - -! do boundary layer nuc - if ((newnuc_method_flagaa == 11) .or. & - (newnuc_method_flagaa == 12)) then - if ( zm_in <= max(pblh_in,100.0_r8) ) then - so4vol_bb = so4vol_in - call pbl_nuc_wang2008( so4vol_bb, & - newnuc_method_flagaa, newnuc_method_flagaa2, & - ratenuclt, rateloge, & - cnum_tot, cnum_h2so4, cnum_nh3, radius_cluster ) - end if - end if - - -! if nucleation rate is less than 1e-6 #/m3/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 - - -! wet/dry volume ratio - use simple kohler approx for ammsulf/ammbisulf - tmpa = max( 0.10_r8, min( 0.95_r8, rh_in ) ) - wetvol_dryvol = 1.0_r8 - 0.56_r8/log(tmpa) - - -! determine size bin into which the new particles go -! (probably it will always be bin #1, but ...) - voldry_clus = ( max(cnum_h2so4,1.0_r8)*mw_so4a + cnum_nh3*mw_nh4a ) / & - (1.0e3_r8*dens_sulfacid*avogad) -! correction when host code sulfate is really ammonium bisulfate/sulfate - voldry_clus = voldry_clus * (mw_so4a_host/mw_so4a) - dpdry_clus = (voldry_clus*6.0_r8/pi)**onethird - - isize_nuc = 1 - dpdry_part = dplom_sect(1) - if (dpdry_clus <= dplom_sect(1)) then - igrow = 1 ! need to clusters to larger size - else if (dpdry_clus >= dphim_sect(nsize)) then - igrow = 0 - isize_nuc = nsize - dpdry_part = dphim_sect(nsize) - else - igrow = 0 - do i = 1, nsize - if (dpdry_clus < dphim_sect(i)) then - isize_nuc = i - dpdry_part = dpdry_clus - dpdry_part = min( dpdry_part, dphim_sect(i) ) - dpdry_part = max( dpdry_part, dplom_sect(i) ) - exit - end if - end do - end if - voldry_part = (pi/6.0_r8)*(dpdry_part**3) - - -! -! determine composition and density of the "grown particles" -! the grown particles are assumed to be liquid -! (since critical clusters contain water) -! so any (nh4/so4) molar ratio between 0 and 2 is allowed -! assume that the grown particles will have -! (nh4/so4 molar ratio) = min( 2, (nh3/h2so4 gas molar ratio) ) -! - if (igrow .le. 0) then -! no "growing" so pure sulfuric acid - tmp_n1 = 0.0_r8 - tmp_n2 = 0.0_r8 - tmp_n3 = 1.0_r8 - else if (qnh3_cur .ge. qh2so4_cur) then -! combination of ammonium sulfate and ammonium bisulfate -! tmp_n1 & tmp_n2 = mole fractions of the ammsulf & ammbisulf - tmp_n1 = (qnh3_cur/qh2so4_cur) - 1.0_r8 - tmp_n1 = max( 0.0_r8, min( 1.0_r8, tmp_n1 ) ) - tmp_n2 = 1.0_r8 - tmp_n1 - tmp_n3 = 0.0_r8 - else -! combination of ammonium bisulfate and sulfuric acid -! tmp_n2 & tmp_n3 = mole fractions of the ammbisulf & sulfacid - tmp_n1 = 0.0_r8 - tmp_n2 = (qnh3_cur/qh2so4_cur) - tmp_n2 = max( 0.0_r8, min( 1.0_r8, tmp_n2 ) ) - tmp_n3 = 1.0_r8 - tmp_n2 - end if - - tmp_m1 = tmp_n1*mw_ammsulf - tmp_m2 = tmp_n2*mw_ammbisulf - tmp_m3 = tmp_n3*mw_sulfacid - dens_part = (tmp_m1 + tmp_m2 + tmp_m3)/ & - ((tmp_m1/dens_ammsulf) + (tmp_m2/dens_ammbisulf) & - + (tmp_m3/dens_sulfacid)) - dens_nh4so4a = dens_part - mass_part = voldry_part*dens_part -! (mol aerosol nh4)/(mol aerosol so4) - molenh4a_per_moleso4a = 2.0_r8*tmp_n1 + tmp_n2 -! (kg dry aerosol)/(mol aerosol so4) - kgaero_per_moleso4a = 1.0e-3_r8*(tmp_m1 + tmp_m2 + tmp_m3) -! correction when host code sulfate is really ammonium bisulfate/sulfate - kgaero_per_moleso4a = kgaero_per_moleso4a * (mw_so4a_host/mw_so4a) - -! fraction of wet volume due to so4a - tmpb = 1.0_r8 + molenh4a_per_moleso4a*17.0_r8/98.0_r8 - wet_volfrac_so4a = 1.0_r8 / ( wetvol_dryvol * tmpb ) - - -! -! calc kerminen & kulmala (2002) correction -! - if (igrow <= 0) then - factor_kk = 1.0_r8 - - else -! "gr" parameter (nm/h) = condensation growth rate of new particles -! use kk2002 eqn 21 for h2so4 uptake, and correct for nh3 & h2o uptake - tmp_spd = 14.7_r8*sqrt(temp_in) ! h2so4 molecular speed (m/s) - gr_kk = 3.0e-9_r8*tmp_spd*mw_sulfacid*so4vol_in/ & - (dens_part*wet_volfrac_so4a) - -! "gamma" parameter (nm2/m2/h) -! use kk2002 eqn 22 -! -! dfin_kk = wet diam (nm) of grown particle having dry dia = dpdry_part (m) - dfin_kk = 1.0e9_r8 * dpdry_part * (wetvol_dryvol**onethird) -! dnuc_kk = wet diam (nm) of cluster - dnuc_kk = 2.0_r8*radius_cluster - dnuc_kk = max( dnuc_kk, 1.0_r8 ) -! neglect (dmean/150)**0.048 factor, -! which should be very close to 1.0 because of small exponent - gamma_kk = 0.23_r8 * (dnuc_kk)**0.2_r8 & - * (dfin_kk/3.0_r8)**0.075_r8 & - * (dens_part*1.0e-3_r8)**(-0.33_r8) & - * (temp_in/293.0_r8)**(-0.75_r8) - -! "cs_prime parameter" (1/m2) -! instead kk2002 eqn 3, use -! cs_prime ~= tmpa / (4*pi*tmpb * h2so4_accom_coef) -! where -! tmpa = -d(ln(h2so4))/dt by conden to particles (1/h units) -! tmpb = h2so4 vapor diffusivity (m2/h units) -! this approx is generally within a few percent of the cs_prime -! calculated directly from eqn 2, -! which is acceptable, given overall uncertainties -! tmpa = -d(ln(h2so4))/dt by conden to particles (1/h units) - tmpa = h2so4_uptkrate * 3600.0_r8 - tmpa1 = tmpa - tmpa = max( tmpa, 0.0_r8 ) -! tmpb = h2so4 gas diffusivity (m2/s, then m2/h) - tmpb = 6.7037e-6_r8 * (temp_in**0.75_r8) / cair - tmpb1 = tmpb ! m2/s - tmpb = tmpb*3600.0_r8 ! m2/h - cs_prime_kk = tmpa/(4.0_r8*pi*tmpb*accom_coef_h2so4) - cs_kk = cs_prime_kk*4.0_r8*pi*tmpb1 - -! "nu" parameter (nm) -- kk2002 eqn 11 - nu_kk = gamma_kk*cs_prime_kk/gr_kk -! nucleation rate adjustment factor (--) -- kk2002 eqn 13 - factor_kk = exp( (nu_kk/dfin_kk) - (nu_kk/dnuc_kk) ) - - end if - ratenuclt_kk = ratenuclt_bb*factor_kk - - -! max production of aerosol dry mass (kg-aero/m3-air) - tmpa = max( 0.0_r8, (ratenuclt_kk*dtnuc*mass_part) ) -! max production of aerosol so4 (mol-so4a/mol-air) - tmpe = tmpa/(kgaero_per_moleso4a*cair) -! max production of aerosol so4 (mol/mol-air) -! based on ratenuclt_kk and mass_part - qmolso4a_del_max = tmpe - -! check if max production exceeds available h2so4 vapor - freducea = 1.0_r8 - if (qmolso4a_del_max .gt. qh2so4_cur) then - freducea = qh2so4_cur/qmolso4a_del_max - end if - -! check if max production exceeds available nh3 vapor - freduceb = 1.0_r8 - if (molenh4a_per_moleso4a .ge. 1.0e-10_r8) then -! max production of aerosol nh4 (ppm) based on ratenuclt_kk and mass_part - qmolnh4a_del_max = qmolso4a_del_max*molenh4a_per_moleso4a - if (qmolnh4a_del_max .gt. qnh3_cur) then - freduceb = qnh3_cur/qmolnh4a_del_max - end if - end if - freduce = min( freducea, freduceb ) - -! if adjusted nucleation rate is less than 1e-12 #/m3/s ~= 0.1 #/cm3/day, -! exit with new particle formation = 0 - if (freduce*ratenuclt_kk .le. 1.0e-12_r8) return - - -! note: suppose that at this point, freduce < 1.0 (no gas-available -! constraints) and molenh4a_per_moleso4a < 2.0 -! if the gas-available constraints is do to h2so4 availability, -! then it would be possible to condense "additional" nh3 and have -! (nh3/h2so4 gas molar ratio) < (nh4/so4 aerosol molar ratio) <= 2 -! one could do some additional calculations of -! dens_part & molenh4a_per_moleso4a to realize this -! however, the particle "growing" is a crude approximate way to get -! the new particles to the host code's minimum particle size, -! are such refinements worth the effort? - - -! changes to h2so4 & nh3 gas (in mol/mol-air), limited by amounts available - tmpa = 0.9999_r8 - qh2so4_del = min( tmpa*qh2so4_cur, freduce*qmolso4a_del_max ) - qnh3_del = min( tmpa*qnh3_cur, qh2so4_del*molenh4a_per_moleso4a ) - qh2so4_del = -qh2so4_del - qnh3_del = -qnh3_del - -! changes to so4 & nh4 aerosol (in mol/mol-air) - qso4a_del = -qh2so4_del - qnh4a_del = -qnh3_del -! change to aerosol number (in #/mol-air) - qnuma_del = 1.0e-3_r8*(qso4a_del*mw_so4a + qnh4a_del*mw_nh4a)/mass_part - -! do the following (tmpa, tmpb, tmpc) calculations as a check -! max production of aerosol number (#/mol-air) - tmpa = max( 0.0_r8, (ratenuclt_kk*dtnuc/cair) ) -! adjusted production of aerosol number (#/mol-air) - tmpb = tmpa*freduce -! relative difference from qnuma_del - tmpc = (tmpb - qnuma_del)/max(tmpb, qnuma_del, 1.0e-35_r8) - - -! -! diagnostic output to fort.41 -! (this should be commented-out or deleted in the wrf-chem version) -! - if (ldiagaa <= 0) return - - icase = icase + 1 - if (abs(tmpc) .gt. abs(reldiffmax)) then - reldiffmax = tmpc - icase_reldiffmax = icase - end if -! do lun = 41, 51, 10 - do lun = 6, 6 -! write(lun,'(/)') - write(lun,'(a,2i9,1p,e10.2)') & - 'vehkam bin-nuc icase, icase_rdmax =', & - icase, icase_reldiffmax, reldiffmax - if (freduceb .lt. freducea) then - if (abs(freducea-freduceb) .gt. & - 3.0e-7_r8*max(freduceb,freducea)) write(lun,'(a,1p,2e15.7)') & - 'freducea, b =', freducea, freduceb - end if - end do - -! output factors so that output matches that of ternucl03 -! fogas = 1.0e6 ! convert mol/mol-air to ppm -! foso4a = 1.0e9*mw_so4a/mw_air ! convert mol-so4a/mol-air to ug/kg-air -! fonh4a = 1.0e9*mw_nh4a/mw_air ! convert mol-nh4a/mol-air to ug/kg-air -! fonuma = 1.0e3/mw_air ! convert #/mol-air to #/kg-air - fogas = 1.0_r8 - foso4a = 1.0_r8 - fonh4a = 1.0_r8 - fonuma = 1.0_r8 - -! do lun = 41, 51, 10 - do lun = 6, 6 - - write(lun,'(a,2i5)') 'newnuc_method_flagaa/aa2', & - newnuc_method_flagaa, newnuc_method_flagaa2 - - write(lun,9210) - write(lun,9201) temp_in, rh_in, & - ratenuclt, 2.0_r8*radius_cluster*1.0e-7_r8, dpdry_part*1.0e2_r8, & - voldry_part*1.0e6_r8, float(igrow) - write(lun,9215) - write(lun,9201) & - qh2so4_avg*fogas, 0.0_r8, & - qh2so4_cur*fogas, qnh3_cur*fogas, & - qh2so4_del*fogas, qnh3_del*fogas, & - qso4a_del*foso4a, qnh4a_del*fonh4a - - write(lun,9220) - write(lun,9201) & - dtnuc, dens_nh4so4a*1.0e-3_r8, & - (qnh3_cur/qh2so4_cur), molenh4a_per_moleso4a, & - qnuma_del*fonuma, tmpb*fonuma, tmpc, freduce - - end do - -! lun = 51 - lun = 6 - write(lun,9230) - write(lun,9201) & - press_in, cair*1.0e-6_r8, so4vol_in, & - wet_volfrac_so4a, wetvol_dryvol, dens_part*1.0e-3_r8 - - if (igrow > 0) then - write(lun,9240) - write(lun,9201) & - tmp_spd, gr_kk, dnuc_kk, dfin_kk, & - gamma_kk, tmpa1, tmpb1, cs_kk - - write(lun,9250) - write(lun,9201) & - cs_prime_kk, nu_kk, factor_kk, ratenuclt, & - ratenuclt_kk*1.0e-6_r8 - end if - -9201 format ( 1p, 40e10.2 ) -9210 format ( & - ' temp rh', & - ' ratenuc dia_clus ddry_part', & - ' vdry_part igrow' ) -9215 format ( & - ' h2so4avg h2so4pre', & - ' h2so4cur nh3_cur', & - ' h2so4del nh3_del', & - ' so4a_del nh4a_del' ) -9220 format ( & - ' dtnuc dens_a nh/so g nh/so a', & - ' numa_del numa_dl2 reldiff freduce' ) -9230 format ( & - ' press_in cair so4_volin', & - ' wet_volfr wetv_dryv dens_part' ) -9240 format ( & - ' tmp_spd gr_kk dnuc_kk dfin_kk', & - ' gamma_kk tmpa1 tmpb1 cs_kk' ) -9250 format ( & - ' cs_pri_kk nu_kk factor_kk ratenuclt', & - ' ratenu_kk' ) - - - return - end subroutine mer07_veh02_nuc_mosaic_1box - - - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine pbl_nuc_wang2008( so4vol, & - newnuc_method_flagaa, newnuc_method_flagaa2, & - ratenucl, rateloge, & - cnum_tot, cnum_h2so4, cnum_nh3, radius_cluster ) -! -! calculates boundary nucleation nucleation rate -! using the first or second-order parameterization in -! wang, m., and j.e. penner, 2008, -! aerosol indirect forcing in a global model with particle nucleation, -! atmos. chem. phys. discuss., 8, 13943-13998 -! - implicit none - -! subr arguments (in) - real(r8), intent(in) :: so4vol ! concentration of h2so4 (molecules cm-3) - integer, intent(in) :: newnuc_method_flagaa - ! [11,12] value selects [first,second]-order parameterization - -! subr arguments (inout) - integer, intent(inout) :: newnuc_method_flagaa2 - real(r8), intent(inout) :: ratenucl ! binary nucleation rate, j (# cm-3 s-1) - real(r8), intent(inout) :: rateloge ! log( ratenucl ) - - real(r8), intent(inout) :: cnum_tot ! total number of molecules - ! in the critical nucleus - real(r8), intent(inout) :: cnum_h2so4 ! number of h2so4 molecules - real(r8), intent(inout) :: cnum_nh3 ! number of nh3 molecules - real(r8), intent(inout) :: radius_cluster ! the radius of cluster (nm) - - -! local variables - real(r8) :: tmp_diam, tmp_mass, tmp_volu - real(r8) :: tmp_rateloge, tmp_ratenucl - -! executable - - -! nucleation rate - if (newnuc_method_flagaa == 11) then - tmp_ratenucl = 1.0e-6_r8 * so4vol - else if (newnuc_method_flagaa == 12) then - tmp_ratenucl = 1.0e-12_r8 * (so4vol**2) - else - return - end if - tmp_rateloge = log( tmp_ratenucl ) - -! exit if pbl nuc rate is lower than (incoming) ternary/binary rate - if (tmp_rateloge <= rateloge) return - - rateloge = tmp_rateloge - ratenucl = tmp_ratenucl - newnuc_method_flagaa2 = newnuc_method_flagaa - -! following wang 2002, assume fresh nuclei are 1 nm diameter -! subsequent code will "grow" them to aitken mode size - radius_cluster = 0.5_r8 - -! assume fresh nuclei are pure h2so4 -! since aitken size >> initial size, the initial composition -! has very little impact on the results - tmp_diam = radius_cluster * 2.0e-7_r8 ! diameter in cm - tmp_volu = (tmp_diam**3) * (pi/6.0_r8) ! volume in cm^3 - tmp_mass = tmp_volu * 1.8_r8 ! mass in g - cnum_h2so4 = (tmp_mass / 98.0_r8) * 6.023e23_r8 ! no. of h2so4 molec assuming pure h2so4 - cnum_tot = cnum_h2so4 - cnum_nh3 = 0.0_r8 - - - return - end subroutine pbl_nuc_wang2008 - - - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine binary_nuc_vehk2002( temp, rh, so4vol, & - ratenucl, rateloge, & - cnum_h2so4, cnum_tot, radius_cluster ) -! -! calculates binary nucleation rate and critical cluster size -! using the parameterization in -! vehkamäki, h., m. kulmala, i. napari, k.e.j. lehtinen, -! c. timmreck, m. noppel and a. laaksonen, 2002, -! an improved parameterization for sulfuric acid-water nucleation -! rates for tropospheric and stratospheric conditions, -! j. geophys. res., 107, 4622, doi:10.1029/2002jd002184 -! - implicit none - -! subr arguments (in) - real(r8), intent(in) :: temp ! temperature (k) - real(r8), intent(in) :: rh ! relative humidity (0-1) - real(r8), intent(in) :: so4vol ! concentration of h2so4 (molecules cm-3) - -! subr arguments (out) - real(r8), intent(out) :: ratenucl ! binary nucleation rate, j (# cm-3 s-1) - real(r8), intent(out) :: rateloge ! log( ratenucl ) - - real(r8), intent(out) :: cnum_h2so4 ! number of h2so4 molecules - ! in the critical nucleus - real(r8), intent(out) :: cnum_tot ! total number of molecules - ! in the critical nucleus - real(r8), intent(out) :: radius_cluster ! the radius of cluster (nm) - - -! local variables - real(r8) :: crit_x - real(r8) :: acoe, bcoe, ccoe, dcoe, ecoe, fcoe, gcoe, hcoe, icoe, jcoe - real(r8) :: tmpa, tmpb - -! executable - - -! calc sulfuric acid mole fraction in critical cluster - crit_x = 0.740997_r8 - 0.00266379_r8 * temp & - - 0.00349998_r8 * log (so4vol) & - + 0.0000504022_r8 * temp * log (so4vol) & - + 0.00201048_r8 * log (rh) & - - 0.000183289_r8 * temp * log (rh) & - + 0.00157407_r8 * (log (rh)) ** 2.0_r8 & - - 0.0000179059_r8 * temp * (log (rh)) ** 2.0_r8 & - + 0.000184403_r8 * (log (rh)) ** 3.0_r8 & - - 1.50345e-6_r8 * temp * (log (rh)) ** 3.0_r8 - - -! calc nucleation rate - acoe = 0.14309_r8+2.21956_r8*temp & - - 0.0273911_r8 * temp**2.0_r8 & - + 0.0000722811_r8 * temp**3.0_r8 + 5.91822_r8/crit_x - - bcoe = 0.117489_r8 + 0.462532_r8 *temp & - - 0.0118059_r8 * temp**2.0_r8 & - + 0.0000404196_r8 * temp**3.0_r8 + 15.7963_r8/crit_x - - ccoe = -0.215554_r8-0.0810269_r8 * temp & - + 0.00143581_r8 * temp**2.0_r8 & - - 4.7758e-6_r8 * temp**3.0_r8 & - - 2.91297_r8/crit_x - - dcoe = -3.58856_r8+0.049508_r8 * temp & - - 0.00021382_r8 * temp**2.0_r8 & - + 3.10801e-7_r8 * temp**3.0_r8 & - - 0.0293333_r8/crit_x - - ecoe = 1.14598_r8 - 0.600796_r8 * temp & - + 0.00864245_r8 * temp**2.0_r8 & - - 0.0000228947_r8 * temp**3.0_r8 & - - 8.44985_r8/crit_x - - fcoe = 2.15855_r8 + 0.0808121_r8 * temp & - -0.000407382_r8 * temp**2.0_r8 & - -4.01957e-7_r8 * temp**3.0_r8 & - + 0.721326_r8/crit_x - - gcoe = 1.6241_r8 - 0.0160106_r8 * temp & - + 0.0000377124_r8 * temp**2.0_r8 & - + 3.21794e-8_r8 * temp**3.0_r8 & - - 0.0113255_r8/crit_x - - hcoe = 9.71682_r8 - 0.115048_r8 * temp & - + 0.000157098_r8 * temp**2.0_r8 & - + 4.00914e-7_r8 * temp**3.0_r8 & - + 0.71186_r8/crit_x - - icoe = -1.05611_r8 + 0.00903378_r8 * temp & - - 0.0000198417_r8 * temp**2.0_r8 & - + 2.46048e-8_r8 * temp**3.0_r8 & - - 0.0579087_r8/crit_x - - jcoe = -0.148712_r8 + 0.00283508_r8 * temp & - - 9.24619e-6_r8 * temp**2.0_r8 & - + 5.00427e-9_r8 * temp**3.0_r8 & - - 0.0127081_r8/crit_x - - tmpa = ( & - acoe & - + bcoe * log (rh) & - + ccoe * ( log (rh))**2.0_r8 & - + dcoe * ( log (rh))**3.0_r8 & - + ecoe * log (so4vol) & - + fcoe * (log (rh)) * (log (so4vol)) & - + gcoe * ((log (rh) ) **2.0_r8) & - * (log (so4vol)) & - + hcoe * (log (so4vol)) **2.0_r8 & - + icoe * log (rh) & - * ((log (so4vol)) **2.0_r8) & - + jcoe * (log (so4vol)) **3.0_r8 & - ) - rateloge = tmpa - tmpa = min( tmpa, log(1.0e38_r8) ) - ratenucl = exp ( tmpa ) -! write(*,*) 'tmpa, ratenucl =', tmpa, ratenucl - - - -! calc number of molecules in critical cluster - acoe = -0.00295413_r8 - 0.0976834_r8*temp & - + 0.00102485_r8 * temp**2.0_r8 & - - 2.18646e-6_r8 * temp**3.0_r8 - 0.101717_r8/crit_x - - bcoe = -0.00205064_r8 - 0.00758504_r8*temp & - + 0.000192654_r8 * temp**2.0_r8 & - - 6.7043e-7_r8 * temp**3.0_r8 - 0.255774_r8/crit_x - - ccoe = +0.00322308_r8 + 0.000852637_r8 * temp & - - 0.0000154757_r8 * temp**2.0_r8 & - + 5.66661e-8_r8 * temp**3.0_r8 & - + 0.0338444_r8/crit_x - - dcoe = +0.0474323_r8 - 0.000625104_r8 * temp & - + 2.65066e-6_r8 * temp**2.0_r8 & - - 3.67471e-9_r8 * temp**3.0_r8 & - - 0.000267251_r8/crit_x - - ecoe = -0.0125211_r8 + 0.00580655_r8 * temp & - - 0.000101674_r8 * temp**2.0_r8 & - + 2.88195e-7_r8 * temp**3.0_r8 & - + 0.0942243_r8/crit_x - - fcoe = -0.038546_r8 - 0.000672316_r8 * temp & - + 2.60288e-6_r8 * temp**2.0_r8 & - + 1.19416e-8_r8 * temp**3.0_r8 & - - 0.00851515_r8/crit_x - - gcoe = -0.0183749_r8 + 0.000172072_r8 * temp & - - 3.71766e-7_r8 * temp**2.0_r8 & - - 5.14875e-10_r8 * temp**3.0_r8 & - + 0.00026866_r8/crit_x - - hcoe = -0.0619974_r8 + 0.000906958_r8 * temp & - - 9.11728e-7_r8 * temp**2.0_r8 & - - 5.36796e-9_r8 * temp**3.0_r8 & - - 0.00774234_r8/crit_x - - icoe = +0.0121827_r8 - 0.00010665_r8 * temp & - + 2.5346e-7_r8 * temp**2.0_r8 & - - 3.63519e-10_r8 * temp**3.0_r8 & - + 0.000610065_r8/crit_x - - jcoe = +0.000320184_r8 - 0.0000174762_r8 * temp & - + 6.06504e-8_r8 * temp**2.0_r8 & - - 1.4177e-11_r8 * temp**3.0_r8 & - + 0.000135751_r8/crit_x - - cnum_tot = exp ( & - acoe & - + bcoe * log (rh) & - + ccoe * ( log (rh))**2.0_r8 & - + dcoe * ( log (rh))**3.0_r8 & - + ecoe * log (so4vol) & - + fcoe * (log (rh)) * (log (so4vol)) & - + gcoe * ((log (rh) ) **2.0_r8) & - * (log (so4vol)) & - + hcoe * (log (so4vol)) **2.0_r8 & - + icoe * log (rh) & - * ((log (so4vol)) **2.0_r8) & - + jcoe * (log (so4vol)) **3.0_r8 & - ) - - cnum_h2so4 = cnum_tot * crit_x - -! calc radius (nm) of critical cluster - radius_cluster = exp( -1.6524245_r8 + 0.42316402_r8*crit_x & - + 0.3346648_r8*log(cnum_tot) ) - - - return - end subroutine binary_nuc_vehk2002 - - - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -subroutine modal_aero_newnuc_init( l_h2so4_in, l_nh3_in, & - lnumait_in, lnh4ait_in, lso4ait_in, & - mw_so4a_host_in, mw_nh4a_host_in, dens_so4a_host_in, & - dgnum_aitken_in, dgnumhi_aitken_in, dgnumlo_aitken_in, & - pi_in, rgas_in, avogad_in, mw_so4a_in, mw_nh4a_in, & - r_universal_in, errmsg, errflg ) - -!----------------------------------------------------------------------- -! -! Purpose: -! store the resolved species indices, aitken-mode so4/nh4 properties, -! and host physical constants used by modal_aero_newnuc_run -! index resolution and history-field registration are host -! responsibilities (see modal_aero_newnuc_cam) -! -!----------------------------------------------------------------------- - -implicit none - -!----------------------------------------------------------------------- -! arguments - integer, intent(in) :: l_h2so4_in ! h2so4 gas index (host constituent space) - integer, intent(in) :: l_nh3_in ! nh3 gas index (host constituent space) - integer, intent(in) :: lnumait_in ! aitken number index (host constituent space) - integer, intent(in) :: lnh4ait_in ! aitken nh4 index (host constituent space) - integer, intent(in) :: lso4ait_in ! aitken so4 index (host constituent space) - real(r8), intent(in) :: mw_so4a_host_in ! mw of so4 aerosol in host code (g/mol) - real(r8), intent(in) :: mw_nh4a_host_in ! mw of nh4 aerosol in host code (g/mol) - real(r8), intent(in) :: dens_so4a_host_in ! dry density of so4 aerosol in host code (kg/m3) - real(r8), intent(in) :: dgnum_aitken_in ! aitken mode nominal dry diameter (m) - real(r8), intent(in) :: dgnumhi_aitken_in ! aitken mode upper dry-diameter limit (m) - real(r8), intent(in) :: dgnumlo_aitken_in ! aitken mode lower dry-diameter limit (m) - real(r8), intent(in) :: pi_in - real(r8), intent(in) :: rgas_in ! gas constant (J/K/mol) - real(r8), intent(in) :: avogad_in ! Avogadro's number (1/mol) - real(r8), intent(in) :: mw_so4a_in ! molecular weight of sulfate (g/mol) - real(r8), intent(in) :: mw_nh4a_in ! molecular weight of ammonium (g/mol) - real(r8), intent(in) :: r_universal_in ! universal gas constant (J/K/kmol) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - !----------------------------------------------------------------------- - - errmsg = ' ' - errflg = 0 - - l_h2so4_sv = l_h2so4_in - l_nh3_sv = l_nh3_in - lnumait_sv = lnumait_in - lnh4ait_sv = lnh4ait_in - lso4ait_sv = lso4ait_in - - mw_so4a_host = mw_so4a_host_in - mw_nh4a_host = mw_nh4a_host_in - dens_so4a_host = dens_so4a_host_in - - dgnum_aitken = dgnum_aitken_in - dgnumhi_aitken = dgnumhi_aitken_in - dgnumlo_aitken = dgnumlo_aitken_in - - pi = pi_in - rgas = rgas_in - avogad = avogad_in - mw_so4a = mw_so4a_in - mw_nh4a = mw_nh4a_in - r_universal = r_universal_in - - return - end subroutine modal_aero_newnuc_init - - - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -subroutine ternary_nuc_merik2007( t, rh, c2, c3, j_log, ntot, nacid, namm, r ) -!subroutine ternary_fit( t, rh, c2, c3, j_log, ntot, nacid, namm, r ) -! *************************** ternary_fit.f90 ******************************** -! joonas merikanto, 2006 -! -! fortran 90 subroutine that calculates the parameterized composition -! and nucleation rate of critical clusters in h2o-h2so4-nh3 vapor -! -! warning: the fit should not be used outside its limits of validity -! (limits indicated below) -! -! in: -! t: temperature (k), limits 235-295 k -! rh: relative humidity as fraction (eg. 0.5=50%) limits 0.05-0.95 -! c2: sulfuric acid concentration (molecules/cm3) limits 5x10^4 - 10^9 molecules/cm3 -! c3: ammonia mixing ratio (ppt) limits 0.1 - 1000 ppt -! -! out: -! j_log: logarithm of nucleation rate (1/(s cm3)) -! ntot: total number of molecules in the critical cluster -! nacid: number of sulfuric acid molecules in the critical cluster -! namm: number of ammonia molecules in the critical cluster -! r: radius of the critical cluster (nm) -! **************************************************************************** -implicit none - -real(r8), intent(in) :: t, rh, c2, c3 -real(r8), intent(out) :: j_log, ntot, nacid, namm, r -real(r8) :: j, t_onset - -t_onset=143.6002929064716_r8 + 1.0178856665693992_r8*rh + & - 10.196398812974294_r8*log(c2) - & - 0.1849879416839113_r8*log(c2)**2 - 17.161783213150173_r8*log(c3) + & - (109.92469248546053_r8*log(c3))/log(c2) + & - 0.7734119613144357_r8*log(c2)*log(c3) - 0.15576469879527022_r8*log(c3)**2 - -if(t_onset.gt.t) then - - j_log=-12.861848898625231_r8 + 4.905527742256349_r8*c3 - 358.2337705052991_r8*rh -& - 0.05463019231872484_r8*c3*t + 4.8630382337426985_r8*rh*t + & - 0.00020258394697064567_r8*c3*t**2 - 0.02175548069741675_r8*rh*t**2 - & - 2.502406532869512e-7_r8*c3*t**3 + 0.00003212869941055865_r8*rh*t**3 - & - 4.39129415725234e6_r8/log(c2)**2 + (56383.93843154586_r8*t)/log(c2)**2 -& - (239.835990963361_r8*t**2)/log(c2)**2 + & - (0.33765136625580167_r8*t**3)/log(c2)**2 - & - (629.7882041830943_r8*rh)/(c3**3*log(c2)) + & - (7.772806552631709_r8*rh*t)/(c3**3*log(c2)) - & - (0.031974053936299256_r8*rh*t**2)/(c3**3*log(c2)) + & - (0.00004383764128775082_r8*rh*t**3)/(c3**3*log(c2)) + & - 1200.472096232311_r8*log(c2) - 17.37107890065621_r8*t*log(c2) + & - 0.08170681335921742_r8*t**2*log(c2) - 0.00012534476159729881_r8*t**3*log(c2) - & - 14.833042158178936_r8*log(c2)**2 + 0.2932631303555295_r8*t*log(c2)**2 - & - 0.0016497524241142845_r8*t**2*log(c2)**2 + & - 2.844074805239367e-6_r8*t**3*log(c2)**2 - 231375.56676032578_r8*log(c3) - & - 100.21645273730675_r8*rh*log(c3) + 2919.2852552424706_r8*t*log(c3) + & - 0.977886555834732_r8*rh*t*log(c3) - 12.286497122264588_r8*t**2*log(c3) - & - 0.0030511783284506377_r8*rh*t**2*log(c3) + & - 0.017249301826661612_r8*t**3*log(c3) + 2.967320346100855e-6_r8*rh*t**3*log(c3) + & - (2.360931724951942e6_r8*log(c3))/log(c2) - & - (29752.130254319443_r8*t*log(c3))/log(c2) + & - (125.04965118142027_r8*t**2*log(c3))/log(c2) - & - (0.1752996881934318_r8*t**3*log(c3))/log(c2) + & - 5599.912337254629_r8*log(c2)*log(c3) - 70.70896612937771_r8*t*log(c2)*log(c3) + & - 0.2978801613269466_r8*t**2*log(c2)*log(c3) - & - 0.00041866525019504_r8*t**3*log(c2)*log(c3) + 75061.15281456841_r8*log(c3)**2 - & - 931.8802278173565_r8*t*log(c3)**2 + 3.863266220840964_r8*t**2*log(c3)**2 - & - 0.005349472062284983_r8*t**3*log(c3)**2 - & - (732006.8180571689_r8*log(c3)**2)/log(c2) + & - (9100.06398573816_r8*t*log(c3)**2)/log(c2) - & - (37.771091915932004_r8*t**2*log(c3)**2)/log(c2) + & - (0.05235455395566905_r8*t**3*log(c3)**2)/log(c2) - & - 1911.0303773001353_r8*log(c2)*log(c3)**2 + & - 23.6903969622286_r8*t*log(c2)*log(c3)**2 - & - 0.09807872005428583_r8*t**2*log(c2)*log(c3)**2 + & - 0.00013564560238552576_r8*t**3*log(c2)*log(c3)**2 - & - 3180.5610833308_r8*log(c3)**3 + 39.08268568672095_r8*t*log(c3)**3 - & - 0.16048521066690752_r8*t**2*log(c3)**3 + & - 0.00022031380023793877_r8*t**3*log(c3)**3 + & - (40751.075322248245_r8*log(c3)**3)/log(c2) - & - (501.66977622013934_r8*t*log(c3)**3)/log(c2) + & - (2.063469732254135_r8*t**2*log(c3)**3)/log(c2) - & - (0.002836873785758324_r8*t**3*log(c3)**3)/log(c2) + & - 2.792313345723013_r8*log(c2)**2*log(c3)**3 - & - 0.03422552111802899_r8*t*log(c2)**2*log(c3)**3 + & - 0.00014019195277521142_r8*t**2*log(c2)**2*log(c3)**3 - & - 1.9201227328396297e-7_r8*t**3*log(c2)**2*log(c3)**3 - & - 980.923146020468_r8*log(rh) + 10.054155220444462_r8*t*log(rh) - & - 0.03306644502023841_r8*t**2*log(rh) + 0.000034274041225891804_r8*t**3*log(rh) + & - (16597.75554295064_r8*log(rh))/log(c2) - & - (175.2365504237746_r8*t*log(rh))/log(c2) + & - (0.6033215603167458_r8*t**2*log(rh))/log(c2) - & - (0.0006731787599587544_r8*t**3*log(rh))/log(c2) - & - 89.38961120336789_r8*log(c3)*log(rh) + 1.153344219304926_r8*t*log(c3)*log(rh) - & - 0.004954549700267233_r8*t**2*log(c3)*log(rh) + & - 7.096309866238719e-6_r8*t**3*log(c3)*log(rh) + & - 3.1712136610383244_r8*log(c3)**3*log(rh) - & - 0.037822330602328806_r8*t*log(c3)**3*log(rh) + & - 0.0001500555743561457_r8*t**2*log(c3)**3*log(rh) - & - 1.9828365865570703e-7_r8*t**3*log(c3)**3*log(rh) - - j=exp(j_log) - - ntot=57.40091052369212_r8 - 0.2996341884645408_r8*t + & - 0.0007395477768531926_r8*t**2 - & - 5.090604835032423_r8*log(c2) + 0.011016634044531128_r8*t*log(c2) + & - 0.06750032251225707_r8*log(c2)**2 - 0.8102831333223962_r8*log(c3) + & - 0.015905081275952426_r8*t*log(c3) - 0.2044174683159531_r8*log(c2)*log(c3) + & - 0.08918159167625832_r8*log(c3)**2 - 0.0004969033586666147_r8*t*log(c3)**2 + & - 0.005704394549007816_r8*log(c3)**3 + 3.4098703903474368_r8*log(j) - & - 0.014916956508210809_r8*t*log(j) + 0.08459090011666293_r8*log(c3)*log(j) - & - 0.00014800625143907616_r8*t*log(c3)*log(j) + 0.00503804694656905_r8*log(j)**2 - - r=3.2888553966535506e-10_r8 - 3.374171768439839e-12_r8*t + & - 1.8347359507774313e-14_r8*t**2 + 2.5419844298881856e-12_r8*log(c2) - & - 9.498107643050827e-14_r8*t*log(c2) + 7.446266520834559e-13_r8*log(c2)**2 + & - 2.4303397746137294e-11_r8*log(c3) + 1.589324325956633e-14_r8*t*log(c3) - & - 2.034596219775266e-12_r8*log(c2)*log(c3) - 5.59303954457172e-13_r8*log(c3)**2 - & - 4.889507104645867e-16_r8*t*log(c3)**2 + 1.3847024107506764e-13_r8*log(c3)**3 + & - 4.141077193427042e-15_r8*log(j) - 2.6813110884009767e-14_r8*t*log(j) + & - 1.2879071621313094e-12_r8*log(c3)*log(j) - & - 3.80352446061867e-15_r8*t*log(c3)*log(j) - 1.8790172502456827e-14_r8*log(j)**2 - - nacid=-4.7154180661803595_r8 + 0.13436423483953885_r8*t - & - 0.00047184686478816176_r8*t**2 - & - 2.564010713640308_r8*log(c2) + 0.011353312899114723_r8*t*log(c2) + & - 0.0010801941974317014_r8*log(c2)**2 + 0.5171368624197119_r8*log(c3) - & - 0.0027882479896204665_r8*t*log(c3) + 0.8066971907026886_r8*log(c3)**2 - & - 0.0031849094214409335_r8*t*log(c3)**2 - 0.09951184152927882_r8*log(c3)**3 + & - 0.00040072788891745513_r8*t*log(c3)**3 + 1.3276469271073974_r8*log(j) - & - 0.006167654171986281_r8*t*log(j) - 0.11061390967822708_r8*log(c3)*log(j) + & - 0.0004367575329273496_r8*t*log(c3)*log(j) + 0.000916366357266258_r8*log(j)**2 - - namm=71.20073903979772_r8 - 0.8409600103431923_r8*t + & - 0.0024803006590334922_r8*t**2 + & - 2.7798606841602607_r8*log(c2) - 0.01475023348171676_r8*t*log(c2) + & - 0.012264508212031405_r8*log(c2)**2 - 2.009926050440182_r8*log(c3) + & - 0.008689123511431527_r8*t*log(c3) - 0.009141180198955415_r8*log(c2)*log(c3) + & - 0.1374122553905617_r8*log(c3)**2 - 0.0006253227821679215_r8*t*log(c3)**2 + & - 0.00009377332742098946_r8*log(c3)**3 + 0.5202974341687757_r8*log(j) - & - 0.002419872323052805_r8*t*log(j) + 0.07916392322884074_r8*log(c3)*log(j) - & - 0.0003021586030317366_r8*t*log(c3)*log(j) + 0.0046977006608603395_r8*log(j)**2 - -else -! nucleation rate less that 5e-6, setting j_log arbitrary small - j_log=-300._r8 -end if - -return - -end subroutine ternary_nuc_merik2007 - -!---------------------------------------------------------------------- -end module modal_aero_newnuc - - - diff --git a/src/chemistry/modal_aero/modal_aero_rename.F90 b/src/chemistry/modal_aero/modal_aero_rename.F90 deleted file mode 100644 index 2517eeef73..0000000000 --- a/src/chemistry/modal_aero/modal_aero_rename.F90 +++ /dev/null @@ -1,1400 +0,0 @@ -! Portable code for modal aerosol mode merging (renaming) -module modal_aero_rename - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - save - - public :: modal_aero_rename_init - public :: modal_aero_rename_run - - integer, parameter, public :: maxpair_renamexf = 3 - integer, parameter, public :: method_optbb_renamexf = 2 - - ! rename's OWN precomputed physics coefficients (accum-coarse-exchange path) are - ! set by modal_aero_rename_init and read by modal_aero_rename_run. - - integer :: iulog - character(len=32), allocatable :: cnst_name(:), cnst_name_cw(:) - - ! precomputed physics coefficients (accum-coarse-exchange path) - integer, allocatable :: ido_mode_calcaa(:) - real (r8) :: dp_belowcut(maxpair_renamexf) - real (r8) :: dp_cut(maxpair_renamexf) - real (r8) :: dp_xferall_thresh(maxpair_renamexf) - real (r8) :: dp_xfernone_threshaa(maxpair_renamexf) - real (r8), allocatable :: dryvol_smallest(:) - real (r8), allocatable :: factoraa(:) - real (r8), allocatable :: factoryy(:) - real (r8) :: lndp_cut(maxpair_renamexf) - real (r8) :: factor_3alnsg2(maxpair_renamexf) - real (r8), allocatable :: v2nhirlx(:), v2nlorlx(:) -contains - - !------------------------------------------------------------------ - ! Precompute rename's own accum-coarse-exchange physics coefficients from the - ! host-provided mode metadata + resolved pair tables (passed as arguments), - ! and store cnst_name/iulog for diagnostics. The shared tables/metadata are - ! NOT retained; modal_aero_rename_run receives them as arguments each call. - !------------------------------------------------------------------ - subroutine modal_aero_rename_init( & - modal_accum_coarse_exch, & - ntot_amode, & - alnsg_amode, dgnum_amode, & - dgnumhi_amode, dgnumlo_amode, & - voltonumblo_amode, voltonumbhi_amode, & - modeptr_accum, modeptr_coarse, modeptr_stracoar, & - npair_renamexf, modefrm_renamexf, modetoo_renamexf, & - nspecfrm_renamexf, & - lspecfrma_renamexf, lspecfrmc_renamexf, & - lspectooa_renamexf, lspectooc_renamexf, & - igrow_shrink_renamexf, ixferable_all_renamexf, & - cnst_name_in, cnst_name_cw_in, & - pi, amRoot, iulog_in, & - errmsg, errflg ) - - ! arguments - logical, intent(in) :: modal_accum_coarse_exch - integer, intent(in) :: ntot_amode - real(r8), intent(in) :: alnsg_amode(:) - real(r8), intent(in) :: dgnum_amode(:) - real(r8), intent(in) :: dgnumhi_amode(:) - real(r8), intent(in) :: dgnumlo_amode(:) - real(r8), intent(in) :: voltonumblo_amode(:) - real(r8), intent(in) :: voltonumbhi_amode(:) - integer, intent(in) :: modeptr_accum - integer, intent(in) :: modeptr_coarse - integer, intent(in) :: modeptr_stracoar - integer, intent(in) :: npair_renamexf - integer, intent(in) :: modefrm_renamexf(:) - integer, intent(in) :: modetoo_renamexf(:) - integer, intent(in) :: nspecfrm_renamexf(:) - integer, intent(in) :: lspecfrma_renamexf(:,:) - integer, intent(in) :: lspecfrmc_renamexf(:,:) - integer, intent(in) :: lspectooa_renamexf(:,:) - integer, intent(in) :: lspectooc_renamexf(:,:) - integer, intent(in) :: igrow_shrink_renamexf(:) - integer, intent(in) :: ixferable_all_renamexf(:) - character(len=*), intent(in) :: cnst_name_in(:) - character(len=*), intent(in) :: cnst_name_cw_in(:) - real(r8), intent(in) :: pi - logical, intent(in) :: amRoot - integer, intent(in) :: iulog_in - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local (used by the precompute + one-time log below) - integer :: ipair, iq, lsfrma, lsfrmc, lstooa, lstooc, lunout - integer :: mfrm, mtoo - real(r8) :: frelax - logical :: masterproc - - errmsg = '' - errflg = 0 - - iulog = iulog_in - ! stored only for the (disabled) per-column diagnostic + one-time log - allocate(cnst_name(size(cnst_name_in))); cnst_name(:) = cnst_name_in(:) - allocate(cnst_name_cw(size(cnst_name_cw_in))); cnst_name_cw(:) = cnst_name_cw_in(:) - - allocate(ido_mode_calcaa(ntot_amode)) - allocate(dryvol_smallest(ntot_amode)) - allocate(factoraa(ntot_amode)) - allocate(factoryy(ntot_amode)) - allocate(v2nhirlx(ntot_amode), v2nlorlx(ntot_amode)) - - ! nothing to precompute unless there are renaming pairs - if (npair_renamexf .le. 0) return - - lunout = iulog - masterproc = amRoot - - if (modal_accum_coarse_exch) then - -! -! -! initialize some working variables -! -! - ido_mode_calcaa(:) = 0 - frelax = 27.0_r8 - - do ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - ido_mode_calcaa(mfrm) = 1 - - factoraa(mfrm) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mfrm)**2)) - factoraa(mtoo) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mtoo)**2)) - factoryy(mfrm) = sqrt( 0.5_r8 )/alnsg_amode(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_r8 - v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax - v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax - - factor_3alnsg2(ipair) = 3.0_r8 * (alnsg_amode(mfrm)**2) - - dp_cut(ipair) = sqrt( & - dgnum_amode(mfrm)*exp(1.5_r8*(alnsg_amode(mfrm)**2)) * & - dgnum_amode(mtoo)*exp(1.5_r8*(alnsg_amode(mtoo)**2)) ) - dp_xferall_thresh(ipair) = dgnum_amode(mtoo) - dp_xfernone_threshaa(ipair) = dgnum_amode(mfrm) - if (((mfrm == modeptr_accum) .and. (mtoo == modeptr_coarse)).or.& - ((mfrm == modeptr_accum) .and. (mtoo == modeptr_stracoar))) then - dp_cut(ipair) = 4.4e-7_r8 - dp_xfernone_threshaa(ipair) = 1.6e-7_r8 - dp_xferall_thresh(ipair) = 4.7e-7_r8 - else if (((mfrm == modeptr_coarse) .and. (mtoo == modeptr_accum)).or.& - ((mfrm == modeptr_stracoar) .and. (mtoo == modeptr_accum))) then - dp_cut(ipair) = 4.4e-7_r8 - dp_xfernone_threshaa(ipair) = 4.4e-7_r8 - dp_xferall_thresh(ipair) = 4.1e-7_r8 - end if - - lndp_cut(ipair) = log( dp_cut(ipair) ) - dp_belowcut(ipair) = 0.99_r8*dp_cut(ipair) - end do - -! -! output results -! - if ( masterproc ) then - - write(lunout,9310) - write(lunout,'(a,1x,i12)') 'method_optbb_renamexf', method_optbb_renamexf - - do 2900 ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - write(lunout,9320) ipair, mfrm, mtoo, & - igrow_shrink_renamexf(ipair), ixferable_all_renamexf(ipair) - - do iq = 1, nspecfrm_renamexf(ipair) - lsfrma = lspecfrma_renamexf(iq,ipair) - lstooa = lspectooa_renamexf(iq,ipair) - lsfrmc = lspecfrmc_renamexf(iq,ipair) - lstooc = lspectooc_renamexf(iq,ipair) - if (lstooa .gt. 0) then - write(lunout,9330) lsfrma, cnst_name(lsfrma), & - lstooa, cnst_name(lstooa) - else - write(lunout,9340) lsfrma, cnst_name(lsfrma) - end if - if (lstooc .gt. 0) then - write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc), & - lstooc, cnst_name_cw(lstooc) - else if (lsfrmc .gt. 0) then - write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc) - else - write(lunout,9350) - end if - end do - - if (igrow_shrink_renamexf(ipair) > 0) then - write(lunout,'(5x,a,1p,2e12.3)') 'mfrm dgnum, dgnumhi ', & - dgnum_amode(mfrm), dgnumhi_amode(mfrm) - write(lunout,'(5x,a,1p,2e12.3)') 'mtoo dgnum, dgnumlo ', & - dgnum_amode(mtoo), dgnumlo_amode(mtoo) - else - write(lunout,'(5x,a,1p,2e12.3)') 'mfrm dgnum, dgnumlo ', & - dgnum_amode(mfrm), dgnumlo_amode(mfrm) - write(lunout,'(5x,a,1p,2e12.3)') 'mtoo dgnum, dgnumhi ', & - dgnum_amode(mtoo), dgnumhi_amode(mtoo) - end if - - write(lunout,'(5x,a,1p,2e12.3)') 'dp_cut ', & - dp_cut(ipair) - write(lunout,'(5x,a,1p,2e12.3)') 'dp_xfernone_threshaa', & - dp_xfernone_threshaa(ipair) - write(lunout,'(5x,a,1p,2e12.3)') 'dp_xferall_thresh ', & - dp_xferall_thresh(ipair) - -2900 continue - write(lunout,*) - - end if ! ( masterproc ) - end if - - return - -9310 format( / 'subr. modal_aero_rename_acc_crs_init' ) -9320 format( / 'pair', i3, 5x, 'mode', i3, ' ---> mode', i3, & - 5x, 'igrow_shrink', i3, 5x, 'ixferable_all', i3 ) -9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a ) -9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' ) -9350 format( 5x, 'no corresponding activated species' ) - - end subroutine modal_aero_rename_init - - subroutine modal_aero_rename_run( & - ncol, & - loffset, deltat, & - pdel, troplev, & - dotendrn, q, & - dqdt, dqdt_other, & - dotendqqcwrn, qqcw, & - dqqcwdt, dqqcwdt_other, & - is_dorename_atik, dorename_atik, & - jsrflx_rename, nsrflx, & - qsrflx, qqcwsrflx, & - dqdt_rnpos, & - ntot_amode, npair_renamexf, & - modefrm_renamexf, modetoo_renamexf, & - nspecfrm_renamexf, & - lspecfrma_renamexf, lspecfrmc_renamexf, & - lspectooa_renamexf, lspectooc_renamexf, & - alnsg_amode, voltonumblo_amode, & - voltonumbhi_amode, dgnum_amode, & - nspec_amode, specmw_amode, & - specdens_amode, lmassptr_amode, & - lmassptrcw_amode, numptr_amode, & - numptrcw_amode, pi, & - modeptr_accum, modeptr_coarse, & - modeptr_stracoar, & - igrow_shrink_renamexf, & - ixferable_all_renamexf, & - ixferable_a_renamexf, ixferable_c_renamexf, & - strat_only_renamexf, & - modal_accum_coarse_exch, & - pver, gravit, & - errmsg, errflg ) - integer, intent(in) :: ncol ! number of atmospheric column - integer, intent(in) :: loffset ! offset applied to modal aero "ptrs" - real(r8), intent(in) :: deltat ! time step (s) - integer, intent(in) :: troplev(:) - real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: q(:,:,:) ! tracer mixing ratio array (mol/mol-air or #/mol-air) - real(r8), intent(in) :: qqcw(:,:,:) ! like q but for cloud-borne species - real(r8), intent(inout) :: dqdt(:,:,:) ! TMR tendency array (renaming tendencies added on) - real(r8), intent(inout) :: dqqcwdt(:,:,:) - real(r8), intent(in) :: dqdt_other(:,:,:) ! tendencies for "other" continuous growth process - real(r8), intent(in) :: dqqcwdt_other(:,:,:) - logical, intent(inout) :: dotendrn(:) ! species with renaming dqdt computed - logical, intent(inout) :: dotendqqcwrn(:) - logical, intent(in) :: is_dorename_atik ! true if dorename_atik is provided - logical, intent(in) :: dorename_atik(:,:) ! true if renaming should be done at i,k - integer, intent(in) :: jsrflx_rename ! qsrflx index for renaming - integer, intent(in) :: nsrflx ! last dimension of qsrflx - real(r8), intent(out) :: qsrflx(:,:,:) ! process-specific column tracer tendencies - real(r8), intent(out) :: qqcwsrflx(:,:,:) - real(r8), intent(out) :: dqdt_rnpos(:,:,:) ! positive (production) part of renaming tendency - ! shared mode metadata + resolved renaming-pair tables (host-owned; passed in) - integer, intent(in) :: ntot_amode - integer, intent(in) :: npair_renamexf - integer, intent(in) :: modefrm_renamexf(:) - integer, intent(in) :: modetoo_renamexf(:) - integer, intent(in) :: nspecfrm_renamexf(:) - integer, intent(in) :: lspecfrma_renamexf(:,:) - integer, intent(in) :: lspecfrmc_renamexf(:,:) - integer, intent(in) :: lspectooa_renamexf(:,:) - integer, intent(in) :: lspectooc_renamexf(:,:) - real(r8), intent(in) :: alnsg_amode(:) - real(r8), intent(in) :: voltonumblo_amode(:) - real(r8), intent(in) :: voltonumbhi_amode(:) - real(r8), intent(in) :: dgnum_amode(:) - integer, intent(in) :: nspec_amode(:) - real(r8), intent(in) :: specmw_amode(:,:) - real(r8), intent(in) :: specdens_amode(:,:) - integer, intent(in) :: lmassptr_amode(:,:) - integer, intent(in) :: lmassptrcw_amode(:,:) - integer, intent(in) :: numptr_amode(:) - integer, intent(in) :: numptrcw_amode(:) - real(r8), intent(in) :: pi - ! accum-coarse-exchange path flags (host-owned; passed in) - integer, intent(in) :: modeptr_accum - integer, intent(in) :: modeptr_coarse - integer, intent(in) :: modeptr_stracoar - integer, intent(in) :: igrow_shrink_renamexf(:) - integer, intent(in) :: ixferable_all_renamexf(:) - integer, intent(in) :: ixferable_a_renamexf(:,:) - integer, intent(in) :: ixferable_c_renamexf(:,:) - logical, intent(in) :: strat_only_renamexf(:) - logical, intent(in) :: modal_accum_coarse_exch ! select accum-coarse exchange path - integer, intent(in) :: pver ! number of vertical levels - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - character(len=*), intent(out) :: errmsg ! error message - integer, intent(out) :: errflg ! error flag - - errmsg = '' - errflg = 0 - - if (modal_accum_coarse_exch) then - call modal_aero_rename_acc_crs_sub( & - ncol, & - loffset, deltat, & - pdel, troplev, & - dotendrn, q, & - dqdt, dqdt_other, & - dotendqqcwrn, qqcw, & - dqqcwdt, dqqcwdt_other, & - is_dorename_atik, dorename_atik, & - jsrflx_rename, nsrflx, & - qsrflx, qqcwsrflx, & - dqdt_rnpos, & - ntot_amode, npair_renamexf, & - modefrm_renamexf, modetoo_renamexf, & - nspecfrm_renamexf, & - lspecfrma_renamexf, lspecfrmc_renamexf, & - lspectooa_renamexf, lspectooc_renamexf, & - alnsg_amode, voltonumblo_amode, & - voltonumbhi_amode, dgnum_amode, & - nspec_amode, specmw_amode, & - specdens_amode, lmassptr_amode, & - lmassptrcw_amode, numptr_amode, & - numptrcw_amode, pi, & - modeptr_accum, modeptr_coarse, & - modeptr_stracoar, & - igrow_shrink_renamexf, & - ixferable_all_renamexf, & - ixferable_a_renamexf, ixferable_c_renamexf, & - strat_only_renamexf, & - pver, gravit, & - errmsg, errflg ) - else - ! no_acc path does not produce dqdt_rnpos; define the required output here. - dqdt_rnpos(:,:,:) = 0.0_r8 - call modal_aero_rename_no_acc_crs_sub( & - ncol, & - loffset, deltat, & - pdel, & - dotendrn, q, & - dqdt, dqdt_other, & - dotendqqcwrn, qqcw, & - dqqcwdt, dqqcwdt_other, & - is_dorename_atik, dorename_atik, & - jsrflx_rename, nsrflx, & - qsrflx, qqcwsrflx, & - ntot_amode, npair_renamexf, & - modefrm_renamexf, modetoo_renamexf, & - nspecfrm_renamexf, & - lspecfrma_renamexf, lspecfrmc_renamexf, & - lspectooa_renamexf, lspectooc_renamexf, & - alnsg_amode, voltonumblo_amode, & - voltonumbhi_amode, dgnum_amode, & - nspec_amode, specmw_amode, & - specdens_amode, lmassptr_amode, & - lmassptrcw_amode, numptr_amode, & - numptrcw_amode, pi, & - pver, gravit, & - errmsg, errflg ) - end if - end subroutine modal_aero_rename_run - - !---------------------------------------------------------------------- - ! private methods - - subroutine modal_aero_rename_no_acc_crs_sub( & - ncol, & - loffset, deltat, & - pdel, & - dotendrn, q, & - dqdt, dqdt_other, & - dotendqqcwrn, qqcw, & - dqqcwdt, dqqcwdt_other, & - is_dorename_atik, dorename_atik, & - jsrflx_rename, nsrflx, & - qsrflx, qqcwsrflx, & - ntot_amode, npair_renamexf, & - modefrm_renamexf, modetoo_renamexf, & - nspecfrm_renamexf, & - lspecfrma_renamexf, lspecfrmc_renamexf, & - lspectooa_renamexf, lspectooc_renamexf, & - alnsg_amode, voltonumblo_amode, & - voltonumbhi_amode, dgnum_amode, & - nspec_amode, specmw_amode, & - specdens_amode, lmassptr_amode, & - lmassptrcw_amode, numptr_amode, & - numptrcw_amode, pi, & - pver, gravit, & - errmsg, errflg ) - use shr_spfn_mod, only: erfc => shr_spfn_erfc - - integer, intent(in) :: ncol ! number of atmospheric column - integer, intent(in) :: loffset ! offset applied to modal aero "ptrs" - real(r8), intent(in) :: deltat ! time step (s) - - real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: q(:,:,:) ! tracer mixing ratio array - ! *** MUST BE mol/mol-air or #/mol-air - ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(in) :: qqcw(:,:,:) ! like q but for cloud-borne species - - real(r8), intent(inout) :: dqdt(:,:,:) ! TMR tendency array; - ! incoming dqdt = tendencies for the - ! "fromwhere" continuous growth process - ! the renaming tendencies are added on - ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(inout) :: dqqcwdt(:,:,:) - real(r8), intent(in) :: dqdt_other(:,:,:) - ! tendencies for "other" continuous growth process - ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(in) :: dqqcwdt_other(:,:,:) - logical, intent(inout) :: dotendrn(:) ! identifies the species for which - ! renaming dqdt is computed - logical, intent(inout) :: dotendqqcwrn(:) - - logical, intent(in) :: is_dorename_atik ! true if dorename_atik is provided - logical, intent(in) :: dorename_atik(:,:) ! true if renaming should - ! be done at i,k - integer, intent(in) :: jsrflx_rename ! qsrflx index for renaming - integer, intent(in) :: nsrflx ! last dimension of qsrflx - - real(r8), intent(out) :: qsrflx(:,:,:) - ! process-specific column tracer tendencies - real(r8), intent(out) :: qqcwsrflx(:,:,:) - - integer, intent(in) :: pver ! number of vertical levels - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - character(len=*), intent(out) :: errmsg ! error message - integer, intent(out) :: errflg ! error flag - ! shared mode metadata + resolved renaming-pair tables (host-owned; passed in) - integer, intent(in) :: ntot_amode ! number of aerosol modes - integer, intent(in) :: npair_renamexf ! number of renaming pairs - integer, intent(in) :: modefrm_renamexf(:) ! source mode index per pair - integer, intent(in) :: modetoo_renamexf(:) ! destination mode index per pair - integer, intent(in) :: nspecfrm_renamexf(:) ! number of transferred species per pair - integer, intent(in) :: lspecfrma_renamexf(:,:) ! interstitial source species (pcnst-space) - integer, intent(in) :: lspecfrmc_renamexf(:,:) ! cloud-borne source species - integer, intent(in) :: lspectooa_renamexf(:,:) ! interstitial destination species - integer, intent(in) :: lspectooc_renamexf(:,:) ! cloud-borne destination species - real(r8), intent(in) :: alnsg_amode(:) ! ln(geometric std dev) of each mode - real(r8), intent(in) :: voltonumblo_amode(:) ! volume-to-number ratio, low limit - real(r8), intent(in) :: voltonumbhi_amode(:) ! volume-to-number ratio, high limit - real(r8), intent(in) :: dgnum_amode(:) ! nominal geometric mean diameter - integer, intent(in) :: nspec_amode(:) ! number of species in each mode - real(r8), intent(in) :: specmw_amode(:,:) ! species molecular weight - real(r8), intent(in) :: specdens_amode(:,:) ! species density - integer, intent(in) :: lmassptr_amode(:,:) ! interstitial mass pointer (pcnst-space) - integer, intent(in) :: lmassptrcw_amode(:,:) ! cloud-borne mass pointer - integer, intent(in) :: numptr_amode(:) ! interstitial number pointer - integer, intent(in) :: numptrcw_amode(:) ! cloud-borne number pointer - real(r8), intent(in) :: pi ! pi -! !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: -! RCE 07.04.13: Adapted from MIRAGE2 code -! -!EOP -!---------------------------------------------------------------------- -!BOC - -! local variables - integer, parameter :: ldiag1=-1 - integer :: i, icol_diag, ipair, iq, j, k, l, l1, la, lc, lunout - integer :: lsfrma, lsfrmc, lstooa, lstooc - integer :: mfrm, mtoo, n, n1, n2, ntot_msa_a - integer :: idomode(ntot_amode) - - real (r8) :: deldryvol_a(ncol,pver,ntot_amode) - real (r8) :: deldryvol_c(ncol,pver,ntot_amode) - real (r8) :: deltatinv - real (r8) :: dp_belowcut(maxpair_renamexf) - real (r8) :: dp_cut(maxpair_renamexf) - real (r8) :: dgn_aftr, dgn_xfer - real (r8) :: dgn_t_new, dgn_t_old - real (r8) :: dryvol_t_del, dryvol_t_new - real (r8) :: dryvol_t_old, dryvol_t_oldbnd - real (r8) :: dryvol_a(ncol,pver,ntot_amode) - real (r8) :: dryvol_c(ncol,pver,ntot_amode) - real (r8) :: dryvol_smallest(ntot_amode) - real (r8) :: dum - real (r8) :: dum3alnsg2(maxpair_renamexf) - real (r8) :: dum_m2v, dum_m2vdt - real (r8) :: factoraa(ntot_amode) - real (r8) :: factoryy(ntot_amode) - real (r8) :: frelax - real (r8) :: lndp_cut(maxpair_renamexf) - real (r8) :: lndgn_new, lndgn_old - real (r8) :: lndgv_new, lndgv_old - real (r8) :: num_t_old, num_t_oldbnd - real (r8) :: onethird - real (r8) :: pdel_fac - real (r8) :: tailfr_volnew, tailfr_volold - real (r8) :: tailfr_numnew, tailfr_numold - 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 - -! begin - lunout = iulog - errmsg = '' - errflg = 0 - ! intent(out): fully define before any early return - qsrflx(:,:,:) = 0.0_r8 - qqcwsrflx(:,:,:) = 0.0_r8 - -! -! calculations done once on initial entry -! -! "init" is now done through chem_init (and things under it) -! if (npair_renamexf .eq. -123456789) then -! npair_renamexf = 0 -! call modal_aero_rename_init -! end if - -! -! check if any renaming pairs exist -! - if (npair_renamexf .le. 0) return -! if (ncol .ne. -123456789) return -! if (fromwhere .eq. 'aqchem') return - -! -! compute aerosol dry-volume for the "from mode" of each renaming pair -! also compute dry-volume change during the continuous growth process -! using the incoming dqdt*deltat -! - deltatinv = 1.0_r8/(deltat*(1.0_r8 + 1.0e-15_r8)) - onethird = 1.0_r8/3.0_r8 - frelax = 27.0_r8 - xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps - - do n = 1, ntot_amode - idomode(n) = 0 - end do - - do ipair = 1, npair_renamexf - if (ipair .gt. 1) goto 8100 - idomode(modefrm_renamexf(ipair)) = 1 - - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - factoraa(mfrm) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mfrm)**2)) - factoraa(mtoo) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mtoo)**2)) - factoryy(mfrm) = sqrt( 0.5_r8 )/alnsg_amode(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_r8 - v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax - v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax - - dum3alnsg2(ipair) = 3.0_r8 * (alnsg_amode(mfrm)**2) - dp_cut(ipair) = sqrt( & - dgnum_amode(mfrm)*exp(1.5_r8*(alnsg_amode(mfrm)**2)) * & - dgnum_amode(mtoo)*exp(1.5_r8*(alnsg_amode(mtoo)**2)) ) - lndp_cut(ipair) = log( dp_cut(ipair) ) - dp_belowcut(ipair) = 0.99_r8*dp_cut(ipair) - end do - - do n = 1, ntot_amode - if (idomode(n) .gt. 0) then - dryvol_a(1:ncol,:,n) = 0.0_r8 - dryvol_c(1:ncol,:,n) = 0.0_r8 - deldryvol_a(1:ncol,:,n) = 0.0_r8 - deldryvol_c(1:ncol,:,n) = 0.0_r8 - do l1 = 1, nspec_amode(n) -! dum_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) -! [m3-AP/kmol-AP]= [kg-AP/kmol-AP] / [kg-AP/m3-AP] - dum_m2v = specmw_amode(l1,n) / specdens_amode(l1,n) - dum_m2vdt = dum_m2v*deltat - la = lmassptr_amode(l1,n)-loffset - if (la > 0) then - dryvol_a(1:ncol,:,n) = dryvol_a(1:ncol,:,n) & - + dum_m2v*max( 0.0_r8, & - q(1:ncol,:,la)-deltat*dqdt_other(1:ncol,:,la) ) - deldryvol_a(1:ncol,:,n) = deldryvol_a(1:ncol,:,n) & - + (dqdt_other(1:ncol,:,la) + dqdt(1:ncol,:,la))*dum_m2vdt - end if - - lc = lmassptrcw_amode(l1,n)-loffset - if (lc > 0) then - dryvol_c(1:ncol,:,n) = dryvol_c(1:ncol,:,n) & - + dum_m2v*max( 0.0_r8, & - qqcw(1:ncol,:,lc)-deltat*dqqcwdt_other(1:ncol,:,lc) ) - deldryvol_c(1:ncol,:,n) = deldryvol_c(1:ncol,:,n) & - + (dqqcwdt_other(1:ncol,:,lc) + & - dqqcwdt(1:ncol,:,lc))*dum_m2vdt - end if - end do - end if - end do - - - -! -! loop over levels and columns to calc the renaming -! -mainloop1_k: do k = 1, pver -mainloop1_i: do i = 1, ncol - -! if dorename_atik is provided, then check if renaming needed at this i,k - if (is_dorename_atik) then - if (.not. dorename_atik(i,k)) cycle mainloop1_i - end if - pdel_fac = pdel(i,k)/gravit - -! -! loop over renameing pairs -! -mainloop1_ipair: do ipair = 1, npair_renamexf - - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(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) - dryvol_t_old = dryvol_a(i,k,mfrm) + dryvol_c(i,k,mfrm) - dryvol_t_del = deldryvol_a(i,k,mfrm) + deldryvol_c(i,k,mfrm) - dryvol_t_new = dryvol_t_old + dryvol_t_del - dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) ) - -! no renaming if dryvol_t_new ~ 0 or dryvol_t_del ~ 0 - if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_ipair - if (dryvol_t_del .le. 1.0e-6_r8*dryvol_t_oldbnd) cycle mainloop1_ipair - -! num_t_old is total number in particles/kmol-air - num_t_old = q(i,k,numptr_amode(mfrm)-loffset) - num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset) - 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_amode(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 + dum3alnsg2(ipair) - yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm) - yv_tail = (lndp_cut(ipair) - 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 -! if dgn_t_new exceeds dp_cut, use the minimum of dgn_t_old and -! dp_belowcut to guarantee some transfer - if (dgn_t_new .ge. dp_cut(ipair)) then - dgn_t_old = min( dgn_t_old, dp_belowcut(ipair) ) - end if - lndgn_old = log( dgn_t_old ) - lndgv_old = lndgn_old + dum3alnsg2(ipair) - yn_tail = (lndp_cut(ipair) - lndgn_old)*factoryy(mfrm) - yv_tail = (lndp_cut(ipair) - 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 - dum = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_old - if (dum .le. 0.0_r8) cycle mainloop1_ipair - - xferfrac_vol = min( dum, 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 ) ) - -! -! compute tendencies for the renaming transfer -! - j = jsrflx_rename - do iq = 1, nspecfrm_renamexf(ipair) - xfercoef = xferfrac_vol*deltatinv - if (iq .eq. 1) xfercoef = xferfrac_num*deltatinv - - lsfrma = lspecfrma_renamexf(iq,ipair)-loffset - lsfrmc = lspecfrmc_renamexf(iq,ipair)-loffset - lstooa = lspectooa_renamexf(iq,ipair)-loffset - lstooc = lspectooc_renamexf(iq,ipair)-loffset - - if (lsfrma .gt. 0) then - xfertend = xfercoef*max( 0.0_r8, & - (q(i,k,lsfrma)+dqdt(i,k,lsfrma)*deltat) ) - -! diagnostic output start ---------------------------------------- - if (ldiag1 > 0) then - if ((i == icol_diag) .and. (mod(k-1,5) == 0)) then - if (lstooa .gt. 0) then - write(*,'(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(*,'(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 ------------------------------------------ - - - dqdt(i,k,lsfrma) = dqdt(i,k,lsfrma) - xfertend - qsrflx(i,lsfrma,j) = qsrflx(i,lsfrma,j) - xfertend*pdel_fac - if (lstooa .gt. 0) then - dqdt(i,k,lstooa) = dqdt(i,k,lstooa) + xfertend - qsrflx(i,lstooa,j) = qsrflx(i,lstooa,j) + xfertend*pdel_fac - end if - end if - - if (lsfrmc .gt. 0) then - xfertend = xfercoef*max( 0.0_r8, & - (qqcw(i,k,lsfrmc)+dqqcwdt(i,k,lsfrmc)*deltat) ) - dqqcwdt(i,k,lsfrmc) = dqqcwdt(i,k,lsfrmc) - xfertend - qqcwsrflx(i,lsfrmc,j) = qqcwsrflx(i,lsfrmc,j) - xfertend*pdel_fac - if (lstooc .gt. 0) then - dqqcwdt(i,k,lstooc) = dqqcwdt(i,k,lstooc) + xfertend - qqcwsrflx(i,lstooc,j) = qqcwsrflx(i,lstooc,j) + xfertend*pdel_fac - end if - end if - - end do ! "iq = 1, nspecfrm_renamexf(ipair)" - - - end do mainloop1_ipair - - - end do mainloop1_i - end do mainloop1_k - -! -! set dotend's -! - dotendrn(:) = .false. - dotendqqcwrn(:) = .false. - do ipair = 1, npair_renamexf - do iq = 1, nspecfrm_renamexf(ipair) - lsfrma = lspecfrma_renamexf(iq,ipair) - loffset - lsfrmc = lspecfrmc_renamexf(iq,ipair) - loffset - lstooa = lspectooa_renamexf(iq,ipair) - loffset - lstooc = lspectooc_renamexf(iq,ipair) - loffset - if (lsfrma .gt. 0) then - dotendrn(lsfrma) = .true. - if (lstooa .gt. 0) dotendrn(lstooa) = .true. - end if - if (lsfrmc .gt. 0) then - dotendqqcwrn(lsfrmc) = .true. - if (lstooc .gt. 0) dotendqqcwrn(lstooc) = .true. - end if - end do - end do - - - return - - -! -! error -- renaming currently just works for 1 pair -! -8100 write(lunout,9050) ipair - errflg = 1 - errmsg = 'modal_aero_rename_no_acc_crs_sub error' - return -9050 format( / '*** subr. modal_aero_rename_no_acc_crs_sub ***' / & - 4x, 'aerosol renaming not implemented for ipair =', i5 ) - -!EOC - end subroutine modal_aero_rename_no_acc_crs_sub - - - - subroutine modal_aero_rename_acc_crs_sub( & - ncol, & - loffset, deltat, & - pdel, troplev, & - dotendrn, q, & - dqdt, dqdt_other, & - dotendqqcwrn, qqcw, & - dqqcwdt, dqqcwdt_other, & - is_dorename_atik, dorename_atik, & - jsrflx_rename, nsrflx, & - qsrflx, qqcwsrflx, & - dqdt_rnpos, & - ntot_amode, npair_renamexf, & - modefrm_renamexf, modetoo_renamexf, & - nspecfrm_renamexf, & - lspecfrma_renamexf, lspecfrmc_renamexf, & - lspectooa_renamexf, lspectooc_renamexf, & - alnsg_amode, voltonumblo_amode, & - voltonumbhi_amode, dgnum_amode, & - nspec_amode, specmw_amode, & - specdens_amode, lmassptr_amode, & - lmassptrcw_amode, numptr_amode, & - numptrcw_amode, pi, & - modeptr_accum, modeptr_coarse, & - modeptr_stracoar, & - igrow_shrink_renamexf, & - ixferable_all_renamexf, & - ixferable_a_renamexf, ixferable_c_renamexf, & - strat_only_renamexf, & - pver, gravit, & - errmsg, errflg ) - -! !USES: - - use shr_spfn_mod, only: erfc => shr_spfn_erfc - -! !PARAMETERS: - integer, intent(in) :: ncol ! number of atmospheric column - integer, intent(in) :: loffset ! offset applied to modal aero "ptrs" - real(r8), intent(in) :: deltat ! time step (s) - integer, intent(in) :: troplev(:) - - real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: q(:,:,:) ! tracer mixing ratio array - ! *** MUST BE mol/mol-air or #/mol-air - ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(in) :: qqcw(:,:,:) ! like q but for cloud-borne species - - real(r8), intent(inout) :: dqdt(:,:,:) ! TMR tendency array; - ! incoming dqdt = tendencies for the - ! "fromwhere" continuous growth process - ! the renaming tendencies are added on - ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(inout) :: dqqcwdt(:,:,:) - real(r8), intent(in) :: dqdt_other(:,:,:) - ! tendencies for "other" continuous growth process - ! *** NOTE ncol and pcnstxx dimensions - real(r8), intent(in) :: dqqcwdt_other(:,:,:) - logical, intent(inout) :: dotendrn(:) ! identifies the species for which - ! renaming dqdt is computed - logical, intent(inout) :: dotendqqcwrn(:) - - logical, intent(in) :: is_dorename_atik ! true if dorename_atik is provided - logical, intent(in) :: dorename_atik(:,:) ! true if renaming should - ! be done at i,k - integer, intent(in) :: jsrflx_rename ! qsrflx index for renaming - integer, intent(in) :: nsrflx ! last dimension of qsrflx - - real(r8), intent(out) :: qsrflx(:,:,:) - ! process-specific column tracer tendencies - real(r8), intent(out) :: qqcwsrflx(:,:,:) - real(r8), intent(out) :: dqdt_rnpos(:,:,:) - ! the positive (production) part of the renaming tendency - - integer, intent(in) :: pver ! number of vertical levels - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - character(len=*), intent(out) :: errmsg ! error message - integer, intent(out) :: errflg ! error flag - ! shared mode metadata + resolved renaming-pair tables (host-owned; passed in) - integer, intent(in) :: ntot_amode ! number of aerosol modes - integer, intent(in) :: npair_renamexf ! number of renaming pairs - integer, intent(in) :: modefrm_renamexf(:) ! source mode index per pair - integer, intent(in) :: modetoo_renamexf(:) ! destination mode index per pair - integer, intent(in) :: nspecfrm_renamexf(:) ! number of transferred species per pair - integer, intent(in) :: lspecfrma_renamexf(:,:) ! interstitial source species (pcnst-space) - integer, intent(in) :: lspecfrmc_renamexf(:,:) ! cloud-borne source species - integer, intent(in) :: lspectooa_renamexf(:,:) ! interstitial destination species - integer, intent(in) :: lspectooc_renamexf(:,:) ! cloud-borne destination species - real(r8), intent(in) :: alnsg_amode(:) ! ln(geometric std dev) of each mode - real(r8), intent(in) :: voltonumblo_amode(:) ! volume-to-number ratio, low limit - real(r8), intent(in) :: voltonumbhi_amode(:) ! volume-to-number ratio, high limit - real(r8), intent(in) :: dgnum_amode(:) ! nominal geometric mean diameter - integer, intent(in) :: nspec_amode(:) ! number of species in each mode - real(r8), intent(in) :: specmw_amode(:,:) ! species molecular weight - real(r8), intent(in) :: specdens_amode(:,:) ! species density - integer, intent(in) :: lmassptr_amode(:,:) ! interstitial mass pointer (pcnst-space) - integer, intent(in) :: lmassptrcw_amode(:,:) ! cloud-borne mass pointer - integer, intent(in) :: numptr_amode(:) ! interstitial number pointer - integer, intent(in) :: numptrcw_amode(:) ! cloud-borne number pointer - real(r8), intent(in) :: pi ! pi - ! accum-coarse-exchange path flags (host-owned; passed in) - integer, intent(in) :: modeptr_accum ! accumulation mode index - integer, intent(in) :: modeptr_coarse ! coarse mode index - integer, intent(in) :: modeptr_stracoar ! stratospheric coarse mode index - integer, intent(in) :: igrow_shrink_renamexf(:) ! +1 growing / -1 shrinking per pair - integer, intent(in) :: ixferable_all_renamexf(:) ! all-species-transferable flag per pair - integer, intent(in) :: ixferable_a_renamexf(:,:) ! per-species interstitial transferable flag - integer, intent(in) :: ixferable_c_renamexf(:,:) ! per-species cloud-borne transferable flag - logical, intent(in) :: strat_only_renamexf(:) ! restrict renaming to the stratosphere -! !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: -! RCE 07.04.13: Adapted from MIRAGE2 code -! -!EOP -!---------------------------------------------------------------------- -!BOC - -! local variables - integer, parameter :: ldiag1 = -1 - integer :: i, icol_diag, ipair, iq - integer :: j, k - integer :: l, l1, la, lc, lunout - integer :: lsfrma, lsfrmc, lstooa, lstooc - integer :: mfrm, mtoo, n, n1, n2, ntot_msa_a - - logical :: l_dqdt_rnpos - logical :: flagaa_shrink, flagbb_shrink - - real (r8) :: deldryvol_a(ncol,pver) - real (r8) :: deldryvol_c(ncol,pver) - real (r8) :: deltatinv - real (r8) :: dgn_aftr, dgn_xfer - real (r8) :: dgn_t_new, dgn_t_old, dgn_t_oldb - real (r8) :: dryvol_t_del, dryvol_t_new, dryvol_t_new_xfab - real (r8) :: dryvol_t_old, dryvol_t_oldb, dryvol_t_oldbnd - real (r8) :: dryvol_a(ncol,pver) - real (r8) :: dryvol_c(ncol,pver) - real (r8) :: dryvol_a_xfab(ncol,pver) - real (r8) :: dryvol_c_xfab(ncol,pver) - real (r8) :: dryvol_xferamt - real (r8) :: lndgn_new, lndgn_old - real (r8) :: lndgv_new, lndgv_old - real (r8) :: num_t_old, num_t_oldbnd - real (r8) :: onethird - real (r8) :: pdel_fac - real (r8) :: tailfr_volnew, tailfr_volold - real (r8) :: tailfr_numnew, tailfr_numold - real (r8) :: tmpa, tmpf - real (r8) :: tmp_m2v, tmp_m2vdt - real (r8) :: xfercoef, xfertend - real (r8) :: xferfrac_vol, xferfrac_num, xferfrac_max - - real (r8) :: yn_tail, yv_tail - -! begin - lunout = iulog - errmsg = '' - errflg = 0 - ! intent(out): fully define before any early return - qsrflx(:,:,:) = 0.0_r8 - qqcwsrflx(:,:,:) = 0.0_r8 - -! -! calculations done once on initial entry -! -! "init" is now done through chem_init (and things under it) -! if (npair_renamexf .eq. -123456789) then -! npair_renamexf = 0 -! call modal_aero_rename_init -! end if - -! -! check if any renaming pairs exist -! - if (npair_renamexf .le. 0) return -! if (ncol .ne. -123456789) return -! if (fromwhere .eq. 'aqchem') return - - - deltatinv = 1.0_r8/(deltat*(1.0_r8 + 1.0e-15_r8)) - onethird = 1.0_r8/3.0_r8 - xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps - - ! dqdt_rnpos is now a required output; always produced. - l_dqdt_rnpos = .true. - dqdt_rnpos(:,:,:) = 0.0_r8 - - - -! -! loop over renaming pairs -! -mainloop1_ipair: do ipair = 1, npair_renamexf - - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - - flagaa_shrink = & - ((mfrm==modeptr_coarse) .and. (mtoo==modeptr_accum)) .or. & - ((mfrm==modeptr_stracoar) .and. (mtoo==modeptr_accum)) - -! -! compute aerosol dry-volume for the "from mode" of each renaming pair -! also compute dry-volume change during the continuous growth process -! using the incoming dqdt*deltat -! - dryvol_a(:,:) = 0.0_r8 - dryvol_c(:,:) = 0.0_r8 - deldryvol_a(:,:) = 0.0_r8 - deldryvol_c(:,:) = 0.0_r8 - if (ixferable_all_renamexf(ipair) <= 0) then - dryvol_a_xfab(:,:) = 0.0_r8 - dryvol_c_xfab(:,:) = 0.0_r8 - end if - - n = mfrm - do l1 = 1, nspec_amode(n) -! tmp_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) -! [m3-AP/kmol-AP]= [kg-AP/kmol-AP] / [kg-AP/m3-AP] - tmp_m2v = specmw_amode(l1,n) / specdens_amode(l1,n) - tmp_m2vdt = tmp_m2v*deltat - la = lmassptr_amode(l1,n)-loffset - if (la > 0) then - dryvol_a(1:ncol,:) = dryvol_a(1:ncol,:) & - + tmp_m2v*max( 0.0_r8, & - q(1:ncol,:,la)-deltat*dqdt_other(1:ncol,:,la) ) - deldryvol_a(1:ncol,:) = deldryvol_a(1:ncol,:) & - + (dqdt_other(1:ncol,:,la) + dqdt(1:ncol,:,la))*tmp_m2vdt - if ( (ixferable_all_renamexf(ipair) <= 0) .and. & - (ixferable_a_renamexf(l1,ipair) > 0) ) then - dryvol_a_xfab(1:ncol,:) = dryvol_a_xfab(1:ncol,:) & - + tmp_m2v*max( 0.0_r8, & - q(1:ncol,:,la)+deltat*dqdt(1:ncol,:,la) ) - end if - end if - - lc = lmassptrcw_amode(l1,n)-loffset - if (lc > 0) then - dryvol_c(1:ncol,:) = dryvol_c(1:ncol,:) & - + tmp_m2v*max( 0.0_r8, & - qqcw(1:ncol,:,lc)-deltat*dqqcwdt_other(1:ncol,:,lc) ) - deldryvol_c(1:ncol,:) = deldryvol_c(1:ncol,:) & - + (dqqcwdt_other(1:ncol,:,lc) + & - dqqcwdt(1:ncol,:,lc))*tmp_m2vdt - if ( (ixferable_all_renamexf(ipair) <= 0) .and. & - (ixferable_c_renamexf(l1,ipair) > 0) ) then - dryvol_c_xfab(1:ncol,:) = dryvol_c_xfab(1:ncol,:) & - + tmp_m2v*max( 0.0_r8, & - qqcw(1:ncol,:,lc)+deltat*dqqcwdt(1:ncol,:,lc) ) - end if - end if - end do - -! -! -! loop over levels and columns to calc the renaming -! -! -mainloop1_k: do k = 1, pver -mainloop1_i: do i = 1, ncol - -! if dorename_atik is provided, then check if renaming needed at this i,k - if (is_dorename_atik) then - if (.not. dorename_atik(i,k)) cycle mainloop1_i - end if - -! if strat_only_renamexf is true, then cycle when at or below the tropopause level - if ( strat_only_renamexf(ipair) ) then - if ( k >= troplev(i) ) cycle mainloop1_i - end if - - -! 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) - dryvol_t_old = dryvol_a(i,k) + dryvol_c(i,k) - dryvol_t_del = deldryvol_a(i,k) + deldryvol_c(i,k) - dryvol_t_new = dryvol_t_old + dryvol_t_del - dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) ) - -grow_shrink_conditional1: & - if (igrow_shrink_renamexf(ipair) > 0) then -! do renaming for growing particles - -! no renaming if dryvol_t_new ~ 0 - if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_i -! no renaming if delta_dryvol is very small or negative - if ( (method_optbb_renamexf /= 2) .and. & - (dryvol_t_del .le. 1.0e-6_r8*dryvol_t_oldbnd) ) cycle mainloop1_i - -! num_t_old is total number in particles/kmol-air - num_t_old = q(i,k,numptr_amode(mfrm)-loffset) - num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset) - 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 ) - -! compute new dgnum - dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird -! no renaming if dgn_t_new < threshold value - if (dgn_t_new .le. dp_xfernone_threshaa(ipair)) cycle mainloop1_i - -! compute old dgnum and possibly a smaller value to get more renaming transfer - dgn_t_old = & - (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird - dgn_t_oldb = dgn_t_old - dryvol_t_oldb = dryvol_t_old - if ( method_optbb_renamexf == 2) then - if (dgn_t_old .ge. dp_cut(ipair)) then - ! this revised volume corresponds to dgn_t_old == dp_belowcut, and same number conc - dryvol_t_oldb = dryvol_t_old * (dp_belowcut(ipair)/dgn_t_old)**3 - dgn_t_oldb = dp_belowcut(ipair) - end if - if (dgn_t_new .lt. dp_xferall_thresh(ipair)) then - ! no renaming if delta_dryvol is very small or negative - if ((dryvol_t_new-dryvol_t_oldb) .le. 1.0e-6_r8*dryvol_t_oldbnd) cycle mainloop1_i - end if - - else if (dgn_t_new .ge. dp_cut(ipair)) then -! if dgn_t_new exceeds dp_cut, use the minimum of dgn_t_oldb and -! dp_belowcut to guarantee some transfer - dgn_t_oldb = min( dgn_t_oldb, dp_belowcut(ipair) ) - end if - -! compute new fraction of number and mass in the tail (dp > dp_cut) - lndgn_new = log( dgn_t_new ) - lndgv_new = lndgn_new + factor_3alnsg2(ipair) - yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm) - yv_tail = (lndp_cut(ipair) - 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) - lndgn_old = log( dgn_t_oldb ) - lndgv_old = lndgn_old + factor_3alnsg2(ipair) - yn_tail = (lndp_cut(ipair) - lndgn_old)*factoryy(mfrm) - yv_tail = (lndp_cut(ipair) - 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 - if ( (method_optbb_renamexf == 2) .and. & - (dgn_t_new .ge. dp_xferall_thresh(ipair)) ) then - dryvol_xferamt = dryvol_t_new - else - dryvol_xferamt = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_oldb - end if - if (dryvol_xferamt .le. 0.0_r8) cycle mainloop1_i - - xferfrac_vol = max( 0.0_r8, (dryvol_xferamt/dryvol_t_new) ) - if ( method_optbb_renamexf == 2 .and. & - (xferfrac_vol >= xferfrac_max) ) then - ! transfer entire contents of mode - xferfrac_vol = 1.0_r8 - xferfrac_num = 1.0_r8 - else - xferfrac_vol = min( xferfrac_vol, xferfrac_max ) - xferfrac_num = tailfr_numnew - tailfr_numold - xferfrac_num = max( 0.0_r8, min( xferfrac_num, xferfrac_vol ) ) - end if - - if (ixferable_all_renamexf(ipair) <= 0) then - ! not all species are xferable - dryvol_t_new_xfab = max( 0.0_r8, (dryvol_a_xfab(i,k) + dryvol_c_xfab(i,k)) ) - dryvol_xferamt = xferfrac_vol*dryvol_t_new - if (dryvol_t_new_xfab >= 0.999999_r8*dryvol_xferamt) then - ! xferable dryvol can supply the needed dryvol_xferamt - ! but xferfrac_vol must be increased - xferfrac_vol = min( 1.0_r8, (dryvol_xferamt/dryvol_t_new_xfab) ) - else if (dryvol_t_new_xfab >= 1.0e-7_r8*dryvol_xferamt) then - ! xferable dryvol cannot supply the needed dryvol_xferamt - ! so transfer all of it, and reduce the number transfer - xferfrac_vol = 1.0_r8 - xferfrac_num = xferfrac_num*(dryvol_t_new_xfab/dryvol_xferamt) - else - ! xferable dryvol << needed dryvol_xferamt - cycle mainloop1_i - end if - end if - - else grow_shrink_conditional1 -! do renaming for shrinking particles - -! no renaming if (dryvol_t_old ~ 0) - if (dryvol_t_old .le. dryvol_smallest(mfrm)) cycle mainloop1_i - -! when (delta_dryvol is very small or positive), -! which means particles are not evaporating, -! only do renaming if [(flagaa_shrink true) and (in stratosphere)]], -! and set flagbb_shrink true to identify this special case - if (dryvol_t_del .ge. -1.0e-6_r8*dryvol_t_oldbnd) then - if ( ( flagaa_shrink ) .and. ( k < troplev(i) ) ) then - flagbb_shrink = .true. - else - cycle mainloop1_i - end if - else - flagbb_shrink = .false. - end if - -! num_t_old is total number in particles/kmol-air - num_t_old = q(i,k,numptr_amode(mfrm)-loffset) - num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset) - 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 ) - -! compute new dgnum - dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird -! no renaming if (dgn_t_new > xfernone threshold value) - if (dgn_t_new .ge. dp_xfernone_threshaa(ipair)) cycle mainloop1_i -! if (flagbb_shrink true), renaming only when (dgn_t_new <= dp_cut value) - if ( flagbb_shrink ) then - if (dgn_t_new .gt. dp_cut(ipair)) cycle mainloop1_i - end if - - if ( dgn_t_new .le. dp_xferall_thresh(ipair) ) then -! special case of (dgn_t_new <= xferall threshold value) - tailfr_numnew = 1.0_r8 - tailfr_volnew = 1.0_r8 - else -! compute new fraction of number and mass in the tail (dp < dp_cut) - lndgn_new = log( dgn_t_new ) - lndgv_new = lndgn_new + factor_3alnsg2(ipair) - yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm) - yv_tail = (lndp_cut(ipair) - lndgv_new)*factoryy(mfrm) - tailfr_numnew = 1.0_r8 - 0.5_r8*erfc( yn_tail ) - tailfr_volnew = 1.0_r8 - 0.5_r8*erfc( yv_tail ) - end if - -! compute old dgnum - dgn_t_old = & - (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird - dgn_t_oldb = dgn_t_old - dryvol_t_oldb = dryvol_t_old - -! no need to compute old fraction of number and mass in the tail - tailfr_numold = 0.0_r8 - tailfr_volold = 0.0_r8 - -! transfer fraction is new tail-fraction - xferfrac_vol = tailfr_volnew - if (xferfrac_vol .le. 0.0_r8) cycle mainloop1_i - xferfrac_num = tailfr_numnew - - if (xferfrac_vol >= xferfrac_max) then - ! transfer entire contents of mode - xferfrac_vol = 1.0_r8 - xferfrac_num = 1.0_r8 - else - xferfrac_vol = min( xferfrac_vol, xferfrac_max ) -! transfer fraction for number cannot be less than that of volume - xferfrac_num = max( xferfrac_num, xferfrac_vol ) - xferfrac_num = min( xferfrac_max, xferfrac_num ) - end if - - if (ixferable_all_renamexf(ipair) <= 0) then - ! not all species are xferable - dryvol_t_new_xfab = max( 0.0_r8, (dryvol_a_xfab(i,k) + dryvol_c_xfab(i,k)) ) - dryvol_xferamt = xferfrac_vol*dryvol_t_new - if (dryvol_t_new_xfab >= 0.999999_r8*dryvol_xferamt) then - ! xferable dryvol can supply the needed dryvol_xferamt - ! but xferfrac_vol must be increased - xferfrac_vol = min( 1.0_r8, (dryvol_xferamt/dryvol_t_new_xfab) ) - else if (dryvol_t_new_xfab >= 1.0e-7_r8*dryvol_xferamt) then - ! xferable dryvol cannot supply the needed dryvol_xferamt - ! so transfer all of it, and reduce the number transfer - xferfrac_vol = 1.0_r8 - xferfrac_num = xferfrac_num*(dryvol_t_new_xfab/dryvol_xferamt) - else - ! xferable dryvol << needed dryvol_xferamt - cycle mainloop1_i - end if - end if - - endif grow_shrink_conditional1 - -! -! compute tendencies for the renaming transfer -! - pdel_fac = pdel(i,k)/gravit - j = jsrflx_rename - do iq = 1, nspecfrm_renamexf(ipair) - xfercoef = xferfrac_vol*deltatinv - if (iq .eq. 1) xfercoef = xferfrac_num*deltatinv - - lsfrma = lspecfrma_renamexf(iq,ipair)-loffset - lsfrmc = lspecfrmc_renamexf(iq,ipair)-loffset - lstooa = lspectooa_renamexf(iq,ipair)-loffset - lstooc = lspectooc_renamexf(iq,ipair)-loffset - - if (lsfrma .gt. 0) then - xfertend = xfercoef*max( 0.0_r8, & - (q(i,k,lsfrma)+dqdt(i,k,lsfrma)*deltat) ) - -! diagnostic output start ---------------------------------------- - if (ldiag1 > 0) then - if ((i == icol_diag) .and. (mod(k-1,5) == 0)) then - if (lstooa .gt. 0) then - write(iulog,'(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(iulog,'(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 ------------------------------------------ - - - dqdt(i,k,lsfrma) = dqdt(i,k,lsfrma) - xfertend - qsrflx(i,lsfrma,j) = qsrflx(i,lsfrma,j) - xfertend*pdel_fac - if (lstooa .gt. 0) then - dqdt(i,k,lstooa) = dqdt(i,k,lstooa) + xfertend - qsrflx(i,lstooa,j) = qsrflx(i,lstooa,j) + xfertend*pdel_fac - if ( l_dqdt_rnpos ) & - dqdt_rnpos(i,k,lstooa) = dqdt_rnpos(i,k,lstooa) + xfertend - end if - end if - - if (lsfrmc .gt. 0) then - xfertend = xfercoef*max( 0.0_r8, & - (qqcw(i,k,lsfrmc)+dqqcwdt(i,k,lsfrmc)*deltat) ) - dqqcwdt(i,k,lsfrmc) = dqqcwdt(i,k,lsfrmc) - xfertend - qqcwsrflx(i,lsfrmc,j) = qqcwsrflx(i,lsfrmc,j) - xfertend*pdel_fac - if (lstooc .gt. 0) then - dqqcwdt(i,k,lstooc) = dqqcwdt(i,k,lstooc) + xfertend - qqcwsrflx(i,lstooc,j) = qqcwsrflx(i,lstooc,j) + xfertend*pdel_fac - end if - end if - - end do ! "iq = 1, nspecfrm_renamexf(ipair)" - - - end do mainloop1_i - end do mainloop1_k - - - end do mainloop1_ipair - -! -! set dotend's -! - dotendrn(:) = .false. - dotendqqcwrn(:) = .false. - do ipair = 1, npair_renamexf - do iq = 1, nspecfrm_renamexf(ipair) - lsfrma = lspecfrma_renamexf(iq,ipair) - loffset - lsfrmc = lspecfrmc_renamexf(iq,ipair) - loffset - lstooa = lspectooa_renamexf(iq,ipair) - loffset - lstooc = lspectooc_renamexf(iq,ipair) - loffset - if (lsfrma .gt. 0) then - dotendrn(lsfrma) = .true. - if (lstooa .gt. 0) dotendrn(lstooa) = .true. - end if - if (lsfrmc .gt. 0) then - dotendqqcwrn(lsfrmc) = .true. - if (lstooc .gt. 0) dotendqqcwrn(lstooc) = .true. - end if - end do - end do - - - return - - -! -! error -- renaming currently just works for 1 pair -! -8100 write(lunout,9050) ipair - errflg = 1 - errmsg = 'modal_aero_rename_acc_crs_sub error' - return -9050 format( / '*** subr. modal_aero_rename_acc_crs_sub ***' / & - 4x, 'aerosol renaming not implemented for ipair =', i5 ) - - end subroutine modal_aero_rename_acc_crs_sub -end module modal_aero_rename diff --git a/src/chemistry/modal_aero/modal_dust_emissions.F90 b/src/chemistry/modal_aero/modal_dust_emissions.F90 deleted file mode 100644 index fc7587f68f..0000000000 --- a/src/chemistry/modal_aero/modal_dust_emissions.F90 +++ /dev/null @@ -1,138 +0,0 @@ -!=============================================================================== -! Dust emissions for the Modal Aerosol Model -! Portable science routines split from modal_aero/dust_model.F90: selection -! of the emitted dust size distribution, and rebinning of the coupler dust -! flux into modal mass and number surface fluxes. -! Host constants and index maps are passed as arguments; array sizing is by -! runtime ncol. -!=============================================================================== -module modal_dust_emissions - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - - public :: modal_dust_emissions_init - public :: modal_dust_emissions_run - -contains - - !============================================================================= - ! Set the emitted dust size distribution (per-bin mass fractions) and the - ! bin mass-weighted diameters used for the number flux conversion. - !============================================================================= - subroutine modal_dust_emissions_init( ntot_amode, dust_nbin, pi, rair, gravit, & - dust_emis_sclfctr, dust_dmt_vwr, errmsg, errflg ) - use dust_common, only: dust_set_params - - integer, intent(in) :: ntot_amode ! number of aerosol modes - integer, intent(in) :: dust_nbin ! number of dust bins (mass species) - real(r8), intent(in) :: pi ! host model constants - real(r8), intent(in) :: rair ! gas constant for dry air (J/K/kg) - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - real(r8), intent(out) :: dust_emis_sclfctr(:) ! mass fraction of emissions per bin - real(r8), intent(out) :: dust_dmt_vwr(:) ! mass-weighted diameter per bin (m) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real(r8) :: dust_dmt_grd(dust_nbin+1) ! bin diameter edges (m) - real(r8) :: dust_stk_crc(dust_nbin) ! Stokes correction from dust_set_params; unused by emissions - - errmsg = '' - errflg = 0 - - ! dmleung edited the mass fraction of the emitted dust size distribution. 27 Oct 2025 ++ - ! The new mass fraction comes from Jun Meng et al. (2022) and MERRA-2. - ! Jun Meng's table indicates 2.1 % mass for 0.1-1 um and 97.9 % mass for 1-10 um. - ! ref: https://zenodo.org/records/6344524 - ! MERRA-2 dust emissions indicate 6 % mass for 0.1-1 um (bin1) and 94 % for 1-10 um (bin2-5). - ! dmleung adopts 2.1 % mass for 0.1-1 um and 97.9 % mass for 1-10 um for dust. - ! Distributing more mass to accumulation mode allows a longer lifetime of dust, reducing - ! low dust biases over remote oceans and reducing high dust biases over the Sahara. - ! This change impacts both Zender_2003 dust and Leung_2023 dust. - if ( ntot_amode == 3 ) then - dust_dmt_grd(:) = (/ 0.1e-6_r8, 1.0e-6_r8, 10.0e-6_r8/) - dust_emis_sclfctr(:) = (/ 0.021_r8,0.979_r8 /) - elseif ( ntot_amode == 4 .or. ntot_amode == 5 ) then - dust_dmt_grd(:) = (/ 0.01e-6_r8, 0.1e-6_r8, 1.0e-6_r8, 10.0e-6_r8 /) - dust_emis_sclfctr(:) = (/ 1.65E-05_r8, 0.021_r8, 0.979_r8 /) - else if( ntot_amode == 7 ) then - dust_dmt_grd(:) = (/ 0.1e-6_r8, 2.0e-6_r8, 10.0e-6_r8/) - dust_emis_sclfctr(:) = (/ 0.12_r8, 0.88_r8 /) - endif - ! dmleung -- - - call dust_set_params( nbin=dust_nbin, dmt_grd=dust_dmt_grd, & - dmt_vwr=dust_dmt_vwr, stk_crc=dust_stk_crc, & - pi=pi, rair=rair, gravit=gravit, & - errmsg=errmsg, errflg=errflg ) - - end subroutine modal_dust_emissions_init - - !=============================================================================== - ! Rebin and adjust the incoming coupler dust flux into per-bin mass and - ! number surface fluxes. - !=============================================================================== - subroutine modal_dust_emissions_run( ncol, dust_nbin, dust_indices, dust_emis_sclfctr, & - dust_dmt_vwr, dust_emis_fact, & - zender_soil_erod_from_atm, soil_erodibility, & - dust_flux_in, pi, cflx, soil_erod ) - use dust_common, only: dust_density - - ! args - integer, intent(in) :: ncol - integer, intent(in) :: dust_nbin ! number of dust bins (mass species) - integer, intent(in) :: dust_indices(:) ! constituent indices: mass bins, then number bins - real(r8), intent(in) :: dust_emis_sclfctr(:) ! mass fraction of emissions per bin - real(r8), intent(in) :: dust_dmt_vwr(:) ! mass-weighted diameter per bin (m) - real(r8), intent(in) :: dust_emis_fact ! tuning parameter for dust emissions - logical, intent(in) :: zender_soil_erod_from_atm ! Zender_2003 with soil erodibility applied in atm - real(r8), intent(in) :: soil_erodibility(:) ! soil erodibility factor (used only when - ! zender_soil_erod_from_atm) - real(r8), intent(in) :: dust_flux_in(:,:) ! dust fluxes from the coupler (kg/m2/s, negative down) - real(r8), intent(in) :: pi - real(r8), intent(inout) :: cflx(:,:) ! constituent surface fluxes (kg/m2/s) - real(r8), intent(out) :: soil_erod(:) ! thresholded soil erodibility - ! (not set on the Leung_2023 branch) - - ! local vars - integer :: i, m, idst, inum - real(r8) :: x_mton - real(r8),parameter :: soil_erod_threshold = 0.1_r8 - - ! set dust emissions - - if (zender_soil_erod_from_atm) then ! Zender_2003 dust emissions - col_loop1: do i = 1,ncol - soil_erod(i) = soil_erodibility(i) - if( soil_erod(i) .lt. soil_erod_threshold ) soil_erod(i) = 0._r8 - - ! rebin and adjust dust emissons. - do m = 1,dust_nbin - idst = dust_indices(m) - cflx(i,idst) = sum( -dust_flux_in(i,:) ) & - * dust_emis_sclfctr(m)*soil_erod(i)/dust_emis_fact*1.15_r8 - x_mton = 6._r8 / (pi * dust_density * (dust_dmt_vwr(m)**3._r8)) - inum = dust_indices(m+dust_nbin) - cflx(i,inum) = cflx(i,idst)*x_mton - enddo - enddo col_loop1 - else ! Leung_2023 dust emissions - - col_loop2: do i = 1,ncol - ! rebin and adjust dust emissons. - do m = 1,dust_nbin - idst = dust_indices(m) - - cflx(i,idst) = sum( -dust_flux_in(i,:) ) & - * dust_emis_sclfctr(m) / dust_emis_fact - x_mton = 6._r8 / (pi * dust_density * (dust_dmt_vwr(m)**3._r8)) - inum = dust_indices(m+dust_nbin) - cflx(i,inum) = cflx(i,idst)*x_mton - enddo - enddo col_loop2 - end if - - end subroutine modal_dust_emissions_run - -end module modal_dust_emissions diff --git a/src/chemistry/modal_aero/modal_seasalt_emissions.F90 b/src/chemistry/modal_aero/modal_seasalt_emissions.F90 deleted file mode 100644 index 9fd5d9ddb6..0000000000 --- a/src/chemistry/modal_aero/modal_seasalt_emissions.F90 +++ /dev/null @@ -1,98 +0,0 @@ -!=============================================================================== -! Sea salt emissions for the Modal Aerosol Model -! Portable science routine split from modal_aero/seasalt_model.F90, plus the -! 10 m wind extrapolation moved from modal_aero/aero_model.F90: sea salt -! section number fluxes accumulated into modal number and mass surface -! fluxes over the ocean fraction. -! Host constants and index maps are passed as arguments; array sizing is by -! runtime ncol. -!=============================================================================== -module modal_seasalt_emissions - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - - public :: modal_seasalt_emissions_run - - ! Sea salt aerosol material density used for the number-to-mass flux - ! conversion (value from CAM mo_constants). - real(r8), parameter :: seasalt_density = 2.2e+3_r8 ! [kg m-3] - -contains - - !============================================================================= - !============================================================================= - subroutine modal_seasalt_emissions_run( ncol, nslt, seasalt_indices, emis_scale, & - u_bottom, v_bottom, zmid_bottom, & - srf_temp, ocnfrc, pi, cflx ) - - use sslt_sections, only: nsections, fluxes, Dg, rdry - - ! dummy arguments - integer, intent(in) :: ncol - integer, intent(in) :: nslt ! number of seasalt bins (mass species) - integer, intent(in) :: seasalt_indices(:) ! constituent indices: mass bins, then number bins - real(r8), intent(in) :: emis_scale ! sea salt emission tuning factor - real(r8), intent(in) :: u_bottom(:) ! bottom layer zonal wind (m/s) - real(r8), intent(in) :: v_bottom(:) ! bottom layer meridional wind (m/s) - real(r8), intent(in) :: zmid_bottom(:) ! bottom layer midpoint geopotential height above surface (m) - real(r8), intent(in) :: srf_temp(:) ! sea surface temperature (K) - real(r8), intent(in) :: ocnfrc(:) ! ocean fraction - real(r8), intent(in) :: pi - real(r8), intent(inout) :: cflx(:,:) ! constituent surface fluxes (kg/m2/s or #/m2/s) - - ! local vars - integer :: mn, mm, ibin, i - real(r8) :: fi(ncol,nsections) - real(r8) :: u10cubed(ncol) - real (r8), parameter :: z0=0.0001_r8 ! m roughness length over oceans--from ocean model - - real(r8) :: sst_sz_range_lo (nslt) - real(r8) :: sst_sz_range_hi (nslt) - - u10cubed(:ncol)=sqrt(u_bottom(:ncol)**2+v_bottom(:ncol)**2) - - ! move the winds to 10m high from the midpoint of the gridbox: - ! follows Tie and Seinfeld and Pandis, p.859 with math. - - u10cubed(:ncol)=u10cubed(:ncol)*log(10._r8/z0)/log(zmid_bottom(:ncol)/z0) - - ! we need them to the 3.41 power, according to Gong et al., 1997: - u10cubed(:ncol)=u10cubed(:ncol)**3.41_r8 - - if (nslt==4) then - sst_sz_range_lo (:) = (/ 0.08e-6_r8, 0.02e-6_r8, 0.3e-6_r8, 1.0e-6_r8 /) ! accu, aitken, fine, coarse - sst_sz_range_hi (:) = (/ 0.3e-6_r8, 0.08e-6_r8, 1.0e-6_r8, 10.0e-6_r8 /) - else if (nslt==3) then - sst_sz_range_lo (:) = (/ 0.08e-6_r8, 0.02e-6_r8, 1.0e-6_r8 /) ! accu, aitken, coarse - sst_sz_range_hi (:) = (/ 1.0e-6_r8, 0.08e-6_r8, 10.0e-6_r8 /) - endif - - fi(:ncol,:nsections) = fluxes( srf_temp, u10cubed, ncol ) - - do ibin = 1,nslt - mm = seasalt_indices(ibin) - mn = seasalt_indices(nslt+ibin) - - if (mn>0) then - do i=1, nsections - if (Dg(i).ge.sst_sz_range_lo(ibin) .and. Dg(i).lt.sst_sz_range_hi(ibin)) then - cflx(:ncol,mn)=cflx(:ncol,mn)+fi(:ncol,i)*ocnfrc(:ncol)*emis_scale !++ ag: scale sea-salt - endif - enddo - endif - - cflx(:ncol,mm)=0.0_r8 - do i=1, nsections - if (Dg(i).ge.sst_sz_range_lo(ibin) .and. Dg(i).lt.sst_sz_range_hi(ibin)) then - cflx(:ncol,mm)=cflx(:ncol,mm)+fi(:ncol,i)*ocnfrc(:ncol)*emis_scale & !++ ag: scale sea-salt - *4._r8/3._r8*pi*rdry(i)**3*seasalt_density ! should use dry size, convert from number to mass flux (kg/m2/s) - endif - enddo - - enddo - - end subroutine modal_seasalt_emissions_run - -end module modal_seasalt_emissions diff --git a/src/chemistry/utils/modal_aero_calcsize.F90 b/src/chemistry/utils/modal_aero_calcsize.F90 deleted file mode 100644 index 3073f3d900..0000000000 --- a/src/chemistry/utils/modal_aero_calcsize.F90 +++ /dev/null @@ -1,1134 +0,0 @@ -! Portable science module for modal aerosol size calculation. -! RCE 07.04.13: Adapted from MIRAGE2 code -module modal_aero_calcsize - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - - public :: modal_aero_calcsize_run - public :: modal_aero_calcsize_diag_run - public :: modal_aero_calcdry_run - - integer, public, parameter :: calcsize_nsrflx = 4 - -contains - -subroutine modal_aero_calcsize_run( & - ncol, pver, deltat, top_lev, & - ntot_amode, nspec_amode, nspec_max, & - dgnum_amode, dgnumlo_amode, dgnumhi_amode, & - alnsg_amode, voltonumb_amode, voltonumblo_amode, voltonumbhi_amode, & - specdens_amode, & - mprognum_amode, & - modeptr_aitken, modeptr_accum, & - lmassptr_amode, numptr_amode, & - lmassptrcw_amode, numptrcw_amode, & - pdel, & - gravit, pi, & - num_q, & - q, q_cw, & - do_adjust, do_aitacc_transfer, & - npair_renamexf, & - nspecfrm_renamexf, & - modefrm_renamexf, modetoo_renamexf, & - lspecfrma_renamexf, lspectooa_renamexf, & - lspecfrmc_renamexf, lspectooc_renamexf, & - dgncur_a, & - dqdt, dqdt_cw, & - dotend, dotend_cw, & - qsrflx, & - errmsg, errflg) - - !----------------------------------------------------------------------- - ! - ! Calculates aerosol size distribution parameters - ! mprognum_amode > 0 - ! calculate Dgnum from mass, number, and fixed sigmag - ! mprognum_amode <= 0 - ! calculate number from mass, fixed Dgnum, and fixed sigmag - ! - ! Also (optionally) adjusts prognostic number to - ! be within bounds determined by mass, Dgnum bounds, and sigma bounds - ! - ! Author: R. Easter - ! - !----------------------------------------------------------------------- - - ! Grid and time arguments - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: pver ! number of vertical levels - real(r8), intent(in) :: deltat ! model time-step size (s) - integer, intent(in) :: top_lev ! top level for aerosol calculations - - ! Mode dimension arguments - integer, intent(in) :: ntot_amode ! total number of aerosol modes - integer, intent(in) :: nspec_amode(:) ! number of species per mode (ntot_amode) - integer, intent(in) :: nspec_max ! max number of species in any mode - - ! Mode geometry - real(r8), intent(in) :: dgnum_amode(:) ! default geometric mean diameter (ntot_amode) - real(r8), intent(in) :: dgnumlo_amode(:) ! lower bound dgnum (ntot_amode) - real(r8), intent(in) :: dgnumhi_amode(:) ! upper bound dgnum (ntot_amode) - - ! Derived mode quantities - real(r8), intent(in) :: alnsg_amode(:) ! ln(sigmag) for each mode (ntot_amode) - real(r8), intent(in) :: voltonumb_amode(:) ! volume-to-number (ntot_amode) - real(r8), intent(in) :: voltonumblo_amode(:) ! vol-to-num at dgnumlo (ntot_amode) - real(r8), intent(in) :: voltonumbhi_amode(:) ! vol-to-num at dgnumhi (ntot_amode) - - ! Species densities - real(r8), intent(in) :: specdens_amode(:,:) ! species densities (nspec_max,ntot_amode) - - ! Prognostic number flags - integer, intent(in) :: mprognum_amode(:) ! prognostic number flag (ntot_amode) - - ! Mode pointers - integer, intent(in) :: modeptr_aitken ! index of aitken mode - integer, intent(in) :: modeptr_accum ! index of accumulation mode - - ! Species-to-q index maps (interstitial) - integer, intent(in) :: lmassptr_amode(:,:) ! mass species pointer (nspec_max,ntot_amode) - integer, intent(in) :: numptr_amode(:) ! number species pointer (ntot_amode) - - ! Species-to-q_cw index maps (cloud-borne) - integer, intent(in) :: lmassptrcw_amode(:,:) ! cloud-borne mass species pointer (nspec_max,ntot_amode) - integer, intent(in) :: numptrcw_amode(:) ! cloud-borne number species pointer (ntot_amode) - - ! Atmospheric state - real(r8), intent(in) :: pdel(:,:) ! pressure thickness (ncol,pver) - - ! Physical constants - real(r8), intent(in) :: gravit ! gravitational acceleration - real(r8), intent(in) :: pi ! pi - - ! Species arrays - integer, intent(in) :: num_q ! number of species (dimension of q/q_cw) - real(r8), intent(in) :: q(:,:,:) ! interstitial species (ncol,pver,num_q) - real(r8), intent(in) :: q_cw(:,:,:) ! cloud-borne species (ncol,pver,num_q) - - ! Control flags - logical, intent(in) :: do_adjust ! adjust number to size bounds - logical, intent(in) :: do_aitacc_transfer ! aitken<-->accum transfer - - ! Rename transfer data (only used when do_aitacc_transfer=.true.) - integer, intent(in) :: npair_renamexf ! number of rename pairs - integer, intent(in) :: nspecfrm_renamexf(:) ! species count per pair - integer, intent(in) :: modefrm_renamexf(:) ! from mode index per pair - integer, intent(in) :: modetoo_renamexf(:) ! to mode index per pair - integer, intent(in) :: lspecfrma_renamexf(:,:) ! interstitial from species indices - integer, intent(in) :: lspectooa_renamexf(:,:) ! interstitial to species indices - integer, intent(in) :: lspecfrmc_renamexf(:,:) ! cloud-borne from species indices - integer, intent(in) :: lspectooc_renamexf(:,:) ! cloud-borne to species indices - - ! Outputs - real(r8), intent(inout) :: dgncur_a(:,:,:) ! dry diameter (ncol,pver,ntot_amode) - real(r8), intent(out) :: dqdt(:,:,:) ! interstitial tendencies (ncol,pver,num_q) - real(r8), intent(out) :: dqdt_cw(:,:,:) ! cloud-borne tendencies (ncol,pver,num_q) - logical, intent(out) :: dotend(:) ! which species have interstitial tendencies (num_q) - logical, intent(out) :: dotend_cw(:) ! which species have cloud-borne tendencies (num_q) - real(r8), intent(out) :: qsrflx(:,:,:,:) ! diagnostic flux (ncol,num_q,calcsize_nsrflx,2) - - ! CCPP error reporting - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - integer :: i, ipair, iq - integer :: ixfer_acc2ait, ixfer_ait2acc - integer :: j, jac, jsrflx, k - integer :: l, l1, la, lc, lna, lnc, lsfrm, lstoo - integer :: n, nacc, nait - - logical :: noxf_acc2ait(nspec_max) - - real(r8), parameter :: third = 1.0_r8/3.0_r8 - real(r8) :: delnum_a2, delnum_c2 ! work variables - real(r8) :: delnum_a3, delnum_c3, delnum_t3 ! work variables - real(r8) :: deltatinv ! 1/deltat - real(r8) :: dgncur_c(ncol,pver,ntot_amode) - real(r8) :: dgnyy, dgnxx ! dgnumlo/hi of current mode - real(r8) :: drv_a, drv_c, drv_t ! dry volume (cm3/mol_air) - real(r8) :: drv_t0 - real(r8) :: drv_a_noxf, drv_c_noxf, drv_t_noxf - real(r8) :: drv_a_acc, drv_c_acc - real(r8) :: drv_a_accsv(ncol,pver), drv_c_accsv(ncol,pver) - real(r8) :: drv_a_aitsv(ncol,pver), drv_c_aitsv(ncol,pver) - real(r8) :: drv_a_sv(ncol,pver,ntot_amode), drv_c_sv(ncol,pver,ntot_amode) - real(r8) :: dryvol_a(ncol,pver) ! interstital aerosol dry - ! volume (cm^3/mol_air) - real(r8) :: dryvol_c(ncol,pver) ! activated aerosol dry volume - real(r8) :: duma, dumb, dumc, dumd ! work variables - real(r8) :: dumfac, dummwdens ! work variables - real(r8) :: frelaxadj ! relaxation factor applied - ! to size bounds - real(r8) :: fracadj ! deltat/tadj - real(r8) :: num_a0, num_c0, num_t0 ! initial number (#/mol_air) - real(r8) :: num_a1, num_c1 ! working number (#/mol_air) - real(r8) :: num_a2, num_c2, num_t2 ! working number (#/mol_air) - real(r8) :: num_a, num_c, num_t ! final number (#/mol_air) - real(r8) :: num_t_noxf - real(r8) :: numbnd ! bounded number - real(r8) :: num_a_acc, num_c_acc - real(r8) :: num_a_accsv(ncol,pver), num_c_accsv(ncol,pver) - real(r8) :: num_a_aitsv(ncol,pver), num_c_aitsv(ncol,pver) - real(r8) :: num_a_sv(ncol,pver,ntot_amode), num_c_sv(ncol,pver,ntot_amode) - real(r8) :: pdel_fac ! - real(r8) :: tadj ! adjustment time scale - real(r8) :: tadjinv ! 1/tadj - real(r8) :: v2ncur_a(ncol,pver,ntot_amode) - real(r8) :: v2ncur_c(ncol,pver,ntot_amode) - real(r8) :: v2nyy, v2nxx, v2nzz ! voltonumblo/hi of current mode - real(r8) :: v2nyyrl, v2nxxrl ! relaxed voltonumblo/hi - real(r8) :: xfercoef - real(r8) :: xfercoef_num_acc2ait, xfercoef_vol_acc2ait - real(r8) :: xfercoef_num_ait2acc, xfercoef_vol_ait2acc - real(r8) :: xferfrac_num_acc2ait, xferfrac_vol_acc2ait - real(r8) :: xferfrac_num_ait2acc, xferfrac_vol_ait2acc - real(r8) :: xfertend, xfertend_num(2,2) - - integer :: ixfer_acc2ait_sv(ncol,pver), ixfer_ait2acc_sv(ncol,pver) - !----------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - - ! Initialize outputs. - ! - ! Note on dgncur_a: it is intent(inout) and is backed by the pbuf (CAM) or - ! non-advected constituent (SIMA) field; levels above top_lev are not modified here. - ! It is initialized to zero or a copy of the per-mode diameter when calcsize_diag - ! called by radiation for diagnostic lists when that is active. - ! So it should not be initialized as part of the other (pure out) variables here. - dotend(:) = .false. - dotend_cw(:) = .false. - dqdt(:,:,:) = 0.0_r8 - dqdt_cw(:,:,:) = 0.0_r8 - qsrflx(:,:,:,:) = 0.0_r8 - - nait = modeptr_aitken - nacc = modeptr_accum - - deltatinv = 1.0_r8/(deltat*(1.0_r8 + 1.0e-15_r8)) - ! tadj = adjustment time scale for number, surface when they are prognosed - ! currently set to deltat - tadj = deltat - tadj = 86400 - tadj = max( tadj, deltat ) - tadjinv = 1.0_r8/(tadj*(1.0_r8 + 1.0e-15_r8)) - fracadj = deltat*tadjinv - fracadj = max( 0.0_r8, min( 1.0_r8, fracadj ) ) - - - ! - ! - ! the "do 40000" loop does the original (pre jan-2006) - ! number adjustment, one mode at a time - ! this artificially adjusts number when mean particle size is too large - ! or too small - ! - ! - do n = 1, ntot_amode - ! initialize all parameters to the default values for the mode - do k=top_lev,pver - do i=1,ncol - ! sgcur_a(i,k,n) = sigmag_amode(n) - ! sgcur_c(i,k,n) = sigmag_amode(n) - dgncur_a(i,k,n) = dgnum_amode(n) - dgncur_c(i,k,n) = dgnum_amode(n) - v2ncur_a(i,k,n) = voltonumb_amode(n) - v2ncur_c(i,k,n) = voltonumb_amode(n) - dryvol_a(i,k) = 0.0_r8 - dryvol_c(i,k) = 0.0_r8 - end do - end do - - ! compute dry volume mixrats = - ! sum_over_components{ component_mass mixrat / density } - do l1 = 1, nspec_amode(n) - ! need qmass*dummwdens = (kg/kg-air) * [1/(kg/m3)] = m3/kg-air - dummwdens = 1.0_r8 / specdens_amode(l1,n) - la = lmassptr_amode(l1,n) - do k=top_lev,pver - do i=1,ncol - dryvol_a(i,k) = dryvol_a(i,k) & - + max(0.0_r8,q(i,k,la))*dummwdens - end do - end do - - lc = lmassptrcw_amode(l1,n) - do k=top_lev,pver - do i=1,ncol - dryvol_c(i,k) = dryvol_c(i,k) & - + max(0.0_r8,q_cw(i,k,lc))*dummwdens - end do - end do - end do - - ! set "short-hand" number pointers - lna = numptr_amode(n) - lnc = numptrcw_amode(n) - - - ! go to section for appropriate number/surface diagnosed/prognosed options - if (mprognum_amode(n) <= 0) then - - ! option 1 -- number diagnosed (fixed dgnum and sigmag) - ! compute number tendencies that will bring numbers to their - ! current diagnosed values - ! - if (lna > 0) then - dotend(lna) = .true. - do k=top_lev,pver - do i=1,ncol - dqdt(i,k,lna) = (dryvol_a(i,k)*voltonumb_amode(n) & - - q(i,k,lna)) * deltatinv - end do - end do - end if - if (lnc > 0) then - dotend_cw(lnc) = .true. - do k=top_lev,pver - do i=1,ncol - dqdt_cw(i,k,lnc) = (dryvol_c(i,k)*voltonumb_amode(n) & - - q_cw(i,k,lnc)) * deltatinv - end do - end do - end if - else - ! - ! option 2 -- number prognosed (variable dgnum, fixed sigmag) - ! Compute number tendencies to adjust numbers if they are outside - ! the limits determined by current volume and dgnumlo/hi - ! The interstitial and activated aerosol fractions can, at times, - ! be the lower or upper tail of the "total" distribution. Thus they - ! can be expected to have a greater range of size parameters than - ! what is specified for the total distribution (via dgnumlo/hi) - ! When both the interstitial and activated dry volumes are positive, - ! the adjustment strategy is to (1) adjust the interstitial and activated - ! numbers towards relaxed bounds, then (2) adjust the total/combined - ! number towards the primary bounds. - ! - ! note - ! v2nyy = voltonumblo_amode is proportional to dgnumlo**(-3), - ! and produces the maximum allowed number for a given volume - ! v2nxx = voltonumbhi_amode is proportional to dgnumhi**(-3), - ! and produces the minimum allowed number for a given volume - ! v2nxxrl and v2nyyrl are their "relaxed" equivalents. - ! Setting frelaxadj=27=3**3 means that - ! dgnumlo_relaxed = dgnumlo/3 and dgnumhi_relaxed = dgnumhi*3 - ! - ! if do_aitacc_transfer is .true., then - ! for n=nacc, multiply v2nyy by 1.0e6 to effectively turn off the - ! adjustment when number is too big (size is too small) - ! for n=nait, divide v2nxx by 1.0e6 to effectively turn off the - ! adjustment when number is too small (size is too big) - !OLD however, do not change the v2nyyrl/v2nxxrl so that - !OLD the interstitial<-->activated adjustment is not changed - !NEW also change the v2nyyrl/v2nxxrl so that - !NEW the interstitial<-->activated adjustment is turned off - ! - end if - frelaxadj = 27.0_r8 - dumfac = exp(4.5_r8*alnsg_amode(n)**2)*pi/6.0_r8 - v2nxx = voltonumbhi_amode(n) - v2nyy = voltonumblo_amode(n) - v2nxxrl = v2nxx/frelaxadj - v2nyyrl = v2nyy*frelaxadj - dgnxx = dgnumhi_amode(n) - dgnyy = dgnumlo_amode(n) - if ( do_aitacc_transfer ) then - if (n == nait) v2nxx = v2nxx/1.0e6_r8 - if (n == nacc) v2nyy = v2nyy*1.0e6_r8 - v2nxxrl = v2nxx/frelaxadj ! NEW - v2nyyrl = v2nyy*frelaxadj ! NEW - end if - - if (do_adjust) then - dotend(lna) = .true. - dotend_cw(lnc) = .true. - end if - - do k = top_lev, pver - do i = 1, ncol - - drv_a = dryvol_a(i,k) - num_a0 = q(i,k,lna) - num_a = max( 0.0_r8, num_a0 ) - drv_c = dryvol_c(i,k) - num_c0 = q_cw(i,k,lnc) - num_c = max( 0.0_r8, num_c0 ) - - if (do_adjust) then - - ! - ! do number adjustment for interstitial and activated particles - ! adjustments that (1) make numbers non-negative or (2) make numbers - ! zero when volume is zero are applied over time-scale deltat - ! adjustments that bring numbers to within specified bounds are - ! applied over time-scale tadj - ! - if ((drv_a <= 0.0_r8) .and. (drv_c <= 0.0_r8)) then - ! both interstitial and activated volumes are zero - ! adjust both numbers to zero - num_a = 0.0_r8 - dqdt(i,k,lna) = -num_a0*deltatinv - num_c = 0.0_r8 - dqdt_cw(i,k,lnc) = -num_c0*deltatinv - else if (drv_c <= 0.0_r8) then - ! activated volume is zero, so interstitial number/volume == total/combined - ! apply step 1 and 3, but skip the relaxed adjustment (step 2, see below) - num_c = 0.0_r8 - dqdt_cw(i,k,lnc) = -num_c0*deltatinv - num_a1 = num_a - numbnd = max( drv_a*v2nxx, min( drv_a*v2nyy, num_a1 ) ) - num_a = num_a1 + (numbnd - num_a1)*fracadj - dqdt(i,k,lna) = (num_a - num_a0)*deltatinv - - else if (drv_a <= 0.0_r8) then - ! interstitial volume is zero, treat similar to above - num_a = 0.0_r8 - dqdt(i,k,lna) = -num_a0*deltatinv - num_c1 = num_c - numbnd = max( drv_c*v2nxx, min( drv_c*v2nyy, num_c1 ) ) - num_c = num_c1 + (numbnd - num_c1)*fracadj - dqdt_cw(i,k,lnc) = (num_c - num_c0)*deltatinv - else - ! both volumes are positive - ! apply 3 adjustment steps - ! step1: num_a,c0 --> num_a,c1 forces non-negative values - num_a1 = num_a - num_c1 = num_c - ! step2: num_a,c1 --> num_a,c2 applies relaxed bounds to the interstitial - ! and activated number (individually) - ! if only only a or c changes, adjust the other in the opposite direction - ! as much as possible to conserve a+c - numbnd = max( drv_a*v2nxxrl, min( drv_a*v2nyyrl, num_a1 ) ) - delnum_a2 = (numbnd - num_a1)*fracadj - num_a2 = num_a1 + delnum_a2 - numbnd = max( drv_c*v2nxxrl, min( drv_c*v2nyyrl, num_c1 ) ) - delnum_c2 = (numbnd - num_c1)*fracadj - num_c2 = num_c1 + delnum_c2 - if ((delnum_a2 == 0.0_r8) .and. (delnum_c2 /= 0.0_r8)) then - num_a2 = max( drv_a*v2nxxrl, min( drv_a*v2nyyrl, & - num_a1-delnum_c2 ) ) - else if ((delnum_a2 /= 0.0_r8) .and. (delnum_c2 == 0.0_r8)) then - num_c2 = max( drv_c*v2nxxrl, min( drv_c*v2nyyrl, & - num_c1-delnum_a2 ) ) - end if - ! step3: num_a,c2 --> num_a,c3 applies stricter bounds to the - ! combined/total number - drv_t = drv_a + drv_c - num_t2 = num_a2 + num_c2 - delnum_a3 = 0.0_r8 - delnum_c3 = 0.0_r8 - if (num_t2 < drv_t*v2nxx) then - delnum_t3 = (drv_t*v2nxx - num_t2)*fracadj - ! if you are here then (num_a2 < drv_a*v2nxx) and/or - ! (num_c2 < drv_c*v2nxx) must be true - if ((num_a2 < drv_a*v2nxx) .and. (num_c2 < drv_c*v2nxx)) then - delnum_a3 = delnum_t3*(num_a2/num_t2) - delnum_c3 = delnum_t3*(num_c2/num_t2) - else if (num_c2 < drv_c*v2nxx) then - delnum_c3 = delnum_t3 - else if (num_a2 < drv_a*v2nxx) then - delnum_a3 = delnum_t3 - end if - else if (num_t2 > drv_t*v2nyy) then - delnum_t3 = (drv_t*v2nyy - num_t2)*fracadj - ! if you are here then (num_a2 > drv_a*v2nyy) and/or - ! (num_c2 > drv_c*v2nyy) must be true - if ((num_a2 > drv_a*v2nyy) .and. (num_c2 > drv_c*v2nyy)) then - delnum_a3 = delnum_t3*(num_a2/num_t2) - delnum_c3 = delnum_t3*(num_c2/num_t2) - else if (num_c2 > drv_c*v2nyy) then - delnum_c3 = delnum_t3 - else if (num_a2 > drv_a*v2nyy) then - delnum_a3 = delnum_t3 - end if - end if - num_a = num_a2 + delnum_a3 - dqdt(i,k,lna) = (num_a - num_a0)*deltatinv - num_c = num_c2 + delnum_c3 - dqdt_cw(i,k,lnc) = (num_c - num_c0)*deltatinv - end if - - end if ! do_adjust - - ! - ! now compute current dgn and v2n - ! - if (drv_a > 0.0_r8) then - if (num_a <= drv_a*v2nxx) then - dgncur_a(i,k,n) = dgnxx - v2ncur_a(i,k,n) = v2nxx - else if (num_a >= drv_a*v2nyy) then - dgncur_a(i,k,n) = dgnyy - v2ncur_a(i,k,n) = v2nyy - else - dgncur_a(i,k,n) = (drv_a/(dumfac*num_a))**third - v2ncur_a(i,k,n) = num_a/drv_a - end if - end if - pdel_fac = pdel(i,k)/gravit ! = rho*dz - jac = 1 - qsrflx(i,lna,1,jac) = qsrflx(i,lna,1,jac) + max(0.0_r8,dqdt(i,k,lna))*pdel_fac - qsrflx(i,lna,2,jac) = qsrflx(i,lna,2,jac) + min(0.0_r8,dqdt(i,k,lna))*pdel_fac - - if (drv_c > 0.0_r8) then - if (num_c <= drv_c*v2nxx) then - dgncur_c(i,k,n) = dgnumhi_amode(n) - v2ncur_c(i,k,n) = v2nxx - else if (num_c >= drv_c*v2nyy) then - dgncur_c(i,k,n) = dgnumlo_amode(n) - v2ncur_c(i,k,n) = v2nyy - else - dgncur_c(i,k,n) = (drv_c/(dumfac*num_c))**third - v2ncur_c(i,k,n) = num_c/drv_c - end if - end if - jac = 2 - qsrflx(i,lnc,1,jac) = qsrflx(i,lnc,1,jac) + max(0.0_r8,dqdt_cw(i,k,lnc))*pdel_fac - qsrflx(i,lnc,2,jac) = qsrflx(i,lnc,2,jac) + min(0.0_r8,dqdt_cw(i,k,lnc))*pdel_fac - - - ! save number and dryvol for aitken <--> accum renaming - if ( do_aitacc_transfer ) then - if (n == nait) then - drv_a_aitsv(i,k) = drv_a - num_a_aitsv(i,k) = num_a - drv_c_aitsv(i,k) = drv_c - num_c_aitsv(i,k) = num_c - else if (n == nacc) then - drv_a_accsv(i,k) = drv_a - num_a_accsv(i,k) = num_a - drv_c_accsv(i,k) = drv_c - num_c_accsv(i,k) = num_c - end if - end if - drv_a_sv(i,k,n) = drv_a - num_a_sv(i,k,n) = num_a - drv_c_sv(i,k,n) = drv_c - num_c_sv(i,k,n) = num_c - - end do - end do - - - ! - ! option 3 -- number and surface prognosed (variable dgnum and sigmag) - ! this is not implemented - ! - end do ! do n = 1, ntot_amode - - - ! - ! - ! the following section - ! does aitken <--> accum mode transfer - ! - ! when the aitken mode mean size is too big, the largest - ! aitken particles are transferred into the accum mode - ! to reduce the aitken mode mean size - ! when the accum mode mean size is too small, the smallest - ! accum particles are transferred into the aitken mode - ! to increase the accum mode mean size - ! - ! - ixfer_ait2acc_sv(:,:) = 0 - ixfer_acc2ait_sv(:,:) = 0 - if ( do_aitacc_transfer ) then - - if (npair_renamexf .le. 0) then - errmsg = 'modal_aero_calcsize_run error -- npair_renamexf <= 0' - errflg = 1 - return - end if - - ! check that renaming ipair=1 is aitken-->accum - ipair = 1 - if ((modefrm_renamexf(ipair) .ne. nait) .or. & - (modetoo_renamexf(ipair) .ne. nacc)) then - errmsg = 'modal_aero_calcsize_run error -- modefrm/too_renamexf(1) are wrong' - errflg = 1 - return - 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) - 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) - if ((lsfrm > 0) .and. (lstoo > 0)) then - dotend_cw(lsfrm) = .true. - dotend_cw(lstoo) = .true. - end if - end do - - ! identify accum species cannot be transferred to aitken mode - 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 - noxf_acc2ait(l1) = .false. - end if - end do - end do - - ! v2nzz is voltonumb at the "geometrically-defined" mid-point - ! between the aitken and accum modes - v2nzz = sqrt(voltonumb_amode(nait)*voltonumb_amode(nacc)) - - ! loop over columns and levels - do k = top_lev, pver - do i = 1, ncol - - pdel_fac = pdel(i,k)/gravit ! = rho*dz - xfertend_num(:,:) = 0.0_r8 - - ! compute aitken --> accum transfer rates - ixfer_ait2acc = 0 - xfercoef_num_ait2acc = 0.0_r8 - xfercoef_vol_ait2acc = 0.0_r8 - - drv_t = drv_a_aitsv(i,k) + drv_c_aitsv(i,k) - num_t = num_a_aitsv(i,k) + num_c_aitsv(i,k) - if (drv_t > 0.0_r8) then - if (num_t < drv_t*v2nzz) then - ixfer_ait2acc = 1 - if (num_t < drv_t*voltonumb_amode(nacc)) then - xferfrac_num_ait2acc = 1.0_r8 - xferfrac_vol_ait2acc = 1.0_r8 - else - xferfrac_vol_ait2acc = ((num_t/drv_t) - v2nzz)/ & - (voltonumb_amode(nacc) - v2nzz) - xferfrac_num_ait2acc = xferfrac_vol_ait2acc* & - (drv_t*voltonumb_amode(nacc)/num_t) - if ((xferfrac_num_ait2acc <= 0.0_r8) .or. & - (xferfrac_vol_ait2acc <= 0.0_r8)) then - xferfrac_num_ait2acc = 0.0_r8 - xferfrac_vol_ait2acc = 0.0_r8 - else if ((xferfrac_num_ait2acc >= 1.0_r8) .or. & - (xferfrac_vol_ait2acc >= 1.0_r8)) then - xferfrac_num_ait2acc = 1.0_r8 - xferfrac_vol_ait2acc = 1.0_r8 - end if - end if - xfercoef_num_ait2acc = xferfrac_num_ait2acc*tadjinv - xfercoef_vol_ait2acc = xferfrac_vol_ait2acc*tadjinv - xfertend_num(1,1) = num_a_aitsv(i,k)*xfercoef_num_ait2acc - xfertend_num(1,2) = num_c_aitsv(i,k)*xfercoef_num_ait2acc - end if - end if - - ! compute accum --> aitken transfer rates - ! accum may have some species (seasalt, dust, poa, lll) that are - ! not in aitken mode - ! so first divide the accum drv & num into not-transferred (noxf) species - ! and transferred species, and use the transferred-species - ! portion in what follows - ixfer_acc2ait = 0 - xfercoef_num_acc2ait = 0.0_r8 - xfercoef_vol_acc2ait = 0.0_r8 - - drv_t = drv_a_accsv(i,k) + drv_c_accsv(i,k) - num_t = num_a_accsv(i,k) + num_c_accsv(i,k) - drv_a_noxf = 0.0_r8 - drv_c_noxf = 0.0_r8 - if (drv_t > 0.0_r8) then - if (num_t > drv_t*v2nzz) then - do l1 = 1, nspec_amode(nacc) - - if ( noxf_acc2ait(l1) ) then - ! need qmass*dummwdens = (kg/kg-air) * [1/(kg/m3)] = m3/kg-air - dummwdens = 1.0_r8 / specdens_amode(l1,nacc) - la = lmassptr_amode(l1,nacc) - drv_a_noxf = drv_a_noxf & - + max(0.0_r8,q(i,k,la))*dummwdens - lc = lmassptrcw_amode(l1,nacc) - - drv_c_noxf = drv_c_noxf & - + max(0.0_r8,q_cw(i,k,lc))*dummwdens - end if - end do - drv_t_noxf = drv_a_noxf + drv_c_noxf - num_t_noxf = drv_t_noxf*voltonumblo_amode(nacc) - num_t0 = num_t - drv_t0 = drv_t - num_t = max( 0.0_r8, num_t - num_t_noxf ) - drv_t = max( 0.0_r8, drv_t - drv_t_noxf ) - end if - end if - - if (drv_t > 0.0_r8) then - if (num_t > drv_t*v2nzz) then - ixfer_acc2ait = 1 - if (num_t > drv_t*voltonumb_amode(nait)) then - xferfrac_num_acc2ait = 1.0_r8 - xferfrac_vol_acc2ait = 1.0_r8 - else - xferfrac_vol_acc2ait = ((num_t/drv_t) - v2nzz)/ & - (voltonumb_amode(nait) - v2nzz) - xferfrac_num_acc2ait = xferfrac_vol_acc2ait* & - (drv_t*voltonumb_amode(nait)/num_t) - if ((xferfrac_num_acc2ait <= 0.0_r8) .or. & - (xferfrac_vol_acc2ait <= 0.0_r8)) then - xferfrac_num_acc2ait = 0.0_r8 - xferfrac_vol_acc2ait = 0.0_r8 - else if ((xferfrac_num_acc2ait >= 1.0_r8) .or. & - (xferfrac_vol_acc2ait >= 1.0_r8)) then - xferfrac_num_acc2ait = 1.0_r8 - xferfrac_vol_acc2ait = 1.0_r8 - end if - end if - duma = 1.0e-37_r8 - xferfrac_num_acc2ait = xferfrac_num_acc2ait* & - num_t/max( duma, num_t0 ) - xfercoef_num_acc2ait = xferfrac_num_acc2ait*tadjinv - xfercoef_vol_acc2ait = xferfrac_vol_acc2ait*tadjinv - xfertend_num(2,1) = num_a_accsv(i,k)*xfercoef_num_acc2ait - xfertend_num(2,2) = num_c_accsv(i,k)*xfercoef_num_acc2ait - end if - end if - - ! jump to end-of-loop if no transfer is needed at current i,k - if (ixfer_ait2acc+ixfer_acc2ait > 0) then - ixfer_ait2acc_sv(i,k) = ixfer_ait2acc - ixfer_acc2ait_sv(i,k) = ixfer_acc2ait - - ! - ! compute new dgncur & v2ncur for aitken & accum modes - ! - ! currently inactive - do n = nait, nacc, (nacc-nait) - if (n .eq. nait) then - duma = (xfertend_num(1,1) - xfertend_num(2,1))*deltat - num_a = max( 0.0_r8, num_a_aitsv(i,k) - duma ) - num_a_acc = max( 0.0_r8, num_a_accsv(i,k) + duma ) - duma = (drv_a_aitsv(i,k)*xfercoef_vol_ait2acc - & - (drv_a_accsv(i,k)-drv_a_noxf)*xfercoef_vol_acc2ait)*deltat - drv_a = max( 0.0_r8, drv_a_aitsv(i,k) - duma ) - drv_a_acc = max( 0.0_r8, drv_a_accsv(i,k) + duma ) - duma = (xfertend_num(1,2) - xfertend_num(2,2))*deltat - num_c = max( 0.0_r8, num_c_aitsv(i,k) - duma ) - num_c_acc = max( 0.0_r8, num_c_accsv(i,k) + duma ) - duma = (drv_c_aitsv(i,k)*xfercoef_vol_ait2acc - & - (drv_c_accsv(i,k)-drv_c_noxf)*xfercoef_vol_acc2ait)*deltat - drv_c = max( 0.0_r8, drv_c_aitsv(i,k) - duma ) - drv_c_acc = max( 0.0_r8, drv_c_accsv(i,k) + duma ) - else - num_a = num_a_acc - drv_a = drv_a_acc - num_c = num_c_acc - drv_c = drv_c_acc - end if - - if (drv_a > 0.0_r8) then - if (num_a <= drv_a*voltonumbhi_amode(n)) then - dgncur_a(i,k,n) = dgnumhi_amode(n) - v2ncur_a(i,k,n) = voltonumbhi_amode(n) - else if (num_a >= drv_a*voltonumblo_amode(n)) then - dgncur_a(i,k,n) = dgnumlo_amode(n) - v2ncur_a(i,k,n) = voltonumblo_amode(n) - else - dgncur_a(i,k,n) = (drv_a/(dumfac*num_a))**third - v2ncur_a(i,k,n) = num_a/drv_a - end if - else - dgncur_a(i,k,n) = dgnum_amode(n) - v2ncur_a(i,k,n) = voltonumb_amode(n) - end if - - if (drv_c > 0.0_r8) then - if (num_c <= drv_c*voltonumbhi_amode(n)) then - dgncur_c(i,k,n) = dgnumhi_amode(n) - v2ncur_c(i,k,n) = voltonumbhi_amode(n) - else if (num_c >= drv_c*voltonumblo_amode(n)) then - dgncur_c(i,k,n) = dgnumlo_amode(n) - v2ncur_c(i,k,n) = voltonumblo_amode(n) - else - dgncur_c(i,k,n) = (drv_c/(dumfac*num_c))**third - v2ncur_c(i,k,n) = num_c/drv_c - end if - else - dgncur_c(i,k,n) = dgnum_amode(n) - v2ncur_c(i,k,n) = voltonumb_amode(n) - end if - - end do - - - ! - ! compute tendency amounts for aitken <--> accum transfer - ! - - ! j=1 does aitken-->accum; j=2 does accum-->aitken - do j = 1, 2 - - if ((j .eq. 1 .and. ixfer_ait2acc > 0) .or. & - (j .eq. 2 .and. ixfer_acc2ait > 0)) then - - jsrflx = j+2 - if (j .eq. 1) then - xfercoef = xfercoef_vol_ait2acc - else - xfercoef = xfercoef_vol_acc2ait - end if - - do iq = 1, nspecfrm_renamexf(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 - ! 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) - else - lsfrm = lspecfrmc_renamexf(iq,ipair) - lstoo = lspectooc_renamexf(iq,ipair) - end if - else - if (jac .eq. 1) then - lsfrm = lspectooa_renamexf(iq,ipair) - lstoo = lspecfrma_renamexf(iq,ipair) - else - lsfrm = lspectooc_renamexf(iq,ipair) - lstoo = lspecfrmc_renamexf(iq,ipair) - end if - end if - - if ((lsfrm > 0) .and. (lstoo > 0)) then - if (jac .eq. 1) then - if (iq .eq. 1) then - xfertend = xfertend_num(j,jac) - else - xfertend = max(0.0_r8,q(i,k,lsfrm))*xfercoef - end if - dqdt(i,k,lsfrm) = dqdt(i,k,lsfrm) - xfertend - dqdt(i,k,lstoo) = dqdt(i,k,lstoo) + xfertend - else - if (iq .eq. 1) then - xfertend = xfertend_num(j,jac) - else - xfertend = max(0.0_r8,q_cw(i,k,lsfrm))*xfercoef - end if - dqdt_cw(i,k,lsfrm) = dqdt_cw(i,k,lsfrm) - xfertend - dqdt_cw(i,k,lstoo) = dqdt_cw(i,k,lstoo) + xfertend - end if - qsrflx(i,lsfrm,jsrflx,jac) = qsrflx(i,lsfrm,jsrflx,jac) - xfertend*pdel_fac - qsrflx(i,lstoo,jsrflx,jac) = qsrflx(i,lstoo,jsrflx,jac) + xfertend*pdel_fac - end if - - end do - end do - end if - end do - - end if - end do - end do - - - end if ! do_aitacc_transfer - lsfrm = -123456789 ! executable statement for debugging - -end subroutine modal_aero_calcsize_run - -!=============================================================================== - -subroutine modal_aero_calcdry_run( & - aero_props, aero_state, & - ncol, pver, top_lev, & - do_strat_sulfate, & - pi, & - dgncur_a, & - hygro, dryvol, dryrad, drymass, so4dryvol, naer, & - errmsg, errflg) - -!----------------------------------------------------------------------- -! -! Compute derived dry aerosol properties from mixing ratios and -! adjusted number mode diameter. Called after calcsize_run. -! -!----------------------------------------------------------------------- - - use aerosol_properties_mod, only: aerosol_properties - use aerosol_state_mod, only: aerosol_state - - ! Arguments - class(aerosol_properties), intent(in) :: aero_props - class(aerosol_state), intent(in) :: aero_state - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: pver ! number of vertical levels - integer, intent(in) :: top_lev ! top level for aerosol calculations - logical, intent(in) :: do_strat_sulfate ! use stratospheric sulfate treatment - real(r8), intent(in) :: pi ! pi - real(r8), intent(in) :: dgncur_a(:,:,:) ! dry number mode diameter (m) - - real(r8), intent(out) :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) - real(r8), intent(out) :: dryvol(:,:,:) ! single-particle-mean dry volume (m3) - real(r8), intent(out) :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) - real(r8), intent(out) :: drymass(:,:,:) ! single-particle-mean dry mass (kg) - real(r8), intent(out) :: so4dryvol(:,:,:) ! single-particle-mean so4 dry volume (m3) - real(r8), intent(out) :: naer(:,:,:) ! aerosol number MR (#/kg-air) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - real(r8), parameter :: third = 1._r8/3._r8 - real(r8) :: pi43 - - integer :: i, k, l, m - integer :: nmodes, nspec - - real(r8) :: specdens - real(r8) :: spechygro, spechygro_1 - real(r8) :: sigmag - real(r8) :: duma, dumb - real(r8) :: alnsg - - real(r8) :: v2ncur_a - real(r8) :: drydens ! dry particle density (kg/m^3) - - real(r8) :: maer(ncol, pver) - real(r8) :: dryvolmr(ncol, pver) - real(r8) :: so4dryvolmr(ncol, pver) - - character(len=32) :: spectype - - real(r8), pointer :: raer(:,:) - !----------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - - pi43 = pi*4._r8/3._r8 - - nmodes = aero_props%nbins() - - hygro(:,:,:) = 0._r8 - so4dryvol(:,:,:) = 0._r8 - - do m = 1, nmodes - - maer(:,:) = 0._r8 - dryvolmr(:,:) = 0._r8 - so4dryvolmr(:,:) = 0._r8 - - ! get mode properties - sigmag = exp(aero_props%alogsig(m)) - - ! get mode info - nspec = aero_props%nspecies(m) - - do l = 1, nspec - - ! get species interstitial mixing ratio ('a') - call aero_state%get_ambient_mmr(species_ndx=l, bin_ndx=m, mmr=raer) - call aero_props%get(m, l, density=specdens, & - hygro=spechygro, spectype=spectype) - - if (l == 1) then - ! save off these values to be used as defaults - spechygro_1 = spechygro - end if - - do k = top_lev, pver - do i = 1, ncol - duma = raer(i,k) ! kg/kg air - maer(i,k) = maer(i,k) + duma - dumb = duma/specdens ! m3/kg air - dryvolmr(i,k) = dryvolmr(i,k) + dumb - if (do_strat_sulfate .and. (trim(spectype).eq.'sulfate')) then - so4dryvolmr(i,k) = so4dryvolmr(i,k) + dumb - end if - hygro(i,k,m) = hygro(i,k,m) + dumb*spechygro - end do - end do - end do - - alnsg = log(sigmag) - - do k = top_lev, pver - do i = 1, ncol - - if (dryvolmr(i,k) > 1.0e-30_r8) then - hygro(i,k,m) = hygro(i,k,m)/dryvolmr(i,k) - else - hygro(i,k,m) = spechygro_1 - end if - - ! dry aerosol properties - - v2ncur_a = 1._r8 / ( (pi/6._r8)*(dgncur_a(i,k,m)**3._r8)*exp(4.5_r8*alnsg**2._r8) ) - ! naer = aerosol number (#/kg) - naer(i,k,m) = dryvolmr(i,k)*v2ncur_a - - ! compute mean (1 particle) dry volume and mass for each mode - if (maer(i,k) .gt. 1.0e-31_r8) then - drydens = maer(i,k)/dryvolmr(i,k) ! kg/m3 aerosol - else - drydens = 1.0_r8 - end if - dryvol(i,k,m) = 1.0_r8/v2ncur_a ! m3/particle - drymass(i,k,m) = drydens*dryvol(i,k,m) ! kg/particle - dryrad(i,k,m) = (dryvol(i,k,m)/pi43)**third ! m - end do ! i = 1, ncol - end do ! k = top_lev, pver - - - if (do_strat_sulfate) then - do k = top_lev, pver - do i = 1, ncol - if (so4dryvolmr(i,k) .gt. 1.0e-31_r8) then - so4dryvol(i,k,m) = dryvol(i,k,m)*so4dryvolmr(i,k)/dryvolmr(i,k) - else - so4dryvol(i,k,m) = 0.0_r8 - end if - - end do ! i = 1, ncol - end do ! k = top_lev, pver - - end if - - end do ! m = 1, nmodes - -end subroutine modal_aero_calcdry_run - -subroutine modal_aero_calcsize_diag_run( & - aero_props, aero_state, & - ncol, pver, top_lev, & - pi, & - dgncur_a, & - errmsg, errflg) - - !----------------------------------------------------------------------- - ! - ! Calculate aerosol size distribution parameters for a diagnostic - ! radiation list, using only the abstract aerosol interfaces. - ! Number is diagnosed from mass, Dgnum bounds, and fixed sigmag - ! (the mprognum <= 0 branch of the prognostic calculation). - ! - !----------------------------------------------------------------------- - - use aerosol_properties_mod, only: aerosol_properties - use aerosol_state_mod, only: aerosol_state - - ! Arguments - class(aerosol_properties), intent(in) :: aero_props - class(aerosol_state), intent(in) :: aero_state - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: pver ! number of vertical levels - integer, intent(in) :: top_lev ! top level for aerosol calculations - real(r8), intent(in) :: pi ! pi - real(r8), intent(out) :: dgncur_a(:,:,:) ! dry number mode diameter (m) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local - integer :: i, k, l1, n - integer :: nmodes - integer :: nspec - - real(r8), parameter :: third = 1.0_r8/3.0_r8 - - real(r8), pointer :: mode_num(:,:) ! mode number mixing ratio - real(r8), pointer :: specmmr(:,:) ! specie mmr - real(r8) :: specdens ! specie density - - real(r8) :: dryvol_a(ncol,pver) ! interstital aerosol dry volume (cm^3/mol_air) - - real(r8) :: dgnum, dgnumhi, dgnumlo - real(r8) :: dgnyy, dgnxx ! dgnumlo/hi of current mode - real(r8) :: drv_a ! dry volume (cm3/mol_air) - real(r8) :: dumfac, dummwdens ! work variables - real(r8) :: num_a0 ! initial number (#/mol_air) - real(r8) :: num_a ! final number (#/mol_air) - real(r8) :: voltonumbhi, voltonumblo - real(r8) :: v2nyy, v2nxx ! voltonumblo/hi of current mode - real(r8) :: sigmag, alnsg - !----------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - - nmodes = aero_props%nbins() - - do n = 1, nmodes - - ! get mode properties - dgnum = aero_props%dgnum(n) - dgnumhi = aero_props%dgnumhi(n) - dgnumlo = aero_props%dgnumlo(n) - sigmag = exp(aero_props%alogsig(n)) - - ! get mode number mixing ratio - call aero_state%get_ambient_num(n, mode_num) - - dgncur_a(:,:,n) = dgnum - dryvol_a(:,:) = 0.0_r8 - - ! compute dry volume mixrats = - ! sum_over_components{ component_mass mixrat / density } - nspec = aero_props%nspecies(n) - do l1 = 1, nspec - - call aero_state%get_ambient_mmr(species_ndx=l1, bin_ndx=n, mmr=specmmr) - call aero_props%get(n, l1, density=specdens) - - ! need qmass*dummwdens = (kg/kg-air) * [1/(kg/m3)] = m3/kg-air - dummwdens = 1.0_r8 / specdens - - do k=top_lev,pver - do i=1,ncol - dryvol_a(i,k) = dryvol_a(i,k) & - + max(0.0_r8, specmmr(i,k))*dummwdens - end do - end do - end do - - alnsg = log( sigmag ) - dumfac = exp(4.5_r8*alnsg**2)*pi/6.0_r8 - voltonumblo = 1._r8 / ( (pi/6._r8)*(dgnumlo**3)*exp(4.5_r8*alnsg**2) ) - voltonumbhi = 1._r8 / ( (pi/6._r8)*(dgnumhi**3)*exp(4.5_r8*alnsg**2) ) - v2nxx = voltonumbhi - v2nyy = voltonumblo - dgnxx = dgnumhi - dgnyy = dgnumlo - - do k = top_lev, pver - do i = 1, ncol - - drv_a = dryvol_a(i,k) - num_a0 = mode_num(i,k) - num_a = max( 0.0_r8, num_a0 ) - - if (drv_a > 0.0_r8) then - if (num_a <= drv_a*v2nxx) then - dgncur_a(i,k,n) = dgnxx - else if (num_a >= drv_a*v2nyy) then - dgncur_a(i,k,n) = dgnyy - else - dgncur_a(i,k,n) = (drv_a/(dumfac*num_a))**third - end if - end if - - end do - end do - - end do ! nmodes - -end subroutine modal_aero_calcsize_diag_run - -end module modal_aero_calcsize diff --git a/src/chemistry/utils/modal_aero_wateruptake.F90 b/src/chemistry/utils/modal_aero_wateruptake.F90 deleted file mode 100644 index 93b4b0f051..0000000000 --- a/src/chemistry/utils/modal_aero_wateruptake.F90 +++ /dev/null @@ -1,1011 +0,0 @@ -module modal_aero_wateruptake - -! Portable science module for modal aerosol water uptake. -! Contains Kohler theory wet radius calculation and polynomial solvers. -! -! RCE 07.04.13: Adapted from MIRAGE2 code - -use shr_kind_mod, only: r8 => shr_kind_r8 - -implicit none -private -save - -public :: & - modal_aero_wateruptake_init, & - modal_aero_wateruptake_sub, & - modal_aero_wateruptake_diag - -real(r8), parameter :: third = 1._r8/3._r8 -real(r8) :: pi43 - -!=============================================================================== -contains -!=============================================================================== - -subroutine modal_aero_wateruptake_init(pi, errmsg, errflg) - real(r8), intent(in) :: pi - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - - pi43 = pi*4.0_r8/3.0_r8 - -end subroutine modal_aero_wateruptake_init - -subroutine modal_aero_wateruptake_sub( & - aero_props, aero_state, & - ncol, pver, top_lev, & - do_strat_sulfate, & - t, pmid, h2ommr, cldn, & - dryrad, hygro, dryvol, so4dryvol, & - dgncur_awet, troplev, & - wetrad, wetvol, wtrvol, & - sulfeq, wtpct, sulden, & - specdens_1, alnsg_out, maer, & - errmsg, errflg) - -!----------------------------------------------------------------------- -! -! Purpose: Compute aerosol wet radius -! -! Method: Kohler theory -! -! Author: S. Ghan -! -!----------------------------------------------------------------------- - - use aerosol_properties_mod, only: aerosol_properties - use aerosol_state_mod, only: aerosol_state - use wv_saturation, only: qsat_water - - ! Arguments - class(aerosol_properties), intent(in) :: aero_props - class(aerosol_state), intent(in) :: aero_state - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: pver ! number of vertical levels - integer, intent(in) :: top_lev ! top level for aerosol calculations - logical, intent(in) :: do_strat_sulfate ! use stratospheric sulfate treatment - real(r8), intent(in) :: t(:,:) ! temperature (K) - real(r8), intent(in) :: pmid(:,:) ! layer pressure (Pa) - real(r8), intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) - real(r8), intent(in) :: cldn(:,:) ! cloud fraction (0-1) - real(r8), intent(in) :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) - real(r8), intent(in) :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) - real(r8), intent(in) :: dryvol(:,:,:) ! dry volume of single aerosol (m3) - real(r8), intent(in) :: so4dryvol(:,:,:) ! dry volume of sulfate in single aerosol (m3) - real(r8), intent(in) :: dgncur_awet(:,:,:) ! wet number mode diameter, prev timestep (m) - integer, intent(in) :: troplev(:) ! tropopause level index - - real(r8), intent(out) :: wetrad(:,:,:) ! wet radius of aerosol (m) - real(r8), intent(out) :: wetvol(:,:,:) ! single-particle-mean wet volume (m3) - real(r8), intent(out) :: wtrvol(:,:,:) ! single-particle-mean water volume (m3) - real(r8), intent(out) :: sulfeq(:,:,:) ! H2SO4 equilibrium mixing ratio (mol/mol) - real(r8), intent(out) :: wtpct(:,:,:) ! sulfate composition, weight % H2SO4 - real(r8), intent(out) :: sulden(:,:,:) ! sulfate aerosol mass density (g/cm3) - real(r8), intent(out) :: specdens_1(:) ! first-species density per mode (kg/m3) - real(r8), intent(out) :: alnsg_out(:) ! log(sigma_g) per mode - real(r8), intent(out) :: maer(:,:,:) ! accumulated mode mass (kg/kg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - - integer :: i, k, l, m - integer :: nmodes, nspec - real(r8) :: so4specdens, specdens, sigmag - character(len=32) :: spectype - real(r8) :: dmean, qh2so4_equilib, wtpct_mode, sulden_mode - real(r8) :: hystfac - - real(r8), allocatable :: rhcrystal(:), rhdeliques(:) - real(r8) :: rh(ncol, pver) - real(r8) :: es(ncol), qs(ncol) - - real(r8), pointer :: raer(:,:) - !----------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - - nmodes = aero_props%nbins() - - ! Initialize defaults - wtpct(:,:,:) = 75._r8 - sulden(:,:,:) = 1.923_r8 - sulfeq(:,:,:) = 0._r8 - maer(:,:,:) = 0._r8 - - allocate(rhcrystal(nmodes), rhdeliques(nmodes)) - - so4specdens = 0._r8 - - ! Query mode properties and accumulate mode mass - do m = 1, nmodes - - sigmag = exp(aero_props%alogsig(m)) - rhcrystal(m) = aero_props%rhcrystal(m) - rhdeliques(m) = aero_props%rhdeliques(m) - alnsg_out(m) = log(sigmag) - - ! get mode info - nspec = aero_props%nspecies(m) - - do l = 1, nspec - - ! accumulate the aerosol masses of each mode - call aero_state%get_ambient_mmr(species_ndx=l, bin_ndx=m, mmr=raer) - maer(:ncol,:,m) = maer(:ncol,:,m) + raer(:ncol,:) - - ! get species interstitial mixing ratio ('a') - call aero_props%get(m, l, density=specdens, & - spectype=spectype) - - if (do_strat_sulfate .and. (trim(spectype).eq.'sulfate')) then - so4specdens=specdens - end if - - if (l == 1) then - ! save off these values to be used as defaults - specdens_1(m) = specdens - end if - - end do - - ! Compute stratospheric sulfate equilibrium - if (do_strat_sulfate) then - do k = top_lev, pver - do i = 1, ncol - dmean = dgncur_awet(i,k,m)*exp(1.5_r8*alnsg_out(m)**2) - call calc_h2so4_equilib_mixrat( t(i,k), pmid(i,k), h2ommr(i,k), dmean, & - qh2so4_equilib, wtpct_mode, sulden_mode, & - errmsg, errflg ) - if (errflg /= 0) then - deallocate(rhcrystal, rhdeliques) - return - end if - sulfeq(i,k,m) = qh2so4_equilib - wtpct(i,k,m) = wtpct_mode - sulden(i,k,m) = sulden_mode - end do ! i = 1, ncol - end do ! k = top_lev, pver - end if - - end do ! m = 1, nmodes - - ! Compute relative humidity - do k = top_lev, pver - call qsat_water(t(1:ncol,k), pmid(1:ncol,k), es(1:ncol), qs(1:ncol), ncol) - do i = 1, ncol - if (qs(i) > h2ommr(i,k)) then - rh(i,k) = h2ommr(i,k)/qs(i) - else - rh(i,k) = 0.98_r8 - endif - rh(i,k) = max(rh(i,k), 0.0_r8) - rh(i,k) = min(rh(i,k), 0.98_r8) - if (cldn(i,k) .lt. 1.0_r8) then - rh(i,k) = (rh(i,k) - cldn(i,k)) / (1.0_r8 - cldn(i,k)) ! clear portion - end if - rh(i,k) = max(rh(i,k), 0.0_r8) - end do - end do - - ! Compute wet radius using Kohler theory - do m = 1, nmodes - - hystfac = 1.0_r8 / max(1.0e-5_r8, (rhdeliques(m) - rhcrystal(m))) - - do k = top_lev, pver - do i = 1, ncol - - if ( do_strat_sulfate .and. (k Pa - sulfequil = sulfequil * 1.01325e5_r8 - - ! Convert Pa ==> mol/mol - sulfequil = sulfequil / pres - - ! Calculate Kelvin curvature factor for H2SO4 interactively with temperature: - ! (g/mol)*(erg/cm2)/(K * g/cm3 * erg/mol/K) = cm - akelvin = 2._r8 * wtmol_h2so4 * surf_tens_mode / (t * sulden * RGAS) - - expon = akelvin / r ! divide by mode radius (cm) - expon = max(-100._r8, expon) - expon = min(100._r8, expon) - akas = exp( expon ) - qh2so4_equilib = sulfequil * akas ! reduce H2SO4 equilibrium mixing ratio by Kelvin curvature factor - -end subroutine calc_h2so4_equilib_mixrat - -!---------------------------------------------------------------------- -subroutine calc_h2so4_wtpct( temp, pres, qh2o, wtpct, errmsg, errflg ) - - !! This function calculates the weight % H2SO4 composition of - !! sulfate aerosol, using Tabazadeh et. al. (GRL, 1931, 1997). - !! Rated for T=185-260K, activity=0.01-1.0 - !! - !! Argument list input: - !! temp = temperature (K) - !! pres = atmospheric pressure (Pa) - !! qh2o = water specific humidity (kg/kg) - !! - !! Output: - !! wtpct = weight % H2SO4 in H2O/H2SO4 particle (0-100) - !! - !! @author Mike Mills - !! @ version October 2013 - - use wv_saturation, only: qsat_water - - real(r8), intent(in) :: temp ! temperature (K) - real(r8), intent(in) :: pres ! pressure (Pa) - real(r8), intent(in) :: qh2o ! water vapor specific humidity (kg/kg) - real(r8), intent(out) :: wtpct ! sulfate weight % H2SO4 composition - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local declarations - real(r8) :: atab1,btab1,ctab1,dtab1,atab2,btab2,ctab2,dtab2 - real(r8) :: contl, conth, contt, conwtp - real(r8) :: activ - real(r8) :: es ! saturation vapor pressure over water (Pa) (dummy) - real(r8) :: qs ! saturation specific humidity over water (kg/kg) - - errmsg = '' - errflg = 0 - - ! calculate saturation specific humidity over pure water, qs (kg/kg) - call qsat_water(temp, pres, es, qs) - - ! Activity = water specific humidity (kg/kg) / equilibrium water (kg/kg) - activ = qh2o/qs - - if (activ.lt.0.05_r8) then - activ = max(activ,1.e-6_r8) ! restrict minimum activity - atab1 = 12.37208932_r8 - btab1 = -0.16125516114_r8 - ctab1 = -30.490657554_r8 - dtab1 = -2.1133114241_r8 - atab2 = 13.455394705_r8 - btab2 = -0.1921312255_r8 - ctab2 = -34.285174607_r8 - dtab2 = -1.7620073078_r8 - elseif (activ.ge.0.05_r8.and.activ.le.0.85_r8) then - atab1 = 11.820654354_r8 - btab1 = -0.20786404244_r8 - ctab1 = -4.807306373_r8 - dtab1 = -5.1727540348_r8 - atab2 = 12.891938068_r8 - btab2 = -0.23233847708_r8 - ctab2 = -6.4261237757_r8 - dtab2 = -4.9005471319_r8 - elseif (activ.gt.0.85_r8) then - activ = min(activ,1._r8) ! restrict maximum activity - atab1 = -180.06541028_r8 - btab1 = -0.38601102592_r8 - ctab1 = -93.317846778_r8 - dtab1 = 273.88132245_r8 - atab2 = -176.95814097_r8 - btab2 = -0.36257048154_r8 - ctab2 = -90.469744201_r8 - dtab2 = 267.45509988_r8 - else - write(*,*) 'calc_h2so4_wtpct: invalid activity: activ,qh2o,qs,temp,pres=',activ,qh2o,qs,temp,pres - errmsg = 'calc_h2so4_wtpct: invalid activity' - errflg = 1 - return - endif - - contl = atab1*(activ**btab1)+ctab1*activ+dtab1 - conth = atab2*(activ**btab2)+ctab2*activ+dtab2 - - contt = contl + (conth-contl) * ((temp -190._r8)/70._r8) - conwtp = (contt*98._r8) + 1000._r8 - - wtpct = (100._r8*contt*98._r8)/conwtp - wtpct = min(max(wtpct,25._r8),100._r8) ! restrict between 1 and 100 % - -end subroutine calc_h2so4_wtpct - -!---------------------------------------------------------------------- - -subroutine modal_aero_wateruptake_diag( & - aero_props, aero_state, & - ncol, nlev, top_lev, & - pi, rhoh2o, & - t, pmid, h2ommr, cldn, & - bin_idx, dgnumwet, qaerwat, & - errmsg, errflg) - -!----------------------------------------------------------------------- -! -! Recompute wet number mode diameter and aerosol water for a DIAGNOSTIC -! radiation list, returning the slices for one mode. Composes the portable -! diagnostic-list size calculation (modal_aero_calcsize_diag_run + -! modal_aero_calcdry_run) with the wet radius calculation -! (modal_aero_wateruptake_sub) and the wet-diameter/water/density -! post-processing of the climate-list driver. -! -! The stratospheric sulfate treatment is not supported for diagnostic -! lists (matching the climate-list driver, which aborts in that case), -! so do_strat_sulfate is hardwired false and troplev is unused. -! -! This routine is the target of the water-uptake-diagnostic procedure -! pointer registered with modal_aerosol_state; it must keep the plain -! abstract-interface signature so hosts without the modal aerosol -! schemes never reference this module. -! -!----------------------------------------------------------------------- - - use aerosol_properties_mod, only: aerosol_properties - use aerosol_state_mod, only: aerosol_state - use modal_aero_calcsize, only: modal_aero_calcsize_diag_run, modal_aero_calcdry_run - - ! Arguments - class(aerosol_properties), intent(in) :: aero_props - class(aerosol_state), intent(in) :: aero_state - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: nlev ! number of vertical levels - integer, intent(in) :: top_lev ! top level for aerosol calculations - real(r8), intent(in) :: pi ! pi - real(r8), intent(in) :: rhoh2o ! density of liquid water (kg/m3) - real(r8), intent(in) :: t(:,:) ! temperature (K) - real(r8), intent(in) :: pmid(:,:) ! layer pressure (Pa) - real(r8), intent(in) :: h2ommr(:,:) ! specific humidity (kg/kg) - real(r8), intent(in) :: cldn(:,:) ! layer cloud fraction (0-1) - integer, intent(in) :: bin_idx ! mode index of the returned slices - real(r8), intent(out) :: dgnumwet(:,:) ! wet number mode diameter of mode bin_idx (m) - real(r8), intent(out) :: qaerwat(:,:) ! aerosol water of mode bin_idx (g/g) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - integer :: i, k, m - integer :: nmodes - integer :: istat - - integer :: troplev(ncol) - - real(r8), allocatable :: dgncur_a(:,:,:) ! dry number mode diameter (m) - real(r8), allocatable :: dgncur_awet(:,:,:) ! wet number mode diameter (m) - real(r8), allocatable :: qaerwat_m(:,:,:) ! aerosol water (g/g) - real(r8), allocatable :: wetdens(:,:,:) ! wet aerosol density (kg/m3) - real(r8), allocatable :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) - real(r8), allocatable :: naer(:,:,:) ! aerosol number MR (bounded!) (#/kg-air) - real(r8), allocatable :: dryvol(:,:,:) ! single-particle-mean dry volume (m3) - real(r8), allocatable :: so4dryvol(:,:,:) ! single-particle-mean so4 dry volume (m3) - real(r8), allocatable :: drymass(:,:,:) ! single-particle-mean dry mass (kg) - real(r8), allocatable :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) - - real(r8), allocatable :: wetrad(:,:,:) ! wet radius of aerosol (m) - real(r8), allocatable :: wetvol(:,:,:) ! single-particle-mean wet volume (m3) - real(r8), allocatable :: wtrvol(:,:,:) ! single-particle-mean water volume in wet aerosol (m3) - - real(r8), allocatable :: sulfeq(:,:,:) ! H2SO4 equilibrium mixing ratios over particles (mol/mol) - real(r8), allocatable :: wtpct(:,:,:) ! sulfate aerosol composition, weight % H2SO4 - real(r8), allocatable :: sulden(:,:,:) ! sulfate aerosol mass density (g/cm3) - - real(r8), allocatable :: specdens_1(:) - real(r8), allocatable :: alnsg(:) - real(r8), allocatable :: maer(:,:,:) ! accumulated aerosol mode MRs - - !----------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - - nmodes = aero_props%nbins() - - allocate( & - dgncur_a(ncol,nlev,nmodes), dgncur_awet(ncol,nlev,nmodes), & - qaerwat_m(ncol,nlev,nmodes), wetdens(ncol,nlev,nmodes), & - hygro(ncol,nlev,nmodes), dryvol(ncol,nlev,nmodes), & - dryrad(ncol,nlev,nmodes), drymass(ncol,nlev,nmodes), & - so4dryvol(ncol,nlev,nmodes), naer(ncol,nlev,nmodes), & - wetrad(ncol,nlev,nmodes), wetvol(ncol,nlev,nmodes), & - wtrvol(ncol,nlev,nmodes), wtpct(ncol,nlev,nmodes), & - sulden(ncol,nlev,nmodes), sulfeq(ncol,nlev,nmodes), & - specdens_1(nmodes), alnsg(nmodes), & - maer(ncol,nlev,nmodes), stat=istat) - if (istat > 0) then - errmsg = 'modal_aero_wateruptake_diag: unable to allocate work arrays' - errflg = 1 - return - end if - - ! dry size distribution parameters of the diagnostic list - call modal_aero_calcsize_diag_run( & - aero_props = aero_props, & - aero_state = aero_state, & - ncol = ncol, & - pver = nlev, & - top_lev = top_lev, & - pi = pi, & - dgncur_a = dgncur_a, & - errmsg = errmsg, & - errflg = errflg) - if (errflg /= 0) return - - ! Zero output fields (_run writes top_lev:nlev) - hygro(:,:,:) = 0._r8 - dryvol(:,:,:) = 0._r8 - dryrad(:,:,:) = 0._r8 - drymass(:,:,:) = 0._r8 - so4dryvol(:,:,:) = 0._r8 - naer(:,:,:) = 0._r8 - - call modal_aero_calcdry_run( & - aero_props = aero_props, & - aero_state = aero_state, & - ncol = ncol, & - pver = nlev, & - top_lev = top_lev, & - do_strat_sulfate = .false., & - pi = pi, & - dgncur_a = dgncur_a, & - hygro = hygro, & - dryvol = dryvol, & - dryrad = dryrad, & - drymass = drymass, & - so4dryvol = so4dryvol, & - naer = naer, & - errmsg = errmsg, & - errflg = errflg) - if (errflg /= 0) return - - ! Zero work arrays (_sub only writes top_lev:nlev). - ! dgncur_awet is an intent(in) of _sub read only under do_strat_sulfate; - ! zero it here for definedness before the post-processing fills it. - wetrad(:,:,:) = 0._r8 - wetvol(:,:,:) = 0._r8 - wtrvol(:,:,:) = 0._r8 - sulfeq(:,:,:) = 0._r8 - wtpct(:,:,:) = 0._r8 - sulden(:,:,:) = 0._r8 - maer(:,:,:) = 0._r8 - dgncur_awet(:,:,:) = 0._r8 - troplev(:) = 0 - - call modal_aero_wateruptake_sub( & - aero_props = aero_props, & - aero_state = aero_state, & - ncol = ncol, & - pver = nlev, & - top_lev = top_lev, & - do_strat_sulfate = .false., & - t = t, & - pmid = pmid, & - h2ommr = h2ommr, & - cldn = cldn, & - dryrad = dryrad, & - hygro = hygro, & - dryvol = dryvol, & - so4dryvol = so4dryvol, & - dgncur_awet = dgncur_awet, & - troplev = troplev, & - wetrad = wetrad, & - wetvol = wetvol, & - wtrvol = wtrvol, & - sulfeq = sulfeq, & - wtpct = wtpct, & - sulden = sulden, & - specdens_1 = specdens_1, & - alnsg_out = alnsg, & - maer = maer, & - errmsg = errmsg, & - errflg = errflg) - if (errflg /= 0) return - - ! Post-processing: wet density, qaerwat, dgncur_awet update - qaerwat_m = 0.0_r8 - - do m = 1, nmodes - - do k = top_lev, nlev - do i = 1, ncol - - dgncur_awet(i,k,m) = dgncur_a(i,k,m) * (wetrad(i,k,m)/dryrad(i,k,m)) - qaerwat_m(i,k,m) = rhoh2o*naer(i,k,m)*wtrvol(i,k,m) - - ! compute aerosol wet density (kg/m3) - if (wetvol(i,k,m) > 1.0e-30_r8) then - wetdens(i,k,m) = (drymass(i,k,m) + rhoh2o*wtrvol(i,k,m))/wetvol(i,k,m) - else - wetdens(i,k,m) = specdens_1(m) - end if - end do - end do - - end do ! modes - - dgnumwet(:ncol,:nlev) = dgncur_awet(:ncol,:nlev,bin_idx) - qaerwat (:ncol,:nlev) = qaerwat_m(:ncol,:nlev,bin_idx) - - deallocate( & - dgncur_a, dgncur_awet, qaerwat_m, wetdens, hygro, dryvol, dryrad, & - drymass, so4dryvol, naer, wetrad, wetvol, wtrvol, wtpct, sulden, & - sulfeq, specdens_1, alnsg, maer) - -end subroutine modal_aero_wateruptake_diag - -!---------------------------------------------------------------------- - -end module modal_aero_wateruptake diff --git a/src/physics/cam/aero_activate.F90 b/src/physics/cam/aero_activate.F90 deleted file mode 100644 index 3d7d139a9a..0000000000 --- a/src/physics/cam/aero_activate.F90 +++ /dev/null @@ -1,429 +0,0 @@ -module aero_activate - -! Portable (CCPP-ready) Abdul-Razzak & Ghan aerosol activation kernel -! (activate_aerosol), extracted from the CAM ndrop module. The derived -! constants aten and sqrt(pi) are computed once by aero_activate_init from host -! physical constants; activate_aerosol receives the remaining host physical -! constants as arguments and returns errmsg/errflg instead of aborting. The -! polymorphic aerosol_properties abstraction is deliberately host-portable. -! CAM interface / callers: ndrop, aero_convproc. - -use shr_kind_mod, only: r8 => shr_kind_r8 -use wv_saturation, only: qsat -use shr_spfn_mod, only: erf => shr_spfn_erf - -use aerosol_properties_mod, only: aerosol_properties - -implicit none -private - -public :: aero_activate_init, activate_aerosol - -! mathematical constants -real(r8), parameter :: zero = 0._r8 -real(r8), parameter :: third = 1._r8/3._r8 -real(r8), parameter :: twothird = 2._r8*third -real(r8), parameter :: sixth = 1._r8/6._r8 -real(r8), parameter :: sq2 = sqrt(2._r8) -real(r8), parameter :: tmelt = 273._r8 - -! derived constants (set by aero_activate_init) -real(r8) :: aten -real(r8) :: sqpi - -!=============================================================================== -contains -!=============================================================================== - -subroutine aero_activate_init(mwh2o, r_universal, rhoh2o, pi) - - ! Compute the derived activation constants from host physical constants. - ! surften (surface tension of water) is a fixed property of the activation - ! parameterization, so it is set here rather than threaded from the host. - - real(r8), intent(in) :: mwh2o ! molecular weight of water (kg/kmol) - real(r8), intent(in) :: r_universal ! universal gas constant (J/K/kmol) - real(r8), intent(in) :: rhoh2o ! density of liquid water (kg/m3) - real(r8), intent(in) :: pi ! pi - - real(r8) :: surften ! surface tension of water w/respect to air (N/m) - - surften = 0.076_r8 - aten = 2._r8*mwh2o*surften/(r_universal*tmelt*rhoh2o) - sqpi = sqrt(pi) - -end subroutine aero_activate_init - -!=============================================================================== - -subroutine activate_aerosol(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & - na, nbins, volume, hygro, aero_props, & - fn, fm, fluxn, fluxm, flux_fullact, & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, errmsg, errflg, & - smax_prescribed, in_cloud_in, smax_f) - - ! calculates number, surface, and mass fraction of aerosols activated as CCN - ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud - ! assumes an internal mixture within each of up to nbin multiple aerosol bins - ! a gaussiam spectrum of updrafts can be treated. - - ! mks units - - ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. - ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - ! input - - real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) - real(r8), intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) - real(r8), intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) - real(r8), intent(in) :: wminf ! minimum updraft velocity for integration (m/s) - real(r8), intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) - real(r8), intent(in) :: tair ! air temperature (K) - real(r8), intent(in) :: rhoair ! air density (kg/m3) - real(r8), intent(in) :: na(:) ! aerosol number concentration (/m3) - integer, intent(in) :: nbins ! number of aerosol bins - real(r8), intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) - real(r8), intent(in) :: hygro(:) ! hygroscopicity of aerosol mode - - class(aerosol_properties), intent(in) :: aero_props - - ! output - - real(r8), intent(out) :: fn(:) ! number fraction of aerosols activated - real(r8), intent(out) :: fm(:) ! mass fraction of aerosols activated - real(r8), intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) - real(r8), intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) - real(r8), intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) - ! rce-comment - ! used for consistency check -- this should match (ekd(k)*zs(k)) - ! also, fluxm/flux_fullact gives fraction of aerosol mass flux - ! that is activated - - ! host physical constants (from physconst) + error handling - real(r8), intent(in) :: pi ! pi - real(r8), intent(in) :: rhoh2o ! density of liquid water (kg/m3) - real(r8), intent(in) :: rh2o ! water vapor gas constant (J/K/kg) - real(r8), intent(in) :: gravit ! gravitational acceleration (m/s2) - real(r8), intent(in) :: latvap ! latent heat of vaporization (J/kg) - real(r8), intent(in) :: cpair ! specific heat of dry air (J/K/kg) - real(r8), intent(in) :: rair ! dry air gas constant (J/K/kg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! optional - real(r8), optional, intent(in) :: smax_prescribed ! prescribed max. supersaturation for secondary activation - logical, optional, intent(in) :: in_cloud_in ! switch to modify calculations when above cloud base - real(r8), optional, intent(in) :: smax_f ! droplet and rain size distr factor in the smax calculation - ! used when in_cloud=.true. - - ! local - - integer, parameter:: nx=200 - real(r8) integ,integf - real(r8), parameter :: p0 = 1013.25e2_r8 ! reference pressure (Pa) - real(r8) pres ! pressure (Pa) - real(r8) diff0,conduct0 - real(r8) es ! saturation vapor pressure - real(r8) qs ! water vapor saturation mixing ratio - real(r8) dqsdt ! change in qs with temperature - real(r8) g ! thermodynamic function (m2/s) - real(r8) zeta(nbins), eta(nbins) - real(r8) alpha - real(r8) gamma - real(r8) beta - real(r8) sqrtg - real(r8) :: amcube(nbins) ! cube of dry bin radius (m) - real(r8) smc(nbins) ! critical supersaturation for number bin radius - real(r8) sumflx_fullact - real(r8) sumflxn(nbins) - real(r8) sumflxm(nbins) - real(r8) sumfn(nbins) - real(r8) sumfm(nbins) - real(r8) fnold(nbins) ! number fraction activated - real(r8) fmold(nbins) ! mass fraction activated - real(r8) wold,gold - real(r8) wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb - real(r8) dfmin,dfmax,fnew,fold,fnmin,fnbar,fmbar - real(r8) alw,sqrtalw - real(r8) smax - real(r8) z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf - real(r8) etafactor1,etafactor2(nbins),etafactor2max - real(r8) grow - character(len=*), parameter :: subname='activate_aerosol' - - logical :: in_cloud - integer m,n - ! numerical integration parameters - real(r8), parameter :: eps=0.3_r8,fmax=0.99_r8,sds=3._r8 - - real(r8), parameter :: namin=1.e6_r8 ! minimum aerosol number concentration (/m3) - - errmsg = '' - errflg = 0 - - if (present(in_cloud_in)) then - if (.not. present(smax_f)) then - errmsg = subname//' error: smax_f must be supplied when in_cloud is used' - errflg = 1 - return - end if - in_cloud = in_cloud_in - else - in_cloud = .false. - end if - - fn(:)=0._r8 - fm(:)=0._r8 - fluxn(:)=0._r8 - fluxm(:)=0._r8 - flux_fullact=0._r8 - - if(nbins.eq.1.and.na(1).lt.1.e-20_r8)return - - if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return - - if ( present( smax_prescribed ) ) then - if (smax_prescribed <= 0.0_r8) return - end if - - pres=rair*rhoair*tair - diff0=0.211e-4_r8*(p0/pres)*(tair/tmelt)**1.94_r8 - conduct0=(5.69_r8+0.017_r8*(tair-tmelt))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg - call qsat(tair, pres, es, qs) - dqsdt=latvap/(rh2o*tair*tair)*qs - alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) - gamma=(1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) - etafactor2max=1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. - - grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) & - + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) - sqrtg = sqrt(grow) - beta = 2._r8*pi*rhoh2o*grow*gamma - - do m=1,nbins - - if(volume(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then - ! number mode radius (m) - amcube(m)=aero_props%amcube(m, volume(m),na(m)) - ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 - ! should depend on mean radius of mode to account for gas kinetic effects - ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 - ! for approriate size to use for effective diffusivity. - etafactor2(m)=1._r8/(na(m)*beta*sqrtg) - if(hygro(m).gt.1.e-10_r8)then - smc(m)=2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist - else - smc(m)=100._r8 - endif - else - smc(m)=1._r8 - etafactor2(m)=etafactor2max ! this should make eta big if na is very small. - endif - - enddo - - if(sigw.gt.1.e-5_r8)then ! spectrum of updrafts - - wmax=min(wmaxf,wbar+sds*sigw) - wmin=max(wminf,-wdiab) - wmin=max(wmin,wbar-sds*sigw) - w=wmin - dwmax=eps*sigw - dw=dwmax - dfmax=0.2_r8 - dfmin=0.1_r8 - if (wmax <= w) return - do m=1,nbins - sumflxn(m)=0._r8 - sumfn(m)=0._r8 - fnold(m)=0._r8 - sumflxm(m)=0._r8 - sumfm(m)=0._r8 - fmold(m)=0._r8 - enddo - sumflx_fullact=0._r8 - - fold=0._r8 - wold=0._r8 - gold=0._r8 - - dwmin = min( dwmax, 0.01_r8 ) - do n = 1, nx - -100 wnuc=w+wdiab - ! write(iulog,*)'wnuc=',wnuc - alw=alpha*wnuc - sqrtalw=sqrt(alw) - etafactor1=alw*sqrtalw - - do m=1,nbins - eta(m)=etafactor1*etafactor2(m) - zeta(m)=twothird*sqrtalw*aten/sqrtg - enddo - - if ( present( smax_prescribed ) ) then - smax = smax_prescribed - else - smax = aero_props%maxsat(zeta,eta,smc) - endif - - call aero_props%actfracs( nbins, smc(nbins), smax, fnew, fm(nbins) ) - - dwnew = dw - if(fnew-fold.gt.dfmax.and.n.gt.1)then - ! reduce updraft increment for greater accuracy in integration - if (dw .gt. 1.01_r8*dwmin) then - dw=0.7_r8*dw - dw=max(dw,dwmin) - w=wold+dw - go to 100 - else - dwnew = dwmin - endif - endif - - if(fnew-fold.lt.dfmin)then - ! increase updraft increment to accelerate integration - dwnew=min(1.5_r8*dw,dwmax) - endif - fold=fnew - - z=(w-wbar)/(sigw*sq2) - g=exp(-z*z) - fnmin=1._r8 - - do m=1,nbins - ! modal - call aero_props%actfracs( m, smc(m), smax, fn(m), fm(m) ) - fnmin=min(fn(m),fnmin) - ! integration is second order accurate - ! assumes linear variation of f*g with w - fnbar=(fn(m)*g+fnold(m)*gold) - fmbar=(fm(m)*g+fmold(m)*gold) - wb=(w+wold) - if(w.gt.0._r8)then - sumflxn(m)=sumflxn(m)+sixth*(wb*fnbar & - +(fn(m)*g*w+fnold(m)*gold*wold))*dw - sumflxm(m)=sumflxm(m)+sixth*(wb*fmbar & - +(fm(m)*g*w+fmold(m)*gold*wold))*dw - endif - sumfn(m)=sumfn(m)+0.5_r8*fnbar*dw - fnold(m)=fn(m) - sumfm(m)=sumfm(m)+0.5_r8*fmbar*dw - fmold(m)=fm(m) - enddo - ! same form as sumflxm but replace the fm with 1.0 - sumflx_fullact = sumflx_fullact & - + sixth*(wb*(g+gold) + (g*w+gold*wold))*dw - gold=g - wold=w - dw=dwnew - if (n > 1 .and. (w > wmax .or. fnmin > fmax)) exit - w=w+dw - if (n == nx) then - errmsg = subname//' -- do loop is too short in activate' - errflg = 1 - return - end if - - enddo - - if(w.lt.wmaxf)then - - ! contribution from all updrafts stronger than wmax - ! assuming constant f (close to fmax) - wnuc=w+wdiab - - z1=(w-wbar)/(sigw*sq2) - z2=(wmaxf-wbar)/(sigw*sq2) - g=exp(-z1*z1) - integ=sigw*0.5_r8*sq2*sqpi*(erf(z2)-erf(z1)) - ! consider only upward flow into cloud base when estimating flux - wf1=max(w,zero) - zf1=(wf1-wbar)/(sigw*sq2) - gf1=exp(-zf1*zf1) - wf2=max(wmaxf,zero) - zf2=(wf2-wbar)/(sigw*sq2) - gf2=exp(-zf2*zf2) - gf=(gf1-gf2) - integf=wbar*sigw*0.5_r8*sq2*sqpi*(erf(zf2)-erf(zf1))+sigw*sigw*gf - - do m=1,nbins - sumflxn(m)=sumflxn(m)+integf*fn(m) - sumfn(m)=sumfn(m)+fn(m)*integ - sumflxm(m)=sumflxm(m)+integf*fm(m) - sumfm(m)=sumfm(m)+fm(m)*integ - enddo - ! same form as sumflxm but replace the fm with 1.0 - sumflx_fullact = sumflx_fullact + integf - ! sumg=sumg+integ - endif - - - do m=1,nbins - fn(m)=sumfn(m)/(sq2*sqpi*sigw) - ! fn(m)=sumfn(m)/(sumg) - if(fn(m).gt.1.01_r8)then - errmsg = 'activate -- fn > 1' - errflg = 1 - return - endif - fluxn(m)=sumflxn(m)/(sq2*sqpi*sigw) - fm(m)=sumfm(m)/(sq2*sqpi*sigw) - ! fm(m)=sumfm(m)/(sumg) - fluxm(m)=sumflxm(m)/(sq2*sqpi*sigw) - enddo - ! same form as fluxm - flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) - - else - - ! single updraft - wnuc=wbar+wdiab - - if(wnuc.gt.0._r8)then - - w=wbar - - if(in_cloud) then - - if (smax_f > 0._r8) then - smax = alpha*w/(2.0_r8*pi*rhoh2o*grow*gamma*smax_f) - else - smax = 1.e-20_r8 - end if - - else ! at cloud base - alw = alpha*wnuc - sqrtalw = sqrt(alw) - etafactor1 = alw*sqrtalw - - do m = 1, nbins - eta(m) = etafactor1*etafactor2(m) - zeta(m) = twothird*sqrtalw*aten/sqrtg - end do - if ( present(smax_prescribed) ) then - smax = smax_prescribed - else - smax = aero_props%maxsat(zeta,eta,smc) - end if - end if - - do m=1,nbins - - call aero_props%actfracs( m, smc(m), smax, fn(m), fm(m) ) - - if(wbar.gt.0._r8)then - fluxn(m)=fn(m)*w - fluxm(m)=fm(m)*w - endif - enddo - flux_fullact = w - endif - - endif - -end subroutine activate_aerosol - -end module aero_activate diff --git a/src/physics/cam/ndrop.F90 b/src/physics/cam/ndrop.F90 deleted file mode 100644 index f53d431af3..0000000000 --- a/src/physics/cam/ndrop.F90 +++ /dev/null @@ -1,1075 +0,0 @@ -module ndrop - -!--------------------------------------------------------------------------------- -! Purpose: -! Droplet activation and vertical mixing by modal (or bin) aerosols -! (dropmixnuc). Portable science routines split from the CAM interface, -! which now lives in microp_aero.F90. Aerosol access is polymorphic through -! aerosol_properties/aerosol_state; host physical constants are provided by -! ndrop_init; array sizing is by runtime ncol/pver. -! -! ***N.B.*** This module is currently hardcoded to recognize only the modes that -! affect the climate calculation. This is implemented by using list -! index 0 in all the calls to rad_constituent interfaces. -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8 => shr_kind_r8, shr_kind_cs -use shr_spfn_mod, only: erf => shr_spfn_erf - -use aerosol_properties_mod, only: aerosol_properties -use aerosol_state_mod, only: aerosol_state, ptr2d_t - -use aero_activate, only: aero_activate_init, activate_aerosol - -implicit none -private -save - -public ndrop_init, dropmixnuc -public psat ! needed by the CAM interface to size the ccn diagnostic - -! mathematical constants -real(r8), parameter :: zero = 0._r8 -real(r8), parameter :: third = 1._r8/3._r8 -real(r8), parameter :: twothird = 2._r8*third -real(r8), parameter :: sq2 = sqrt(2._r8) -real(r8), parameter :: surften = 0.076_r8 - -! CCN diagnostic fields -integer, parameter :: psat=6 ! number of supersaturations to calc ccn concentration -real(r8), parameter :: supersat(psat)= & ! supersaturation (%) to determine ccn concentration - (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) - -! host physical constants (set by ndrop_init) -real(r8) :: pi ! pi -real(r8) :: rhoh2o ! density of liquid water (kg/m3) -real(r8) :: mwh2o ! molecular weight of water (kg/kmol) -real(r8) :: r_universal ! universal gas constant (J/K/kmol) -real(r8) :: rh2o ! water vapor gas constant (J/K/kg) -real(r8) :: gravit ! gravitational acceleration (m/s2) -real(r8) :: latvap ! latent heat of vaporization (J/kg) -real(r8) :: cpair ! specific heat of dry air (J/K/kg) -real(r8) :: rair ! dry air gas constant (J/K/kg) - -real(r8) :: sq2pi ! sqrt(2*pi), derived from host pi by ndrop_init - -integer :: nbin ! number of bins - -!=============================================================================== -contains -!=============================================================================== - -subroutine ndrop_init(aero_props, pi_in, rhoh2o_in, mwh2o_in, r_universal_in, & - rh2o_in, gravit_in, latvap_in, cpair_in, rair_in) - - class(aerosol_properties), intent(in) :: aero_props - - ! host physical constants - real(r8), intent(in) :: pi_in ! pi - real(r8), intent(in) :: rhoh2o_in ! density of liquid water (kg/m3) - real(r8), intent(in) :: mwh2o_in ! molecular weight of water (kg/kmol) - real(r8), intent(in) :: r_universal_in ! universal gas constant (J/K/kmol) - real(r8), intent(in) :: rh2o_in ! water vapor gas constant (J/K/kg) - real(r8), intent(in) :: gravit_in ! gravitational acceleration (m/s2) - real(r8), intent(in) :: latvap_in ! latent heat of vaporization (J/kg) - real(r8), intent(in) :: cpair_in ! specific heat of dry air (J/K/kg) - real(r8), intent(in) :: rair_in ! dry air gas constant (J/K/kg) - - !------------------------------------------------------------------------------- - - pi = pi_in - rhoh2o = rhoh2o_in - mwh2o = mwh2o_in - r_universal = r_universal_in - rh2o = rh2o_in - gravit = gravit_in - latvap = latvap_in - cpair = cpair_in - rair = rair_in - - sq2pi = sqrt(2._r8*pi) - - call aero_activate_init(mwh2o, r_universal, rhoh2o, pi) - - nbin = aero_props%nbins() - -end subroutine ndrop_init - -!=============================================================================== - -subroutine dropmixnuc( aero_props, aero_state, & - ncol, pver, top_lev, dtmicro, & - temp, pmid, pint, pdel, rpdel, zm, kvh, ncldwtr, & - wsub, wmixmin, cldn, cldo, cldliqf, & - dotend, raertend_out, tendnd, factnum, & - wtke, nsource, ndropmix, ndropcol, & - ccn, coltend, coltend_cw, & - errmsg, errflg) - - ! vertical diffusion and nucleation of cloud droplets - ! assume cloud presence controlled by cloud fraction - ! doesn't distinguish between warm, cold clouds - - ! arguments - class(aerosol_properties), intent(in) :: aero_props - class(aerosol_state), intent(in) :: aero_state - - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: pver ! number of vertical layers - integer, intent(in) :: top_lev ! top level for cloud physics - real(r8), intent(in) :: dtmicro ! time step for microphysics (s) - real(r8), intent(in) :: temp(:,:) ! temperature (K) - real(r8), intent(in) :: pmid(:,:) ! mid-level pressure (Pa) - real(r8), intent(in) :: pint(:,:) ! pressure at layer interfaces (Pa) - real(r8), intent(in) :: pdel(:,:) ! pressure thickess of layer (Pa) - real(r8), intent(in) :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) - real(r8), intent(in) :: zm(:,:) ! geopotential height of level (m) - real(r8), intent(in) :: kvh(:,:) ! vertical diffusivity (m2/s), interfaces - real(r8), intent(in) :: ncldwtr(:,:)! droplet number concentration (#/kg) - real(r8), intent(in) :: wsub(:,:) ! subgrid vertical velocity - real(r8), intent(in) :: wmixmin ! minimum turbulence vertical velocity (m/s) - real(r8), intent(in) :: cldn(:,:) ! cloud fraction - real(r8), intent(in) :: cldo(:,:) ! cloud fraction on previous time step - real(r8), intent(in) :: cldliqf(:,:)! liquid cloud fraction (liquid / (liquid + ice)) - logical, intent(in) :: dotend(:) ! (nele_tot) true for aerosol elements resolving to - ! advected constituents: tendency returned in raertend_out. - ! false elements are updated in place through the - ! aero_state interstitial pointers. - - ! output arguments - real(r8), intent(out) :: raertend_out(:,:,:) ! (ncol,pver,nele_tot) tendency of interstitial aerosol - ! mass, number mixing ratios, only where dotend is true - real(r8), intent(out) :: tendnd(:,:) ! change in droplet number concentration (#/kg/s) - real(r8), intent(out) :: factnum(:,:,:) ! activation fraction for aerosol number - real(r8), intent(out) :: wtke(:,:) ! turbulent vertical velocity at base of layer k (m/s) - real(r8), intent(out) :: nsource(:,:) ! droplet number source (#/kg/s) - real(r8), intent(out) :: ndropmix(:,:) ! droplet number mixing (#/kg/s) - real(r8), intent(out) :: ndropcol(:) ! column droplet number (#/m2) - real(r8), intent(out) :: ccn(:,:,:) ! (ncol,pver,psat) number conc of aerosols activated at supersat (#/cm3) - real(r8), intent(out) :: coltend(:,:) ! (ncol,nele_tot) column tendency for diagnostic output - real(r8), intent(out) :: coltend_cw(:,:) ! (ncol,nele_tot) column tendency - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - !--------------------Local storage------------------------------------- - - integer :: nele_tot ! total number of aerosol elements - - type(ptr2d_t), allocatable :: raer(:) ! aerosol mass, number mixing ratios - type(ptr2d_t), allocatable :: qqcw(:) - real(r8) :: raertend(pver) ! tendency of aerosol mass, number mixing ratios - real(r8) :: qqcwtend(pver) ! tendency of cloudborne aerosol mass, number mixing ratios - - real(r8), parameter :: zkmin = 0.01_r8, zkmax = 100._r8 - integer :: i, k, l, m, mm, n - integer :: km1, kp1 - integer :: nnew, nsav, ntemp - integer :: nsubmix, nsubmix_bnd - integer, save :: count_submix(100) - integer :: phase ! phase of aerosol - - real(r8) :: arg - real(r8) :: dtinv - - real(r8) :: dtmin, tinv, dtt - real(r8) :: lcldn(ncol,pver) - real(r8) :: lcldo(ncol,pver) - - real(r8) :: zs(pver) ! inverse of distance between levels (m) - real(r8) :: qcld(pver) ! cloud droplet number mixing ratio (#/kg) - real(r8) :: qncld(pver) ! droplet number nucleated on cloud boundaries - real(r8) :: srcn(pver) ! droplet source rate (/s) - real(r8) :: cs(ncol,pver) ! air density (kg/m3) - real(r8) :: csbot(pver) ! air density at bottom (interface) of layer (kg/m3) - real(r8) :: csbot_cscen(pver) ! csbot(i)/cs(i,k) - real(r8) :: dz(ncol,pver) ! geometric thickness of layers (m) - - real(r8) :: wtke_cen(ncol,pver) ! turbulent vertical velocity at center of layer k (m/s) - real(r8) :: wbar, wmix, wmin, wmax - - real(r8) :: zn(pver) ! g/pdel (m2/g) for layer - real(r8) :: flxconv ! convergence of flux into lowest layer - - real(r8) :: wdiab ! diabatic vertical velocity - real(r8) :: ekd(pver) ! diffusivity for droplets (m2/s) - real(r8) :: ekk(0:pver) ! density*diffusivity for droplets (kg/m3 m2/s) - real(r8) :: ekkp(pver) ! zn*zs*density*diffusivity - real(r8) :: ekkm(pver) ! zn*zs*density*diffusivity - - real(r8) :: dum, dumc - real(r8) :: tmpa - real(r8) :: dact - real(r8) :: fluxntot ! (#/cm2/s) - real(r8) :: dtmix - real(r8) :: alogarg - real(r8) :: overlapp(pver), overlapm(pver) ! cloud overlap - - real(r8) :: cldo_tmp, cldn_tmp - real(r8) :: tau_cld_regenerate - real(r8) :: taumix_internal_pver_inv ! 1/(internal mixing time scale for k=pver) (1/s) - - - real(r8), allocatable :: nact(:,:) ! fractional aero. number activation rate (/s) - real(r8), allocatable :: mact(:,:) ! fractional aero. mass activation rate (/s) - - real(r8), allocatable :: raercol(:,:,:) ! single column of aerosol mass, number mixing ratios - real(r8), allocatable :: raercol_cw(:,:,:) ! same as raercol but for cloud-borne phase - - - real(r8) :: na(ncol,pver,nbin), va(ncol,pver,nbin), hy(ncol,pver,nbin) - real(r8), allocatable :: naermod(:) ! (1/m3) - real(r8), allocatable :: hygro(:) ! hygroscopicity of aerosol mode - real(r8), allocatable :: vaerosol(:) ! interstit+activated aerosol volume conc (cm3/cm3) - - real(r8) :: source(pver) - - real(r8), allocatable :: fn(:) ! activation fraction for aerosol number - real(r8), allocatable :: fm(:) ! activation fraction for aerosol mass - - real(r8), allocatable :: fluxn(:) ! number activation fraction flux (cm/s) - real(r8), allocatable :: fluxm(:) ! mass activation fraction flux (cm/s) - real(r8) :: flux_fullact(pver) ! 100% activation fraction flux (cm/s) - ! note: activation fraction fluxes are defined as - ! fluxn = [flux of activated aero. number into cloud (#/cm2/s)] - ! / [aero. number conc. in updraft, just below cloudbase (#/cm3)] - - - integer :: errnum - character(len=shr_kind_cs) :: errstr - !------------------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - - nele_tot = aero_props%ncnst_tot() - - ! Create the liquid weighted cloud fractions that were passsed in - ! before. This doesn't seem like the best variable, since the cloud could - ! have liquid condensate, but the part of it that is changing could be the - ! ice portion; however, this is what was done before. - lcldo(:ncol,:) = cldo(:ncol,:) * cldliqf(:ncol,:) - lcldn(:ncol,:) = cldn(:ncol,:) * cldliqf(:ncol,:) - - - arg = 1.0_r8 - if (abs(0.8427_r8 - erf(arg))/0.8427_r8 > 0.001_r8) then - write(errmsg,*) 'dropmixnuc: Error function error, erf(1.0) = ',ERF(arg) - errflg = 1 - return - endif - arg = 0.0_r8 - if (erf(arg) /= 0.0_r8) then - write(errmsg,*) 'dropmixnuc: Error function error, erf(0.0) = ',erf(arg) - errflg = 1 - return - endif - - dtinv = 1._r8/dtmicro - - allocate( & - nact(pver,nbin), & - mact(pver,nbin), & - raer(nele_tot), & - qqcw(nele_tot), & - raercol(pver,nele_tot,2), & - raercol_cw(pver,nele_tot,2), & - naermod(nbin), & - hygro(nbin), & - vaerosol(nbin), & - fn(nbin), & - fm(nbin), & - fluxn(nbin), & - fluxm(nbin) ) - - ! Init pointers to mode number and specie mass mixing ratios in - ! intersitial and cloud borne phases. - call aero_state%get_states( aero_props, raer, qqcw ) - - factnum = 0._r8 - wtke = 0._r8 - nsource = 0._r8 - ndropmix = 0._r8 - ndropcol = 0._r8 - tendnd = 0._r8 - raertend_out = 0._r8 - - ! air density (kg/m3) - cs(:ncol,:) = pmid(:ncol,:)/(rair*temp(:ncol,:)) - - phase = 1 ! interstitial - do m = 1, nbin - call aero_state%loadaer( aero_props, & - ncol, pver, & - m, cs, phase, na(:,:,m), va(:,:,m), & - hy(:,:,m), errnum, errstr) - if (errnum/=0) then - errmsg = 'dropmixnuc : '//trim(errstr) - errflg = 1 - return - end if - end do - - ! overall_main_i_loop - do i = 1, ncol - - do k = top_lev, pver-1 - zs(k) = 1._r8/(zm(i,k) - zm(i,k+1)) - end do - zs(pver) = zs(pver-1) - - ! load number nucleated into qcld on cloud boundaries - - do k = top_lev, pver - - qcld(k) = ncldwtr(i,k) - qncld(k) = 0._r8 - srcn(k) = 0._r8 - dz(i,k) = 1._r8/(cs(i,k)*gravit*rpdel(i,k)) ! layer thickness in m - - do m = 1, nbin - nact(k,m) = 0._r8 - mact(k,m) = 0._r8 - end do - - zn(k) = gravit*rpdel(i,k) - - if (k < pver) then - ekd(k) = kvh(i,k+1) - ekd(k) = max(ekd(k), zkmin) - ekd(k) = min(ekd(k), zkmax) - csbot(k) = 2.0_r8*pint(i,k+1)/(rair*(temp(i,k) + temp(i,k+1))) - csbot_cscen(k) = csbot(k)/cs(i,k) - else - ekd(k) = 0._r8 - csbot(k) = cs(i,k) - csbot_cscen(k) = 1.0_r8 - end if - - ! rce-comment - define wtke at layer centers for new-cloud activation - ! and at layer boundaries for old-cloud activation - wtke_cen(i,k) = wsub(i,k) - wtke(i,k) = wsub(i,k) - wtke_cen(i,k) = max(wtke_cen(i,k), wmixmin) - wtke(i,k) = max(wtke(i,k), wmixmin) - - nsource(i,k) = 0._r8 - - end do - - nsav = 1 - nnew = 2 - - do mm = 1,nele_tot - raercol_cw(:,mm,nsav) = 0.0_r8 - raercol(:,mm,nsav) = 0.0_r8 - raercol_cw(top_lev:pver,mm,nsav) = qqcw(mm)%fld(i,top_lev:pver) - raercol(top_lev:pver,mm,nsav) = raer(mm)%fld(i,top_lev:pver) - end do - - ! droplet nucleation/aerosol activation - - ! tau_cld_regenerate = time scale for regeneration of cloudy air - ! by (horizontal) exchange with clear air - tau_cld_regenerate = 3600.0_r8 * 3.0_r8 - - ! k-loop for growing/shrinking cloud calcs ............................. - ! grow_shrink_main_k_loop: & - do k = top_lev, pver - - ! This code was designed for liquid clouds, but the cloudbourne - ! aerosol can be either from liquid or ice clouds. For the ice clouds, - ! we do not do regeneration, but as cloud fraction decreases the - ! aerosols should be returned interstitial. The lack of a liquid cloud - ! should not mean that all of the aerosol is realease. Therefor a - ! section has been added for shrinking ice clouds and checks were added - ! to protect ice cloudbourne aerosols from being released when no - ! liquid cloud is present. - - ! shrinking ice cloud ...................................................... - cldo_tmp = cldo(i,k) * (1._r8 - cldliqf(i,k)) - cldn_tmp = cldn(i,k) * (1._r8 - cldliqf(i,k)) - - if (cldn_tmp < cldo_tmp) then - - ! convert activated aerosol to interstitial in decaying cloud - - dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * (1._r8 - cldliqf(i,k)) - do mm = 1,nele_tot - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - end do - - end if - - ! shrinking liquid cloud ...................................................... - ! treat the reduction of cloud fraction from when cldn(i,k) < cldo(i,k) - ! and also dissipate the portion of the cloud that will be regenerated - cldo_tmp = lcldo(i,k) - cldn_tmp = lcldn(i,k) * exp( -dtmicro/tau_cld_regenerate ) - ! alternate formulation - ! cldn_tmp = cldn(i,k) * max( 0.0_r8, (1.0_r8-dtmicro/tau_cld_regenerate) ) - - ! fraction is also provided. - if (cldn_tmp < cldo_tmp) then - ! droplet loss in decaying cloud - !++ sungsup - nsource(i,k) = nsource(i,k) + qcld(k)*(cldn_tmp - cldo_tmp)/cldo_tmp*cldliqf(i,k)*dtinv - qcld(k) = qcld(k)*(1._r8 + (cldn_tmp - cldo_tmp)/cldo_tmp) - !-- sungsup - - ! convert activated aerosol to interstitial in decaying cloud - - dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * cldliqf(i,k) - do mm = 1,nele_tot - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - end do - - end if - - ! growing liquid cloud ...................................................... - ! treat the increase of cloud fraction from when cldn(i,k) > cldo(i,k) - ! and also regenerate part of the cloud - cldo_tmp = cldn_tmp - cldn_tmp = lcldn(i,k) - - if (cldn_tmp-cldo_tmp > 0.01_r8) then - - ! rce-comment - use wtke at layer centers for new-cloud activation - wbar = wtke_cen(i,k) - wmix = 0._r8 - wmin = 0._r8 - wmax = 10._r8 - wdiab = 0._r8 - - ! load aerosol properties, assuming external mixtures - - do m = 1, nbin - naermod(m) = na(i,k,m) - vaerosol(m) = va(i,k,m) - hygro(m) = hy(i,k,m) - end do - - call activate_aerosol( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, nbin, & - vaerosol, hygro, aero_props, fn, fm, fluxn, & - fluxm,flux_fullact(k), & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & - errmsg, errflg) - if (errflg /= 0) return - - factnum(i,k,:) = fn - - dumc = (cldn_tmp - cldo_tmp) - - do m = 1, nbin - mm = aero_props%indexer(m,0) - dact = dumc*fn(m)*raer(mm)%fld(i,k) ! interstitial only - qcld(k) = qcld(k) + dact - nsource(i,k) = nsource(i,k) + dact*dtinv - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - dum = dumc*fm(m) - do l = 1,aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - dact = dum*raer(mm)%fld(i,k) ! interstitial only - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - enddo - enddo - - endif - - enddo ! grow_shrink_main_k_loop - ! end of k-loop for growing/shrinking cloud calcs ...................... - - ! ...................................................................... - ! start of k-loop for calc of old cloud activation tendencies .......... - ! - ! rce-comment - ! changed this part of code to use current cloud fraction (cldn) exclusively - ! consider case of cldo(:)=0, cldn(k)=1, cldn(k+1)=0 - ! previous code (which used cldo below here) would have no cloud-base activation - ! into layer k. however, activated particles in k mix out to k+1, - ! so they are incorrectly depleted with no replacement - - ! old_cloud_main_k_loop - do k = top_lev, pver - kp1 = min0(k+1, pver) - taumix_internal_pver_inv = 0.0_r8 - - if (lcldn(i,k) > 0.01_r8) then - - wdiab = 0._r8 - wmix = 0._r8 ! single updraft - wbar = wtke(i,k) ! single updraft - if (k == pver) wbar = wtke_cen(i,k) ! single updraft - wmax = 10._r8 - wmin = 0._r8 - - if (lcldn(i,k) - lcldn(i,kp1) > 0.01_r8 .or. k == pver) then - - ! cloud base - - ! ekd(k) = wtke(i,k)*dz(i,k)/sq2pi - ! rce-comments - ! first, should probably have 1/zs(k) here rather than dz(i,k) because - ! the turbulent flux is proportional to ekd(k)*zs(k), - ! while the dz(i,k) is used to get flux divergences - ! and mixing ratio tendency/change - ! second and more importantly, using a single updraft velocity here - ! means having monodisperse turbulent updraft and downdrafts. - ! The sq2pi factor assumes a normal draft spectrum. - ! The fluxn/fluxm from activate must be consistent with the - ! fluxes calculated in explmix. - ekd(k) = wbar/zs(k) - - alogarg = max(1.e-20_r8, 1._r8/lcldn(i,k) - 1._r8) - wmin = wbar + wmix*0.25_r8*sq2pi*log(alogarg) - - do m = 1, nbin - ! rce-comment - use kp1 here as old-cloud activation involves - ! aerosol from layer below - naermod(m) = na(i,kp1,m) - vaerosol(m) = va(i,kp1,m) - hygro(m) = hy(i,kp1,m) - end do - - call activate_aerosol( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, nbin, & - vaerosol, hygro, aero_props, fn, fm, fluxn, & - fluxm, flux_fullact(k), & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & - errmsg, errflg) - if (errflg /= 0) return - - factnum(i,k,:) = fn - - if (k < pver) then - dumc = lcldn(i,k) - lcldn(i,kp1) - else - dumc = lcldn(i,k) - endif - - fluxntot = 0 - - ! rce-comment 1 - ! flux of activated mass into layer k (in kg/m2/s) - ! = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k) - ! source of activated mass (in kg/kg/s) = flux divergence - ! = actmassflux/(cs(i,k)*dz(i,k)) - ! so need factor of csbot_cscen = csbot(k)/cs(i,k) - ! dum=1./(dz(i,k)) - dum=csbot_cscen(k)/(dz(i,k)) - - ! rce-comment 2 - ! code for k=pver was changed to use the following conceptual model - ! in k=pver, there can be no cloud-base activation unless one considers - ! a scenario such as the layer being partially cloudy, - ! with clear air at bottom and cloudy air at top - ! assume this scenario, and that the clear/cloudy portions mix with - ! a timescale taumix_internal = dz(i,pver)/wtke_cen(i,pver) - ! in the absence of other sources/sinks, qact (the activated particle - ! mixratio) attains a steady state value given by - ! qact_ss = fcloud*fact*qtot - ! where fcloud is cloud fraction, fact is activation fraction, - ! qtot=qact+qint, qint is interstitial particle mixratio - ! the activation rate (from mixing within the layer) can now be - ! written as - ! d(qact)/dt = (qact_ss - qact)/taumix_internal - ! = qtot*(fcloud*fact*wtke/dz) - qact*(wtke/dz) - ! note that (fcloud*fact*wtke/dz) is equal to the nact/mact - ! also, d(qact)/dt can be negative. in the code below - ! it is forced to be >= 0 - ! - ! steve -- - ! you will likely want to change this. i did not really understand - ! what was previously being done in k=pver - ! in the cam3_5_3 code, wtke(i,pver) appears to be equal to the - ! droplet deposition velocity which is quite small - ! in the cam3_5_37 version, wtke is done differently and is much - ! larger in k=pver, so the activation is stronger there - ! - if (k == pver) then - taumix_internal_pver_inv = flux_fullact(k)/dz(i,k) - end if - - do m = 1, nbin - mm = aero_props%indexer(m,0) - fluxn(m) = fluxn(m)*dumc - fluxm(m) = fluxm(m)*dumc - nact(k,m) = nact(k,m) + fluxn(m)*dum - mact(k,m) = mact(k,m) + fluxm(m)*dum - if (k < pver) then - ! note that kp1 is used here - fluxntot = fluxntot & - + fluxn(m)*raercol(kp1,mm,nsav)*cs(i,k) - else - tmpa = raercol(kp1,mm,nsav)*fluxn(m) & - + raercol_cw(kp1,mm,nsav)*(fluxn(m) & - - taumix_internal_pver_inv*dz(i,k)) - fluxntot = fluxntot + max(0.0_r8, tmpa)*cs(i,k) - end if - end do - srcn(k) = srcn(k) + fluxntot/(cs(i,k)*dz(i,k)) - nsource(i,k) = nsource(i,k) + fluxntot/(cs(i,k)*dz(i,k)) - - endif ! (cldn(i,k) - cldn(i,kp1) > 0.01 .or. k == pver) - - else - - ! no liquid cloud - nsource(i,k) = nsource(i,k) - qcld(k)*dtinv - qcld(k) = 0 - - if (cldn(i,k) < 0.01_r8) then - ! no ice cloud either - - ! convert activated aerosol to interstitial in decaying cloud - - do mm = 1,nele_tot - raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol - raercol_cw(k,mm,nsav) = 0._r8 - end do - - end if - end if - - end do ! old_cloud_main_k_loop - - ! switch nsav, nnew so that nnew is the updated aerosol - ntemp = nsav - nsav = nnew - nnew = ntemp - - ! load new droplets in layers above, below clouds - - dtmin = dtmicro - ekk(top_lev-1) = 0.0_r8 - ekk(pver) = 0.0_r8 - do k = top_lev, pver-1 - ! rce-comment -- ekd(k) is eddy-diffusivity at k/k+1 interface - ! want ekk(k) = ekd(k) * (density at k/k+1 interface) - ! so use pint(i,k+1) as pint is 1:pverp - ! ekk(k)=ekd(k)*2.*pint(i,k)/(rair*(temp(i,k)+temp(i,k+1))) - ! ekk(k)=ekd(k)*2.*pint(i,k+1)/(rair*(temp(i,k)+temp(i,k+1))) - ekk(k) = ekd(k)*csbot(k) - end do - - do k = top_lev, pver - km1 = max0(k-1, top_lev) - ekkp(k) = zn(k)*ekk(k)*zs(k) - ekkm(k) = zn(k)*ekk(k-1)*zs(km1) - tinv = ekkp(k) + ekkm(k) - - ! rce-comment -- tinv is the sum of all first-order-loss-rates - ! for the layer. for most layers, the activation loss rate - ! (for interstitial particles) is accounted for by the loss by - ! turb-transfer to the layer above. - ! k=pver is special, and the loss rate for activation within - ! the layer must be added to tinv. if not, the time step - ! can be too big, and explmix can produce negative values. - ! the negative values are reset to zero, resulting in an - ! artificial source. - if (k == pver) tinv = tinv + taumix_internal_pver_inv - - if (tinv .gt. 1.e-6_r8) then - dtt = 1._r8/tinv - dtmin = min(dtmin, dtt) - end if - end do - - dtmix = 0.9_r8*dtmin - nsubmix = int(dtmicro/dtmix) + 1 - if (nsubmix > 100) then - nsubmix_bnd = 100 - else - nsubmix_bnd = nsubmix - end if - count_submix(nsubmix_bnd) = count_submix(nsubmix_bnd) + 1 - dtmix = dtmicro/nsubmix - - do k = top_lev, pver - kp1 = min(k+1, pver) - km1 = max(k-1, top_lev) - ! maximum overlap assumption - if (cldn(i,kp1) > 1.e-10_r8) then - overlapp(k) = min(cldn(i,k)/cldn(i,kp1), 1._r8) - else - overlapp(k) = 1._r8 - end if - if (cldn(i,km1) > 1.e-10_r8) then - overlapm(k) = min(cldn(i,k)/cldn(i,km1), 1._r8) - else - overlapm(k) = 1._r8 - end if - end do - - - ! rce-comment - ! the activation source(k) = mact(k,m)*raercol(kp1,lmass) - ! should not exceed the rate of transfer of unactivated particles - ! from kp1 to k which = ekkp(k)*raercol(kp1,lmass) - ! however it might if things are not "just right" in subr activate - ! the following is a safety measure to avoid negatives in explmix - do k = top_lev, pver-1 - do m = 1, nbin - nact(k,m) = min( nact(k,m), ekkp(k) ) - mact(k,m) = min( mact(k,m), ekkp(k) ) - end do - end do - - - ! old_cloud_nsubmix_loop - do n = 1, nsubmix - qncld(:) = qcld(:) - ! switch nsav, nnew so that nsav is the updated aerosol - ntemp = nsav - nsav = nnew - nnew = ntemp - srcn(:) = 0.0_r8 - - do m = 1, nbin - mm = aero_props%indexer(m,0) - - ! update droplet source - ! rce-comment- activation source in layer k involves particles from k+1 - ! srcn(:)=srcn(:)+nact(:,m)*(raercol(:,mm,nsav)) - srcn(top_lev:pver-1) = srcn(top_lev:pver-1) + nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - - ! rce-comment- new formulation for k=pver - ! srcn( pver )=srcn( pver )+nact( pver ,m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*nact(pver,m) & - + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) - srcn(pver) = srcn(pver) + max(0.0_r8,tmpa) - end do - call explmix( & - qcld, srcn, ekkp, ekkm, overlapp, & - overlapm, qncld, zero, zero, pver, & - top_lev, dtmix, .false.) - - ! rce-comment - ! the interstitial particle mixratio is different in clear/cloudy portions - ! of a layer, and generally higher in the clear portion. (we have/had - ! a method for diagnosing the the clear/cloudy mixratios.) the activation - ! source terms involve clear air (from below) moving into cloudy air (above). - ! in theory, the clear-portion mixratio should be used when calculating - ! source terms - do m = 1, nbin - mm = aero_props%indexer(m,0) - ! rce-comment - activation source in layer k involves particles from k+1 - ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) - source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - ! rce-comment - new formulation for k=pver - ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*nact(pver,m) & - + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) - source(pver) = max(0.0_r8, tmpa) - flxconv = 0._r8 - - call explmix( & - raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & - top_lev, dtmix, .false.) - - call explmix( & - raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & - top_lev, dtmix, .true., raercol_cw(:,mm,nsav)) - - do l = 1,aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - ! rce-comment - activation source in layer k involves particles from k+1 - ! source(:)= mact(:,m)*(raercol(:,mm,nsav)) - source(top_lev:pver-1) = mact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - ! rce-comment- new formulation for k=pver - ! source( pver )= mact( pver ,m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*mact(pver,m) & - + raercol_cw(pver,mm,nsav)*(mact(pver,m) - taumix_internal_pver_inv) - source(pver) = max(0.0_r8, tmpa) - flxconv = 0._r8 - - call explmix( & - raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & - top_lev, dtmix, .false.) - - call explmix( & - raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & - top_lev, dtmix, .true., raercol_cw(:,mm,nsav)) - - end do - end do - - end do ! old_cloud_nsubmix_loop - - ! evaporate particles again if no cloud (either ice or liquid) - - do k = top_lev, pver - if (cldn(i,k) == 0._r8) then - ! no ice or liquid cloud - qcld(k)=0._r8 - - ! convert activated aerosol to interstitial in decaying cloud - do mm = 1,nele_tot - raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) - raercol_cw(k,mm,nnew) = 0._r8 - end do - - end if - end do - - ! droplet number - - ndropcol(i) = 0._r8 - do k = top_lev, pver - ndropmix(i,k) = (qcld(k) - ncldwtr(i,k))*dtinv - nsource(i,k) - tendnd(i,k) = (max(qcld(k), 1.e-6_r8) - ncldwtr(i,k))*dtinv - ndropcol(i) = ndropcol(i) + ncldwtr(i,k)*pdel(i,k) - end do - ndropcol(i) = ndropcol(i)/gravit - - raertend = 0._r8 - qqcwtend = 0._r8 - - do m = 1, nbin - do l = 0, aero_props%nmasses(m) - - mm = aero_props%indexer(m,l) - - raertend(top_lev:pver) = (raercol(top_lev:pver,mm,nnew) - raer(mm)%fld(i,top_lev:pver))*dtinv - qqcwtend(top_lev:pver) = (raercol_cw(top_lev:pver,mm,nnew) - qqcw(mm)%fld(i,top_lev:pver))*dtinv - - coltend(i,mm) = sum( pdel(i,:)*raertend )/gravit - coltend_cw(i,mm) = sum( pdel(i,:)*qqcwtend )/gravit - - ! check for advected aerosol constituents - if (dotend(mm)) then ! advected aerosol parts - raertend_out(i,:,mm) = 0.0_r8 - raertend_out(i,top_lev:pver,mm) = raertend(top_lev:pver) ! set tendencies for interstitial aerosol - else - raer(mm)%fld(i,:) = 0.0_r8 - raer(mm)%fld(i,top_lev:pver) = raercol(top_lev:pver,mm,nnew) ! update non-advected interstitial aerosol (pbuf) - end if - - qqcw(mm)%fld(i,:) = 0.0_r8 - qqcw(mm)%fld(i,top_lev:pver) = raercol_cw(top_lev:pver,mm,nnew) ! update cloud-borne aerosol - - end do - end do - - end do ! overall_main_i_loop - ! end of main loop over i/longitude .................................... - - call ccncalc(aero_state, aero_props, ncol, pver, top_lev, temp, cs, ccn, errmsg, errflg) - if (errflg /= 0) return - - deallocate( & - nact, & - mact, & - raer, & - qqcw, & - raercol, & - raercol_cw, & - naermod, & - hygro, & - vaerosol, & - fn, & - fm, & - fluxn, & - fluxm ) - -end subroutine dropmixnuc - -!=============================================================================== - -subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & - qold, surfrate, flxconv, pver, top_lev, dt, is_unact, qactold ) - - ! explicit integration of droplet/aerosol mixing - ! with source due to activation/nucleation - - - integer, intent(in) :: pver ! number of levels - integer, intent(in) :: top_lev ! top level for cloud physics - real(r8), intent(out) :: q(pver) ! mixing ratio to be updated - real(r8), intent(in) :: qold(pver) ! mixing ratio from previous time step - real(r8), intent(in) :: src(pver) ! source due to activation/nucleation (/s) - real(r8), intent(in) :: ekkp(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! below layer k (k,k+1 interface) - real(r8), intent(in) :: ekkm(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! above layer k (k,k+1 interface) - real(r8), intent(in) :: overlapp(pver) ! cloud overlap below - real(r8), intent(in) :: overlapm(pver) ! cloud overlap above - real(r8), intent(in) :: surfrate ! surface exchange rate (/s) - real(r8), intent(in) :: flxconv ! convergence of flux from surface - real(r8), intent(in) :: dt ! time step (s) - logical, intent(in) :: is_unact ! true if this is an unactivated species - real(r8), intent(in),optional :: qactold(pver) - ! mixing ratio of ACTIVATED species from previous step - ! *** this should only be present - ! if the current species is unactivated number/sfc/mass - - integer k,kp1,km1 - - if ( is_unact ) then - ! the qactold*(1-overlap) terms are resuspension of activated material - do k=top_lev,pver - kp1=min(k+1,pver) - km1=max(k-1,top_lev) - q(k) = qold(k) + dt*( - src(k) + ekkp(k)*(qold(kp1) - qold(k) + & - qactold(kp1)*(1.0_r8-overlapp(k))) & - + ekkm(k)*(qold(km1) - qold(k) + & - qactold(km1)*(1.0_r8-overlapm(k))) ) - ! force to non-negative - ! if(q(k)<-1.e-30)then - ! write(iulog,*)'q=',q(k),' in explmix' - q(k)=max(q(k),0._r8) - ! endif - end do - - ! diffusion loss at base of lowest layer - q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt - ! force to non-negative - ! if(q(pver)<-1.e-30)then - ! write(iulog,*)'q=',q(pver),' in explmix' - q(pver)=max(q(pver),0._r8) - ! endif - else - do k=top_lev,pver - kp1=min(k+1,pver) - km1=max(k-1,top_lev) - q(k) = qold(k) + dt*(src(k) + ekkp(k)*(overlapp(k)*qold(kp1)-qold(k)) + & - ekkm(k)*(overlapm(k)*qold(km1)-qold(k)) ) - ! force to non-negative - ! if(q(k)<-1.e-30)then - ! write(iulog,*)'q=',q(k),' in explmix' - q(k)=max(q(k),0._r8) - ! endif - end do - ! diffusion loss at base of lowest layer - q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt - ! force to non-negative - ! if(q(pver)<-1.e-30)then - ! write(iulog,*)'q=',q(pver),' in explmix' - q(pver)=max(q(pver),0._r8) - - end if - -end subroutine explmix - -!=============================================================================== - -subroutine ccncalc(aero_state, aero_props, ncol, pver, top_lev, tair, cs, ccn, errmsg, errflg) - - ! calculates number concentration of aerosols activated as CCN at - ! supersaturation supersat. - ! assumes an internal mixture of a multiple externally-mixed aerosol modes - ! cgs units - - ! Ghan et al., Atmos. Res., 1993, 198-221. - - ! arguments - class(aerosol_state), intent(in) :: aero_state - class(aerosol_properties), intent(in) :: aero_props - - integer, intent(in) :: ncol ! number of columns - integer, intent(in) :: pver ! number of vertical layers - integer, intent(in) :: top_lev ! top level for cloud physics - real(r8), intent(in) :: tair(:,:) ! air temperature (K) - real(r8), intent(in) :: cs(:,:) ! air density (kg/m3) - real(r8), intent(out) :: ccn(:,:,:) ! (ncol,pver,psat) number conc of aerosols activated at supersat (#/m3) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local - - real(r8) naerosol(ncol,pver,nbin) ! interstit+activated aerosol number conc (/m3) - real(r8) vaerosol(ncol,pver,nbin) ! interstit+activated aerosol volume conc (m3/m3) - - real(r8) amcube(ncol) - real(r8), allocatable :: argfactor(:) - real(r8) surften_coef - real(r8) a(ncol) ! surface tension parameter - real(r8) hygro(ncol,pver,nbin) ! aerosol hygroscopicity - real(r8) sm(ncol) ! critical supersaturation at mode radius - real(r8) arg(ncol) - integer l,m,i,k, astat - real(r8) smcoef(ncol) - integer phase ! phase of aerosol - - integer :: errnum - character(len=shr_kind_cs) :: errstr - - ! mathematical constants - real(r8), parameter :: super(psat) = supersat(:psat)*0.01_r8 - real(r8), parameter :: smcoefcoef = 2._r8/sqrt(27._r8) - - !------------------------------------------------------------------------------- - - errmsg = '' - errflg = 0 - - allocate( argfactor(nbin), stat=astat ) - if (astat/=0) then - errmsg = 'ndrop::ccncalc : not able to allocate argfactor' - errflg = 1 - return - end if - - surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) - - do m=1,nbin - argfactor(m)=twothird/(sq2*aero_props%alogsig(m)) - end do - - phase=3 ! interstitial+cloudborne - - do m = 1, nbin - call aero_state%loadaer( aero_props, & - ncol, pver, & - m, cs, phase, naerosol(:,:,m), vaerosol(:,:,m), & - hygro(:,:,m), errnum, errstr) - if (errnum/=0) then - errmsg = 'ccncalc : '//trim(errstr) - errflg = 1 - return - end if - end do - - ccn = 0._r8 - do k=top_lev,pver - - do i=1,ncol - a(i)=surften_coef/tair(i,k) - smcoef(i)=smcoefcoef*a(i)*sqrt(a(i)) - end do - - do m=1,nbin - - where(naerosol(:ncol,k,m)>1.e-3_r8 .and. hygro(:ncol,k,m)>1.e-10_r8) - amcube(:ncol)=aero_props%amcube(m, vaerosol(:ncol,k,m), naerosol(:ncol,k,m) ) - sm(:ncol)=smcoef(:ncol)/sqrt(hygro(:ncol,k,m)*amcube(:ncol)) ! critical supersaturation - elsewhere - sm(:ncol)=1._r8 ! value shouldn't matter much since naerosol is small - endwhere - do l=1,psat - do i=1,ncol - arg(i)=argfactor(m)*log(sm(i)/super(l)) - ccn(i,k,l)=ccn(i,k,l)+naerosol(i,k,m)*0.5_r8*(1._r8-erf(arg(i))) - enddo - enddo - enddo - enddo - ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 - - deallocate( argfactor ) - -end subroutine ccncalc - -!=============================================================================== -end module ndrop From 22616dec8644fc1bf7076ef96204be3e6c3b201c Mon Sep 17 00:00:00 2001 From: Haipeng Lin Date: Mon, 10 Aug 2026 13:16:40 -0400 Subject: [PATCH 3/6] Cleanup --- src/chemistry/aerosol/mo_setsox_cam.F90 | 24 +-- .../aerosol/modal_aerosol_state_mod.F90 | 23 +-- src/chemistry/aerosol/wetdep_cam.F90 | 14 +- src/chemistry/modal_aero/aero_model.F90 | 169 +++++++++--------- .../modal_aero/modal_aero_coag_cam.F90 | 74 +++----- .../modal_aero/modal_aero_gasaerexch_cam.F90 | 14 +- .../modal_aero/modal_aero_newnuc_cam.F90 | 32 +--- .../modal_aero/modal_aero_rename_cam.F90 | 42 ++--- .../utils/modal_aero_calcsize_cam.F90 | 20 +-- .../utils/modal_aero_wateruptake_cam.F90 | 19 +- src/physics/cam/aerosol_optics_cam.F90 | 8 +- src/physics/cam/microp_aero.F90 | 11 +- 12 files changed, 163 insertions(+), 287 deletions(-) diff --git a/src/chemistry/aerosol/mo_setsox_cam.F90 b/src/chemistry/aerosol/mo_setsox_cam.F90 index 98e9f64443..4a4bb0ee6a 100644 --- a/src/chemistry/aerosol/mo_setsox_cam.F90 +++ b/src/chemistry/aerosol/mo_setsox_cam.F90 @@ -1,11 +1,5 @@ !----------------------------------------------------------------------- ! CAM wrapper for mo_setsox (portable aqueous sulfur chemistry). -! -! Resolves the species indices / invariant flags and Henry's Law table -! indices, hands them (with the host physical constants) to the portable -! setsox_init / sox_cldaero_init, and marshals CAM structures (physics -! state / pbuf CO2, shr_drydep dheff table) into plain arguments for the -! portable setsox_sub. !----------------------------------------------------------------------- module mo_setsox_cam @@ -23,9 +17,6 @@ module mo_setsox_cam logical :: has_sox = .true. contains - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- subroutine sox_inti(aero_props) !----------------------------------------------------------------------- ! ... initialize the hetero sox routine @@ -161,6 +152,7 @@ subroutine sox_inti(aero_props) return end if + ! call the portable init subroutines: call setsox_init( cloud_borne_in=cloud_borne, & id_so2_in=id_so2, inv_so2_in=inv_so2, & id_nh3_in=id_nh3, inv_nh3_in=inv_nh3, & @@ -173,11 +165,11 @@ subroutine sox_inti(aero_props) heff_id_nh3_in=heff_id_nh3, heff_id_co2_in=heff_id_co2, & heff_id_h2o2_in=heff_id_h2o2, heff_id_o3_in=heff_id_o3 ) - ! sulfur oxidation is performed internally to GEOS-Chem, so the aerosol - ! and gas updates are not applied here (avoids double counting) call sox_cldaero_init(aero_props, & id_msa_in=id_msa, id_h2so4_in=id_h2so4, id_so2_in=id_so2, & id_h2o2_in=id_h2o2, id_nh3_in=id_nh3, pi_in=pi, & + ! sulfur oxidation is performed internally to GEOS-Chem, so the aerosol + ! and gas updates are not applied here (avoids double counting) do_aqueous_sulfur_chemistry_aerosol_update_in=.not. cam_chempkg_is('geoschem_mam4'), & errmsg=errmsg, errflg=errflg) if (errflg /= 0) then @@ -212,12 +204,6 @@ subroutine setsox( aero_state, state, & aqso4_o3_3d & ) - !----------------------------------------------------------------------- - ! CAM-facing setsox: marshal CAM structures (pbuf CO2 via rad_cnst, - ! shr_drydep dheff table, host physical constants) and call the - ! portable setsox_sub. - !----------------------------------------------------------------------- - use physconst, only : avogad, boltz, r_universal, mwco2, mwdry, gravit use ppgrid, only : pver use shr_drydep_mod, only : dheff @@ -264,7 +250,9 @@ subroutine setsox( aero_state, state, & call rad_cnst_get_gas(0, 'CO2', state, pbuf, co2_mass_mixing_ratio) - call setsox_sub( aero_state = aero_state, & + ! call the portable subroutine: + call setsox_sub( + aero_state = aero_state, & ncol = ncol, & pver = pver, & dtime = dtime, & diff --git a/src/chemistry/aerosol/modal_aerosol_state_mod.F90 b/src/chemistry/aerosol/modal_aerosol_state_mod.F90 index 8474e90688..3311fb00fa 100644 --- a/src/chemistry/aerosol/modal_aerosol_state_mod.F90 +++ b/src/chemistry/aerosol/modal_aerosol_state_mod.F90 @@ -19,7 +19,7 @@ module modal_aerosol_state_mod type, extends(aerosol_state) :: modal_aerosol_state private ! Opaque host-binding handle used to retrieve aerosol fields from - ! host model data; built by host-side wiring (aerosol_instances_mod). + ! host model data; built by aerosol_instances_mod. ! This keeps model-specific data structures outside of the aerosol interface. type(aero_host_binding_t) :: host_ contains @@ -56,12 +56,9 @@ module modal_aerosol_state_mod procedure :: constructor end interface modal_aerosol_state - ! Interface of the diagnostic-list water uptake recompute. The science - ! (modal_aero_wateruptake_diag) lives with the portable modal aerosol - ! schemes, which are not part of every build, so it is wired in by host - ! code at initialization through a procedure pointer rather than - ! referenced directly; when nothing is registered, diagnostic-list - ! water uptake aborts as unavailable. + ! Abstract interface for computing diagnostic-list water uptake. + ! Use a procedure pointer since some model configurations do not compile + ! the portable modal aerosol science code. abstract interface subroutine water_uptake_diag_i(aero_props, aero_state, ncol, nlev, top_lev, & pi, rhoh2o, t, pmid, h2ommr, cldn, bin_idx, dgnumwet, qaerwat, errmsg, errflg) @@ -92,9 +89,7 @@ end subroutine water_uptake_diag_i contains !------------------------------------------------------------------------------ - ! register the diagnostic-list water uptake implementation (host wiring; - ! called at initialization from code that has access to the portable - ! modal aerosol schemes) + ! register the diagnostic-list water uptake implementation !------------------------------------------------------------------------------ subroutine modal_aerosol_state_register_water_uptake_diag(fn) procedure(water_uptake_diag_i) :: fn @@ -493,14 +488,6 @@ end subroutine hygroscopicity !------------------------------------------------------------------------------ ! returns aerosol wet diameter and aerosol water concentration for a given mode - ! - ! For the climate list (list_idx==0) these were pre-computed by the water - ! uptake calculation and are retrieved via the aerosol_mmr_host accessors - ! (DGNUMWET/QAERWAT pbuf fields in CAM; dgncur_awet/qaerwat_aer registry - ! fields written by the CCPPized wateruptake scheme in CAM-SIMA). - ! Diagnostic lists are recomputed from the atmospheric state passed in by - ! the caller, via the registered portable implementation (see the - ! water_uptake_diag_i interface above). !------------------------------------------------------------------------------ subroutine water_uptake(self, aero_props, bin_idx, ncol, nlev, top_lev, & t, pmid, h2ommr, cldn, dgnumwet, qaerwat) diff --git a/src/chemistry/aerosol/wetdep_cam.F90 b/src/chemistry/aerosol/wetdep_cam.F90 index 157d71dd81..1eccd74bee 100644 --- a/src/chemistry/aerosol/wetdep_cam.F90 +++ b/src/chemistry/aerosol/wetdep_cam.F90 @@ -2,10 +2,9 @@ module wetdep_cam !----------------------------------------------------------------------- ! -! CAM host interface for the portable wetdep module. Gathers the wetdepa -! inputs from the physics state/pbuf (wetdep_inputs_t / wetdep_init / -! wetdep_inputs_set) and retains wetdepg (gas-phase Henry's-law scavenging), -! which has no portable caller. +! CAM host interface for the portable wetdep module +! Calls portable wetdepa. +! Retains gas-phase Henry's law scavenging (wetdepg). ! !----------------------------------------------------------------------- @@ -17,7 +16,6 @@ module wetdep_cam use wetdep, only: clddiag implicit none -save private public :: wetdepg ! scavenging of gas phase constituents by henry's law @@ -60,12 +58,8 @@ module wetdep_cam integer :: nevapr_dpcu_idx = 0 integer :: ixcldice, ixcldliq -!============================================================================== contains -!============================================================================== -!============================================================================== -!============================================================================== subroutine wetdep_init() use physics_buffer, only: pbuf_get_index use constituents, only: cnst_get_ind @@ -89,7 +83,7 @@ subroutine wetdep_init() call cnst_get_ind('CLDICE', ixcldice) call cnst_get_ind('CLDLIQ', ixcldliq) -endsubroutine wetdep_init +end subroutine wetdep_init !============================================================================== ! gathers up the inputs needed for the wetdepa routines diff --git a/src/chemistry/modal_aero/aero_model.F90 b/src/chemistry/modal_aero/aero_model.F90 index 8c2199bd4d..8b072593f4 100644 --- a/src/chemistry/modal_aero/aero_model.F90 +++ b/src/chemistry/modal_aero/aero_model.F90 @@ -1120,22 +1120,25 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re real(r8) :: qsrflx(pcols,gas_pcnst,nsrflx) real(r8) :: qqcwsrflx(pcols,gas_pcnst,nsrflx) real(r8) :: qsrflx_gaexch_out(ncol,gas_pcnst) ! column-integrated gaexch source/sink from the scheme + ! Local arrays for refactored newnuc call real(r8) :: dqdt_nnuc(ncol,pver,gas_pcnst) logical :: dotend_nnuc(gas_pcnst) real(r8) :: qsrflx_nnuc(pcols,gas_pcnst,1) ! column-integrated nucleation source/sink - ! Local arrays for refactored coag call (dqdt_coag is diagnostic-only; - ! the scheme updates vmr in place) + + ! Local arrays for refactored coag call + ! dqdt_coag is diagnostic-only, vmr is updated in-place real(r8) :: dqdt_coag(ncol,pver,gas_pcnst) logical :: dotend_coag(gas_pcnst) real(r8) :: qsrflx_coag(pcols) ! column-integrated coagulation source/sink character(len=fieldname_len+3) :: fieldname integer :: jac, jsrf, jsoa, lb logical :: use_sulfeq + character(len=512) :: errmsg_local integer :: errflg_local ! Zero-initialized dummy array for intent(in) placeholders (e.g. sulfeq - ! when use_sulfeq=.false.). Sized to the common (ncol,pver,ntot_amode) shape. + ! when use_sulfeq=.false.) real(r8) :: dummy_3d(ncol,pver,ntot_amode) ! SOA condensation/evaporation diagnostics @@ -1301,7 +1304,7 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re call modal_aero_gasaerexch_run( & ncol = ncol, & pver = pver, & - deltat = delt, & + deltat = delt, & top_lev = top_lev, & loffset = loffset, & t = tfld(:ncol,:), & @@ -1312,7 +1315,7 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re dgncur_a = dgnum(:ncol,:,:), & dgncur_awet = dgnumwet(:ncol,:,:), & use_sulfeq = .false., & - sulfeq = dummy_3d, & + sulfeq = dummy_3d, & num_q = gas_pcnst, & q = vmr(:ncol,:,:), & dqdt = dqdt_gaex, & @@ -1326,91 +1329,89 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re call endrun('aero_model_gasaerexch: ' // trim(errmsg_local)) end if - ! Snapshot conden-only tendencies before modal_aero_rename_run adds its - ! mode-transfer tendencies into dqdt_gaex in place. The _sfgaex1 and SOA - ! cond/evap diagnostics below use these pre-rename values, matching the - ! original where qsrflx/qcon were accumulated before the rename call. + ! Save conden-only tendencies before modal_aero_rename_run + ! adds mode-transfer tendencies into dqdt_gaex + ! since they are used by _sfgaex1 and SOA cond/evap diagnostics dqdt_gaex_conden(:,:,:) = dqdt_gaex(:,:,:) if (ndx_h2so4 > 0) then - ! Snapshot h2so4 vmr before applying tendencies. del_h2so4_aeruptk is - ! recovered below as (vmr_after - vmr_before) after the apply loop, matching - ! the original which bracketed the in-place gasaerexch_sub update. + ! Save h2so4 vmr before applying tendencies. + ! del_h2so4_aeruptk is computed by (vmr_after - vmr_before) after + ! the apply loop for bfb. + ! ! A clearer formulation is ! del_h2so4_aeruptk(1:ncol,:) = dqdt_gaex(1:ncol,:,ndx_h2so4) * delt - ! but is not bit-for-bit and the difference propagates down to newnuc. + ! but is not bfb and the difference propagates down to newnuc. del_h2so4_aeruptk(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) else del_h2so4_aeruptk(:,:) = 0.0_r8 end if - ! Call rename as a separate step (was embedded in gasaerexch_sub). - ! Marshal MAM mode metadata + the resolved renaming-pair tables (owned by - ! modal_aero_rename_cam) into the portable modal_aero_rename_run directly. + ! Call portable mode merging (renaming): dqqcwdt_gaex(:,:,:) = 0.0_r8 dotendrn(:) = .false. dotendqqcwrn(:) = .false. dorename_atik(1:ncol,:) = .true. is_dorename_atik = .true. - ! Zero the (pcols-padded) column-tendency outputs over the full domain; the - ! scheme is called on :ncol and defines only that subset. + + ! zero to pcols: qsrflx(:,:,:) = 0.0_r8 qqcwsrflx(:,:,:) = 0.0_r8 - call modal_aero_rename_run( & - ncol = ncol, & - loffset = loffset, & - deltat = delt, & - pdel = pdel(:ncol,:), & - troplev = troplev(:ncol), & - dotendrn = dotendrn, & - q = vmr(:ncol,:,:), & - dqdt = dqdt_gaex(:ncol,:,:), & - dqdt_other = dvmrdt(:ncol,:,:), & - dotendqqcwrn = dotendqqcwrn, & - qqcw = vmrcw(:ncol,:,:), & - dqqcwdt = dqqcwdt_gaex(:ncol,:,:), & - dqqcwdt_other = dvmrcwdt(:ncol,:,:), & - is_dorename_atik = is_dorename_atik, & - dorename_atik = dorename_atik(:ncol,:), & - jsrflx_rename = jsrflx_rename, & - nsrflx = nsrflx, & - qsrflx = qsrflx(:ncol,:,:), & - qqcwsrflx = qqcwsrflx(:ncol,:,:), & - dqdt_rnpos = dqdt_rnpos_unused, & - ntot_amode = ntot_amode, & - npair_renamexf = npair_renamexf, & - modefrm_renamexf = modefrm_renamexf, & - modetoo_renamexf = modetoo_renamexf, & - nspecfrm_renamexf = nspecfrm_renamexf, & - lspecfrma_renamexf = lspecfrma_renamexf, & - lspecfrmc_renamexf = lspecfrmc_renamexf, & - lspectooa_renamexf = lspectooa_renamexf, & - lspectooc_renamexf = lspectooc_renamexf, & - alnsg_amode = alnsg_amode, & - voltonumblo_amode = voltonumblo_amode, & - voltonumbhi_amode = voltonumbhi_amode, & - dgnum_amode = dgnum_amode, & - nspec_amode = nspec_amode, & - specmw_amode = specmw_amode, & - specdens_amode = specdens_amode, & - lmassptr_amode = lmassptr_amode, & - lmassptrcw_amode = lmassptrcw_amode, & - numptr_amode = numptr_amode, & - numptrcw_amode = numptrcw_amode, & - pi = pi, & - modeptr_accum = modeptr_accum, & - modeptr_coarse = modeptr_coarse, & - modeptr_stracoar = modeptr_stracoar, & - igrow_shrink_renamexf = igrow_shrink_renamexf, & - ixferable_all_renamexf = ixferable_all_renamexf, & - ixferable_a_renamexf = ixferable_a_renamexf, & - ixferable_c_renamexf = ixferable_c_renamexf, & - strat_only_renamexf = strat_only_renamexf, & - modal_accum_coarse_exch = modal_accum_coarse_exch, & - pver = pver, & - gravit = gravit, & - errmsg = errmsg_local, & - errflg = errflg_local ) + call modal_aero_rename_run( & + ncol = ncol, & + loffset = loffset, & + deltat = delt, & + pdel = pdel(:ncol,:), & + troplev = troplev(:ncol), & + dotendrn = dotendrn, & + q = vmr(:ncol,:,:), & + dqdt = dqdt_gaex(:ncol,:,:), & + dqdt_other = dvmrdt(:ncol,:,:), & + dotendqqcwrn = dotendqqcwrn, & + qqcw = vmrcw(:ncol,:,:), & + dqqcwdt = dqqcwdt_gaex(:ncol,:,:), & + dqqcwdt_other = dvmrcwdt(:ncol,:,:), & + is_dorename_atik = is_dorename_atik, & + dorename_atik = dorename_atik(:ncol,:), & + jsrflx_rename = jsrflx_rename, & + nsrflx = nsrflx, & + qsrflx = qsrflx(:ncol,:,:), & + qqcwsrflx = qqcwsrflx(:ncol,:,:), & + dqdt_rnpos = dqdt_rnpos_unused, & + ntot_amode = ntot_amode, & + npair_renamexf = npair_renamexf, & + modefrm_renamexf = modefrm_renamexf, & + modetoo_renamexf = modetoo_renamexf, & + nspecfrm_renamexf = nspecfrm_renamexf, & + lspecfrma_renamexf = lspecfrma_renamexf, & + lspecfrmc_renamexf = lspecfrmc_renamexf, & + lspectooa_renamexf = lspectooa_renamexf, & + lspectooc_renamexf = lspectooc_renamexf, & + alnsg_amode = alnsg_amode, & + voltonumblo_amode = voltonumblo_amode, & + voltonumbhi_amode = voltonumbhi_amode, & + dgnum_amode = dgnum_amode, & + nspec_amode = nspec_amode, & + specmw_amode = specmw_amode, & + specdens_amode = specdens_amode, & + lmassptr_amode = lmassptr_amode, & + lmassptrcw_amode = lmassptrcw_amode, & + numptr_amode = numptr_amode, & + numptrcw_amode = numptrcw_amode, & + pi = pi, & + modeptr_accum = modeptr_accum, & + modeptr_coarse = modeptr_coarse, & + modeptr_stracoar = modeptr_stracoar, & + igrow_shrink_renamexf = igrow_shrink_renamexf, & + ixferable_all_renamexf = ixferable_all_renamexf, & + ixferable_a_renamexf = ixferable_a_renamexf, & + ixferable_c_renamexf = ixferable_c_renamexf, & + strat_only_renamexf = strat_only_renamexf, & + modal_accum_coarse_exch = modal_accum_coarse_exch, & + pver = pver, & + gravit = gravit, & + errmsg = errmsg_local, & + errflg = errflg_local) if (errflg_local /= 0) then call endrun('aero_model_gasaerexch (rename): ' // trim(errmsg_local)) @@ -1434,16 +1435,16 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re end if end do - ! Recover del_h2so4_aeruptk = vmr_after - vmr_before (see snapshot above). + ! Get del_h2so4_aeruptk = vmr_after - vmr_before: if (ndx_h2so4 > 0) then del_h2so4_aeruptk(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) - del_h2so4_aeruptk(1:ncol,:) end if ! Diagnostics: column tendencies for gas-aerosol exchange and renaming. - ! The gaexch column source/sink (qsrflx, jsrflx_gaexch) is accumulated inside the - ! scheme: the per-mode and primary-carbon-aging contributions must be summed term - ! by term (and with pdel/gravit in that operand order) to stay bit-for-bit with the - ! original; the host only sees the combined tendency and cannot reproduce it. + ! The gaexch column source/sink (qsrflx, jsrflx_gaexch) + ! is accumulated inside the scheme: + ! the per-mode and primary-carbon-aging contributions + ! are sum'd term by term for bfb. qsrflx(:ncol,:,jsrflx_gaexch) = qsrflx_gaexch_out(:ncol,:) ! Output history fields @@ -1486,8 +1487,8 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re ! SOA condensation/evaporation diagnostics ! Reconstruct from the pre-rename conden tendencies (dqdt_gaex_conden). ! NOTE: for the accumulation mode this is not exactly b4b with the original, - ! which used the per-mode conden tendency dqdt_soa(n,jsoa); the species-indexed - ! tendency here also absorbs primary-carbon-aged SOA. History-diagnostic only. + ! which used the per-mode conden tendency dqdt_soa(n,jsoa); + ! the species-indexed tendency here also absorbs primary-carbon-aged SOA qconff(:,:) = 0.0_r8 qevapff(:,:) = 0.0_r8 qconbb(:,:) = 0.0_r8 @@ -1560,8 +1561,6 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re call t_startf('modal_nucl') ! do aerosol nucleation (new particle formation) - ! Zero the (pcols-padded) column-tendency output over the full domain; the - ! scheme is called on :ncol and defines only that subset. qsrflx_nnuc(:,:,:) = 0.0_r8 call modal_aero_newnuc_run( & ncol = ncol, & @@ -1618,9 +1617,9 @@ subroutine aero_model_gasaerexch( state, loffset, ncol, lchnk, troplev, delt, re call t_startf('modal_coag') ! do aerosol coagulation - ! vmr is updated in place by the scheme; dqdt_coag is returned for the - ! history diagnostics only (dqdt*delt is not bit-identical to the stored - ! change, so it must not be re-applied) + ! vmr is updated in place by the scheme. + ! dqdt_coag is returned for the history diagnostics only + ! (dqdt*delt is not bit-identical to the stored change so it cannot be applied directly) call modal_aero_coag_run( & ncol = ncol, & pver = pver, & diff --git a/src/chemistry/modal_aero/modal_aero_coag_cam.F90 b/src/chemistry/modal_aero/modal_aero_coag_cam.F90 index ef78f2e702..77ea90f839 100644 --- a/src/chemistry/modal_aero/modal_aero_coag_cam.F90 +++ b/src/chemistry/modal_aero/modal_aero_coag_cam.F90 @@ -1,20 +1,15 @@ ! CAM wrapper for modal_aero_coag. -! Owns the pair_option_acoag build-time selection, resolves the -! coagulation-pair tables from CAM constituent metadata (with the pcage -! aging tables from modal_aero_gasaerexch), hands them (with the mode -! metadata and host physical constants) to the portable -! modal_aero_coag_init, and registers history fields. +! Select pair_option_acoag at build time +! Resolve the coagulation-pair tables from CAM constituents metadata +! with the pcage aging tables from modal_aero_gasaerexch, +! registers history fields, and calls portable subroutines !---------------------------------------------------------------------- - module modal_aero_coag_cam - -! !USES: +module modal_aero_coag_cam use shr_kind_mod, only: r8 => shr_kind_r8 implicit none private - save -! !PUBLIC MEMBER FUNCTIONS: public :: modal_aero_coag_cam_init #if ( defined MODAL_AERO_7MODE || defined MODAL_AERO_4MODE || defined MODAL_AERO_5MODE) @@ -31,9 +26,6 @@ module modal_aero_coag_cam !---------------------------------------------------------------------- contains - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- subroutine modal_aero_coag_cam_init ! ! computes pointers for species transfer during coagulation @@ -50,19 +42,17 @@ subroutine modal_aero_coag_cam_init use constituents, only: pcnst, cnst_name use physconst, only: r_universal, pstd, tmelt, boltz use spmd_utils, only: masterproc - use phys_control, only: phys_getopts - - implicit none + use phys_control, only: phys_getopts + use cam_logfile, only: iulog ! local variables integer :: ipair, iq, iqfrm, iqfrm_aa, iqtoo, iqtoo_aa - integer :: jsoa - integer :: l, l1, l2, lsfrm, lstoo, lunout + integer :: jsoa + integer :: l, l1, l2, lsfrm, lstoo integer :: m, mait, mpca, mfrm, mtoo, mtef integer :: nchfrm, nchfrmskip, nchtoo, nchtooskip, nspec -! resolved coagulation-pair tables (host constituent-index space), -! handed to the portable modal_aero_coag_init at the end +! resolved coagulation-pair tables (host constituent-index space) integer :: maxspec_acoag integer :: npair_acoag integer :: modefrm_acoag(maxpair_acoag) @@ -80,31 +70,28 @@ subroutine modal_aero_coag_cam_init character(8) :: unit logical :: dotend(pcnst) - logical :: history_aerosol ! Output the MAM aerosol tendencies + logical :: history_aerosol ! Output the MAM aerosol tendencies character(len=200) :: msg character(len=512) :: errmsg integer :: errflg - !----------------------------------------------------------------------- - call phys_getopts( history_aerosol_out = history_aerosol ) - - lunout = 6 + call phys_getopts( history_aerosol_out = history_aerosol ) - maxspec_acoag = nspec_max - allocate( lspecfrm_acoag(maxspec_acoag,maxpair_acoag) ) - allocate( lspectoo_acoag(maxspec_acoag,maxpair_acoag) ) - allocate( fac_m2v_aitage(nspec_max), fac_m2v_pcarbon(nspec_max) ) + maxspec_acoag = nspec_max + allocate( lspecfrm_acoag(maxspec_acoag,maxpair_acoag) ) + allocate( lspectoo_acoag(maxspec_acoag,maxpair_acoag) ) + allocate( fac_m2v_aitage(nspec_max), fac_m2v_pcarbon(nspec_max) ) ! default-initialize the tables so the unused slots are well-defined when ! the whole arrays are handed to the portable modal_aero_coag_init - modefrm_acoag(:) = 0 - modetoo_acoag(:) = 0 - modetooeff_acoag(:) = 0 - nspecfrm_acoag(:) = 0 - lspecfrm_acoag(:,:) = 0 - lspectoo_acoag(:,:) = 0 + modefrm_acoag(:) = 0 + modetoo_acoag(:) = 0 + modetooeff_acoag(:) = 0 + nspecfrm_acoag(:) = 0 + lspecfrm_acoag(:,:) = 0 + lspectoo_acoag(:,:) = 0 ! ! define "from mode" and "to mode" for each coagulation pairing @@ -221,27 +208,27 @@ subroutine modal_aero_coag_cam_init ! if ( masterproc ) then - write(lunout,9310) + write(iulog,9310) do ipair = 1, npair_acoag mfrm = modefrm_acoag(ipair) mtoo = modetoo_acoag(ipair) mtef = modetooeff_acoag(ipair) - write(lunout,9320) ipair, mfrm, mtoo, mtef + write(iulog,9320) ipair, mfrm, mtoo, mtef do iq = 1, nspecfrm_acoag(ipair) lsfrm = lspecfrm_acoag(iq,ipair) lstoo = lspectoo_acoag(iq,ipair) if (lstoo .gt. 0) then - write(lunout,9330) lsfrm, cnst_name(lsfrm), & + write(iulog,9330) lsfrm, cnst_name(lsfrm), & lstoo, cnst_name(lstoo) else - write(lunout,9340) lsfrm, cnst_name(lsfrm) + write(iulog,9340) lsfrm, cnst_name(lsfrm) end if end do end do ! ipair = ... - write(lunout,*) + write(iulog,*) end if ! ( masterproc ) @@ -317,8 +304,7 @@ subroutine modal_aero_coag_cam_init ip_aitpca = -999888777 end if -! hand the resolved tables, mode metadata, and host physical constants -! to the portable scheme + ! call the portable subroutine: call modal_aero_coag_init( & pair_option_acoag_in = pair_option_acoag, & npair_acoag_in = npair_acoag, & @@ -409,8 +395,6 @@ subroutine modal_aero_coag_cam_init 'modal_aero_coag_init addfld', fieldname, unit end do ! l = ... - - return end subroutine modal_aero_coag_cam_init - end module modal_aero_coag_cam +end module modal_aero_coag_cam diff --git a/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 b/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 index 3ecc2b4383..8178f5f83b 100644 --- a/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 +++ b/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 @@ -31,6 +31,7 @@ subroutine modal_aero_gasaerexch_cam_init() use cam_abortutils, only: endrun use spmd_utils, only: masterproc use phys_control, only: phys_getopts, cam_chempkg_is + use cam_logfile, only: iulog ! indices are in pcnst (q) space ! run phase receives loffset for gas_pcnst (vmr) space @@ -38,7 +39,7 @@ subroutine modal_aero_gasaerexch_cam_init() ! local integer :: ipair, iq, iqfrm, iqtoo integer :: jac, jsoa, j - integer :: l, lsfrm, lstoo, lunout + integer :: l, lsfrm, lstoo integer :: mfrm, mtoo integer :: n, nspec integer :: nchfrm, nchfrmskip, nchtoo, nchtooskip @@ -75,7 +76,6 @@ subroutine modal_aero_gasaerexch_cam_init() integer :: errflg call phys_getopts(history_aerosol_out=history_aerosol) - lunout = 6 !----------------------------------------------------------------------- ! Part A: Resolve arguments and call portable _init @@ -225,21 +225,21 @@ subroutine modal_aero_gasaerexch_cam_init() ! output results if (masterproc) then - write (lunout, 9310) - write (lunout, 9320) 1, mfrm, mtoo + write (iulog, 9310) + write (iulog, 9320) 1, mfrm, mtoo do iq = 1, nspecfrm_pcage_resolved lsfrm = lspecfrm_pcage_resolved(iq) lstoo = lspectoo_pcage_resolved(iq) if (lstoo > 0) then - write (lunout, 9330) lsfrm, cnst_name(lsfrm), & + write (iulog, 9330) lsfrm, cnst_name(lsfrm), & lstoo, cnst_name(lstoo) else - write (lunout, 9340) lsfrm, cnst_name(lsfrm) + write (iulog, 9340) lsfrm, cnst_name(lsfrm) end if end do - write (lunout, *) + write (iulog, *) end if ! ( masterproc ) 9310 format(/'subr. modal_aero_gasaerexch_cam_init - primary carbon aging pointers') diff --git a/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 b/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 index ba8ea08964..d324e92d23 100644 --- a/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 +++ b/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 @@ -1,26 +1,14 @@ -! CAM wrapper for modal_aero_newnuc. -! Resolves CAM-specific species indices and aitken-mode so4/nh4 properties, -! hands them (with the host physical constants) to the portable -! modal_aero_newnuc_init, and registers history fields. -!---------------------------------------------------------------------- +! CAM wrapper for modal_aero_newnuc module modal_aero_newnuc_cam - -! !USES: use shr_kind_mod, only: r8 => shr_kind_r8 implicit none private -! !PUBLIC MEMBER FUNCTIONS: public :: modal_aero_newnuc_cam_init - -!---------------------------------------------------------------------- contains -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- subroutine modal_aero_newnuc_cam_init - !----------------------------------------------------------------------- ! ! Purpose: @@ -46,13 +34,6 @@ subroutine modal_aero_newnuc_cam_init use phys_control, only: phys_getopts -implicit none - -!----------------------------------------------------------------------- -! arguments - -!----------------------------------------------------------------------- -! local integer :: l_h2so4, l_nh3 integer :: lnumait, lnh4ait, lso4ait integer :: l, l1, l2 @@ -74,7 +55,7 @@ subroutine modal_aero_newnuc_cam_init !----------------------------------------------------------------------- - call phys_getopts( history_aerosol_out = history_aerosol ) + call phys_getopts( history_aerosol_out = history_aerosol ) ! set these indices @@ -136,8 +117,7 @@ subroutine modal_aero_newnuc_cam_init mw_nh4a_host = mw_so4a_host end if -! hand the resolved indices, aitken-mode properties, and host physical -! constants to the portable scheme + ! call portable science subroutine: call modal_aero_newnuc_init( & l_h2so4_in = l_h2so4, & l_nh3_in = l_nh3, & @@ -193,8 +173,6 @@ subroutine modal_aero_newnuc_cam_init 'modal_aero_newnuc_init addfld', fieldname, unit end do ! l = ... +end subroutine modal_aero_newnuc_cam_init +end module modal_aero_newnuc_cam - return - end subroutine modal_aero_newnuc_cam_init - - end module modal_aero_newnuc_cam diff --git a/src/chemistry/modal_aero/modal_aero_rename_cam.F90 b/src/chemistry/modal_aero/modal_aero_rename_cam.F90 index aa79e7b704..8ded4cc79f 100644 --- a/src/chemistry/modal_aero/modal_aero_rename_cam.F90 +++ b/src/chemistry/modal_aero/modal_aero_rename_cam.F90 @@ -1,11 +1,6 @@ -! CAM wrapper for modal_aero_rename. -! Owns the resolved renaming-pair tables (consumed by other CAM aerosol -! wrappers), performs the cnst_name-based pair resolution, and hands the -! tables + mode metadata to the portable modal_aero_rename_init. -!---------------------------------------------------------------------- - module modal_aero_rename_cam +! CAM wrapper for modal_aero_rename +module modal_aero_rename_cam -! !USES: use shr_kind_mod, only: r8 => shr_kind_r8 use cam_abortutils, only: endrun use cam_logfile, only: iulog @@ -23,12 +18,10 @@ module modal_aero_rename_cam implicit none private - save -! !PUBLIC MEMBER FUNCTIONS: public :: modal_aero_rename_cam_init -! !PUBLIC DATA MEMBERS: +! PUBLIC DATA MEMBERS: ! Resolved renaming-pair tables (host constituent-index space). These are ! consumed by modal_aero_calcsize_cam and modal_aero_gasaerexch_cam. integer, public :: npair_renamexf = -123456789 @@ -49,8 +42,9 @@ module modal_aero_rename_cam ! 5001 = stracoar --> accum integer :: ipair_select_renamexf(maxpair_renamexf) -! Renaming-pair flags resolved here and consumed by the portable science: handed -! to modal_aero_rename_init, and passed by aero_model to modal_aero_rename_run. +! Renaming-pair flags resolved here and consumed by the portable science: +! passed to modal_aero_rename_init, +! and passed by aero_model to modal_aero_rename_run. integer, protected, public :: igrow_shrink_renamexf(maxpair_renamexf) integer, protected, public :: ixferable_all_renamexf(maxpair_renamexf) integer :: ixferable_all_needed_renamexf(maxpair_renamexf) @@ -65,11 +59,6 @@ module modal_aero_rename_cam !---------------------------------------------------------------------- contains - - !------------------------------------------------------------------ - ! Resolve the renaming-pair tables from CAM constituent metadata, then hand - ! them (with the mode metadata) to the portable modal_aero_rename_init. - !------------------------------------------------------------------ subroutine modal_aero_rename_cam_init(modal_accum_coarse_exch_in) use modal_aero_rename, only: modal_aero_rename_init @@ -98,9 +87,8 @@ subroutine modal_aero_rename_cam_init(modal_accum_coarse_exch_in) allocate( ixferable_a_renamexf(maxspec_renamexf,maxpair_renamexf) ) allocate( ixferable_c_renamexf(maxspec_renamexf,maxpair_renamexf) ) - ! Default-initialize the accum-coarse-exchange flags: the no_acc_crs - ! resolution path leaves them unset, and they are handed (unused) to the - ! portable code on that path. + ! Default-initialize the accum-coarse-exchange flags: + ! unset in the no_acc_crs resolution path igrow_shrink_renamexf(:) = 0 ixferable_all_renamexf(:) = 0 ixferable_a_renamexf(:,:) = 0 @@ -117,9 +105,7 @@ subroutine modal_aero_rename_cam_init(modal_accum_coarse_exch_in) call modal_aero_rename_no_acc_crs_init() endif - ! Precompute rename's own accum-coarse-exchange physics coefficients. Only - ! the metadata the precompute + one-time log needs is handed over; the shared - ! tables/metadata are passed per-call to modal_aero_rename_run instead. + ! Precompute rename's own accum-coarse-exchange physics coefficients: call modal_aero_rename_init( & modal_accum_coarse_exch = modal_accum_coarse_exch, & ntot_amode = ntot_amode, & @@ -169,8 +155,6 @@ subroutine modal_aero_rename_no_acc_crs_init ! water_a ! - implicit none - ! local variables integer :: ipair, iq, iqfrm, iqtoo integer :: lsfrma, lsfrmc, lstooa, lstooc, lunout @@ -216,7 +200,7 @@ subroutine modal_aero_rename_no_acc_crs_init nchtooskip = 3 end if nspec = 0 -aa_iqfrm: do iqfrm = -1, nspec_amode(mfrm) + aa_iqfrm: do iqfrm = -1, nspec_amode(mfrm) if (iqfrm == -1) then lsfrma = numptr_amode(mfrm) lstooa = numptr_amode(mtoo) @@ -350,11 +334,8 @@ subroutine modal_aero_rename_no_acc_crs_init 9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' ) 9350 format( 5x, 'no corresponding activated species' ) - return end subroutine modal_aero_rename_no_acc_crs_init - - subroutine modal_aero_rename_acc_crs_init ! ! computes pointers for species transfer during aerosol renaming @@ -363,8 +344,6 @@ subroutine modal_aero_rename_acc_crs_init ! water_a ! - implicit none - ! local variables integer :: i, ipair, iq, iqfrm, iqtooa, iqtooc, itmpa integer :: l, lsfrma, lsfrmc, lstooa, lstooc, lunout @@ -451,7 +430,6 @@ subroutine modal_aero_rename_acc_crs_init return end if - ! ! define species involved in each tail-xfer pairing ! (include aerosol water) diff --git a/src/chemistry/utils/modal_aero_calcsize_cam.F90 b/src/chemistry/utils/modal_aero_calcsize_cam.F90 index d0cc864fd5..c5fde99dd0 100644 --- a/src/chemistry/utils/modal_aero_calcsize_cam.F90 +++ b/src/chemistry/utils/modal_aero_calcsize_cam.F90 @@ -1,9 +1,5 @@ module modal_aero_calcsize_cam - -! CAM wrapper for modal_aero_calcsize. -! Handles pbuf registration, initialization, history output, -! state/ptend/qqcw marshaling, and calls the portable science -! routine modal_aero_calcsize_run. +! CAM wrapper for modal_aero_calcsize. use shr_kind_mod, only: r8 => shr_kind_r8 use spmd_utils, only: masterproc @@ -255,13 +251,6 @@ end subroutine modal_aero_calcsize_init subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_state, & do_adjust_in, do_aitacc_transfer_in) - - !----------------------------------------------------------------------- - ! CAM wrapper for modal_aero_calcsize_run. - ! Marshals state/ptend/pbuf/qqcw into explicit arrays, calls the - ! portable science routine, then applies tendencies and history output. - !----------------------------------------------------------------------- - ! arguments type(physics_state), target, intent(in) :: state type(physics_ptend), target, intent(inout) :: ptend @@ -513,10 +502,6 @@ subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_ end subroutine modal_aero_calcsize_sub - -!---------------------------------------------------------------------- - - subroutine modal_aero_calcsize_diag(state, pbuf, aero_props, aero_state) !----------------------------------------------------------------------- @@ -667,7 +652,6 @@ subroutine modal_aero_calcdry(state, pbuf, aero_props, aero_state) call pbuf_get_field(pbuf, so4dryvol_idx, so4dryvol) call pbuf_get_field(pbuf, naer_idx, naer) - ! Zero output fields (allocated to pcols, _run writes 1:ncol) hygro(:,:,:) = 0._r8 dryvol(:,:,:) = 0._r8 dryrad(:,:,:) = 0._r8 @@ -675,6 +659,7 @@ subroutine modal_aero_calcdry(state, pbuf, aero_props, aero_state) so4dryvol(:,:,:) = 0._r8 naer(:,:,:) = 0._r8 + ! call portable subroutine: call modal_aero_calcdry_run( & aero_props = aero_props, & aero_state = aero_state, & @@ -697,6 +682,5 @@ subroutine modal_aero_calcdry(state, pbuf, aero_props, aero_state) end if end subroutine modal_aero_calcdry -!---------------------------------------------------------------------- end module modal_aero_calcsize_cam diff --git a/src/chemistry/utils/modal_aero_wateruptake_cam.F90 b/src/chemistry/utils/modal_aero_wateruptake_cam.F90 index 90bab93e79..fd4abd254d 100644 --- a/src/chemistry/utils/modal_aero_wateruptake_cam.F90 +++ b/src/chemistry/utils/modal_aero_wateruptake_cam.F90 @@ -1,15 +1,11 @@ module modal_aero_wateruptake_cam - ! CAM wrapper for modal_aero_wateruptake. -! Handles pbuf registration, initialization, history output, -! state/pbuf/aero_props marshaling, and calls the portable -! science routines. use shr_kind_mod, only: r8 => shr_kind_r8 use physconst, only: pi, rhoh2o, rair use ppgrid, only: pcols, pver use physics_types, only: physics_state -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field use aerosol_properties_mod, only: aerosol_properties use aerosol_state_mod, only: aerosol_state @@ -46,10 +42,7 @@ module modal_aero_wateruptake_cam integer :: so4dryvol_idx = 0 integer :: naer_idx = 0 - -!=============================================================================== contains -!=============================================================================== subroutine modal_aero_wateruptake_reg() @@ -166,9 +159,9 @@ subroutine modal_aero_wateruptake_cam_init(pbuf2d) end if ! Register the diagnostic-list water uptake recompute with the aerosol - ! interface (called by modal_aerosol_state%water_uptake for diagnostic - ! radiation lists; wired at init because the portable modal aerosol - ! schemes are not part of every build). + ! interface + ! + ! Pass a procedure pointer in since MAM is not always built in every config. call modal_aerosol_state_register_water_uptake_diag(modal_aero_wateruptake_diag) end subroutine modal_aero_wateruptake_cam_init @@ -199,7 +192,6 @@ subroutine modal_aero_wateruptake_dr(state, pbuf, aero_props, aero_state) integer :: ncol ! number of columns integer :: i, k, m - integer :: itim_old integer :: nmodes integer :: tropLev(pcols) @@ -298,8 +290,7 @@ subroutine modal_aero_wateruptake_dr(state, pbuf, aero_props, aero_state) t => state%t pmid => state%pmid - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1/), kount=(/pcols,pver/) ) ! Zero output arrays (allocated at pcols, _sub only writes 1:ncol) wetrad(:,:,:) = 0._r8 diff --git a/src/physics/cam/aerosol_optics_cam.F90 b/src/physics/cam/aerosol_optics_cam.F90 index ca244f16a6..012170a17b 100644 --- a/src/physics/cam/aerosol_optics_cam.F90 +++ b/src/physics/cam/aerosol_optics_cam.F90 @@ -481,7 +481,6 @@ subroutine aerosol_optics_cam_sw(list_idx, state, pbuf, nnite, idxnite, tauxar, integer :: icol integer :: lchnk, ncol integer :: num_aero_models - integer :: itim_old real(r8), pointer :: cldn(:,:) ! layer cloud fraction (0-1) @@ -652,8 +651,7 @@ subroutine aerosol_optics_cam_sw(list_idx, state, pbuf, nnite, idxnite, tauxar, relh(:ncol,:) = max(1.e-20_r8,relh(:ncol,:)) ! layer cloud fraction, for the water uptake recompute of diagnostic lists - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, pbuf_get_index('CLD'), cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, pbuf_get_index('CLD'), cldn, start=(/1,1/), kount=(/pcols,pver/)) bam_cnt = 0 @@ -1140,7 +1138,6 @@ subroutine aerosol_optics_cam_lw(list_idx, state, pbuf, tauxar) integer :: iwav, ilev integer :: ncol, icol integer :: num_aero_models - integer :: itim_old real(r8), pointer :: cldn(:,:) ! layer cloud fraction (0-1) @@ -1183,8 +1180,7 @@ subroutine aerosol_optics_cam_lw(list_idx, state, pbuf, tauxar) relh(:ncol,:) = max(1.e-20_r8,relh(:ncol,:)) ! layer cloud fraction, for the water uptake recompute of diagnostic lists - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, pbuf_get_index('CLD'), cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, pbuf_get_index('CLD'), cldn, start=(/1,1/), kount=(/pcols,pver/)) aeromodel: do iaermod = 1,num_aero_models diff --git a/src/physics/cam/microp_aero.F90 b/src/physics/cam/microp_aero.F90 index 35986213a7..8424a39f2e 100644 --- a/src/physics/cam/microp_aero.F90 +++ b/src/physics/cam/microp_aero.F90 @@ -127,9 +127,7 @@ module microp_aero integer :: naer_all = 0 integer :: npccn_idx, rndst_idx, nacon_idx -! dropmixnuc CAM interface data (moved from ndrop) -! psat/ccn_name serve the CCN diagnostics of both the modal (dropmixnuc) and -! bulk (ndrop_bam) paths; the values match the psat/supersat conventions of both. +! dropmixnuc CAM interface data integer, parameter :: psat = 6 ! number of supersaturations used to calc ccn concentration character(len=8) :: ccn_name(psat)= & (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6'/) @@ -144,7 +142,8 @@ module microp_aero logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies ! in the ptend object -! true for aerosol elements resolving to advected constituents (dropmixnuc tendency-return) +! true for aerosol elements resolving to advected constituents +! (dropmixnuc returns tendencies) logical, allocatable :: dotend(:) logical :: separate_dust = .false. @@ -658,7 +657,7 @@ subroutine microp_aero_run ( & real(r8), allocatable :: factnum(:,:,:) ! activation fraction for aerosol number - ! dropmixnuc work arrays and diagnostics (CAM marshal, moved from ndrop) + ! dropmixnuc work arrays and diagnostics real(r8), allocatable :: raertend_out(:,:,:) ! tendency of interstitial aerosol mass, number mixing ratios real(r8), allocatable :: coltend(:,:) ! column tendency for diagnostic output real(r8), allocatable :: coltend_cw(:,:) ! column tendency @@ -861,8 +860,6 @@ subroutine microp_aero_run ( & call endrun('microp_aero_run: not able to allocate dropmixnuc work arrays') endif - ! dropmixnuc CAM marshaling (moved from ndrop): kvh from pbuf, ptend - ! initialized with the aerosol lq mask. call pbuf_get_field(pbuf, kvh_idx, kvh) ! initialize aerosol tendencies From e926709468319df4bbe644dfcdeb4760f50fc65c Mon Sep 17 00:00:00 2001 From: Haipeng Lin Date: Mon, 10 Aug 2026 14:07:28 -0400 Subject: [PATCH 4/6] Whitespace-only cleanup for new files --- src/chemistry/aerosol/aero_convproc_cam.F90 | 893 +++++++------ src/chemistry/aerosol/mo_setsox_cam.F90 | 492 +++---- src/chemistry/aerosol/wetdep_cam.F90 | 298 +++-- .../modal_aero/modal_aero_coag_cam.F90 | 641 +++++---- .../modal_aero/modal_aero_gasaerexch_cam.F90 | 924 ++++++------- .../modal_aero/modal_aero_newnuc_cam.F90 | 268 ++-- .../modal_aero/modal_aero_rename_cam.F90 | 994 +++++++------- .../utils/modal_aero_calcsize_cam.F90 | 1160 ++++++++--------- .../utils/modal_aero_wateruptake_cam.F90 | 762 ++++++----- 9 files changed, 3208 insertions(+), 3224 deletions(-) diff --git a/src/chemistry/aerosol/aero_convproc_cam.F90 b/src/chemistry/aerosol/aero_convproc_cam.F90 index 50e5f5a7e4..b546a80cc2 100644 --- a/src/chemistry/aerosol/aero_convproc_cam.F90 +++ b/src/chemistry/aerosol/aero_convproc_cam.F90 @@ -14,277 +14,277 @@ module aero_convproc_cam ! !--------------------------------------------------------------------------------- -use shr_kind_mod, only: r8=>shr_kind_r8 -use shr_kind_mod, only: shr_kind_cs - -use spmd_utils, only: masterproc -use physconst, only: gravit, rair -use physconst, only: pi, rhoh2o, rh2o, latvap, cpair -use ppgrid, only: pver, pcols, pverp -use constituents, only: pcnst, cnst_get_ind -use constituents, only: cnst_species_class, cnst_spec_class_aerosol -use phys_control, only: phys_getopts - -use physics_types, only: physics_state, physics_ptend -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field -use time_manager, only: get_nstep -use cam_history, only: outfld, addfld, add_default, horiz_only -use cam_logfile, only: iulog -use cam_abortutils, only: endrun - -use aerosol_properties_mod, only: aerosol_properties -use aerosol_state_mod, only: aerosol_state, ptr2d_t - -use aero_convproc, only: aero_convproc_run -use aero_convproc, only: use_cwaer_for_activate_maxsat, convproc_method_activate -use aero_convproc, only: method1_activate_nlayers, method2_activate_smaxmax -use aero_convproc, only: method_reduce_actfrac, factor_reduce_actfrac - -implicit none -private - -public :: aero_convproc_readnl -public :: aero_convproc_init -public :: aero_convproc_intr + use shr_kind_mod, only: r8=>shr_kind_r8 + use shr_kind_mod, only: shr_kind_cs + + use spmd_utils, only: masterproc + use physconst, only: gravit, rair + use physconst, only: pi, rhoh2o, rh2o, latvap, cpair + use ppgrid, only: pver, pcols, pverp + use constituents, only: pcnst, cnst_get_ind + use constituents, only: cnst_species_class, cnst_spec_class_aerosol + use phys_control, only: phys_getopts + + use physics_types, only: physics_state, physics_ptend + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field + use time_manager, only: get_nstep + use cam_history, only: outfld, addfld, add_default, horiz_only + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + + use aerosol_properties_mod, only: aerosol_properties + use aerosol_state_mod, only: aerosol_state, ptr2d_t + + use aero_convproc, only: aero_convproc_run + use aero_convproc, only: use_cwaer_for_activate_maxsat, convproc_method_activate + use aero_convproc, only: method1_activate_nlayers, method2_activate_smaxmax + use aero_convproc, only: method_reduce_actfrac, factor_reduce_actfrac + + implicit none + private + + public :: aero_convproc_readnl + public :: aero_convproc_init + public :: aero_convproc_intr ! namelist options ! NOTE: These are the defaults for CAM6. -logical, protected, public :: deepconv_wetdep_history = .true. -logical, protected, public :: convproc_do_deep = .true. + logical, protected, public :: deepconv_wetdep_history = .true. + logical, protected, public :: convproc_do_deep = .true. ! NOTE: These are the defaults for the Eaton/Wang parameterization. -logical, protected, public :: convproc_do_evaprain_atonce = .false. -real(r8), protected, public :: convproc_pom_spechygro = -1._r8 -real(r8), protected, public :: convproc_wup_max = 4.0_r8 + logical, protected, public :: convproc_do_evaprain_atonce = .false. + real(r8), protected, public :: convproc_pom_spechygro = -1._r8 + real(r8), protected, public :: convproc_wup_max = 4.0_r8 -logical, parameter :: apply_convproc_tend_to_ptend = .true. + logical, parameter :: apply_convproc_tend_to_ptend = .true. -logical :: convproc_do_aer + logical :: convproc_do_aer ! physics buffer indices -integer :: fracis_idx = 0 + integer :: fracis_idx = 0 -integer :: rprddp_idx = 0 -integer :: rprdsh_idx = 0 -integer :: nevapr_shcu_idx = 0 -integer :: nevapr_dpcu_idx = 0 + integer :: rprddp_idx = 0 + integer :: rprdsh_idx = 0 + integer :: nevapr_shcu_idx = 0 + integer :: nevapr_dpcu_idx = 0 -integer :: icwmrdp_idx = 0 -integer :: icwmrsh_idx = 0 -integer :: sh_frac_idx = 0 -integer :: dp_frac_idx = 0 + integer :: icwmrdp_idx = 0 + integer :: icwmrsh_idx = 0 + integer :: sh_frac_idx = 0 + integer :: dp_frac_idx = 0 -integer :: zm_eu_idx = 0 -integer :: zm_du_idx = 0 -integer :: zm_ed_idx = 0 -integer :: zm_dp_idx = 0 -integer :: zm_jt_idx = 0 -integer :: zm_maxg_idx = 0 -integer :: zm_ideep_idx = 0 + integer :: zm_eu_idx = 0 + integer :: zm_du_idx = 0 + integer :: zm_ed_idx = 0 + integer :: zm_dp_idx = 0 + integer :: zm_jt_idx = 0 + integer :: zm_maxg_idx = 0 + integer :: zm_ideep_idx = 0 -integer :: cmfmc_sh_idx = 0 -integer :: sh_e_ed_ratio_idx = 0 + integer :: cmfmc_sh_idx = 0 + integer :: sh_e_ed_ratio_idx = 0 -integer :: istat + integer :: istat -integer :: nbins = 0 -integer :: ncnstaer = 0 + integer :: nbins = 0 + integer :: ncnstaer = 0 -integer, allocatable :: aer_cnst_ndx(:) + integer, allocatable :: aer_cnst_ndx(:) -character(len=32), allocatable :: cnst_name_extd(:,:) ! (2,ncnstaer) + character(len=32), allocatable :: cnst_name_extd(:,:) ! (2,ncnstaer) contains !========================================================================================= -subroutine aero_convproc_readnl(nlfile) - - use namelist_utils, only: find_group_name - use spmd_utils, only: mpicom, masterprocid, mpi_real8, mpi_logical - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'aero_convproc_readnl' - - namelist /aerosol_convproc_opts/ deepconv_wetdep_history, convproc_do_deep, & - convproc_do_evaprain_atonce, convproc_pom_spechygro, convproc_wup_max - - ! Read namelist - if (masterproc) then - open( newunit=unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'aerosol_convproc_opts', status=ierr) - if (ierr == 0) then - read(unitn, aerosol_convproc_opts, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - end if - - ! Broadcast namelist variables - call mpi_bcast( deepconv_wetdep_history, 1, mpi_logical, masterprocid, mpicom, ierr) - call mpi_bcast( convproc_do_deep, 1, mpi_logical, masterprocid, mpicom, ierr) - call mpi_bcast( convproc_do_evaprain_atonce, 1, mpi_logical, masterprocid, mpicom, ierr) - call mpi_bcast( convproc_pom_spechygro, 1, mpi_real8, masterprocid, mpicom, ierr) - call mpi_bcast( convproc_wup_max, 1, mpi_real8, masterprocid, mpicom, ierr) - - if (masterproc) then - write(iulog,*) subname//': deepconv_wetdep_history = ',deepconv_wetdep_history - write(iulog,*) subname//': convproc_do_deep = ',convproc_do_deep - write(iulog,*) subname//': convproc_do_evaprain_atonce = ',convproc_do_evaprain_atonce - write(iulog,*) subname//': convproc_pom_spechygro = ',convproc_pom_spechygro - write(iulog,*) subname//': convproc_wup_max = ', convproc_wup_max - end if - -end subroutine aero_convproc_readnl + subroutine aero_convproc_readnl(nlfile) -!========================================================================================= + use namelist_utils, only: find_group_name + use spmd_utils, only: mpicom, masterprocid, mpi_real8, mpi_logical + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input -subroutine aero_convproc_init(aero_props) + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'aero_convproc_readnl' - class(aerosol_properties), intent(in) :: aero_props + namelist /aerosol_convproc_opts/ deepconv_wetdep_history, convproc_do_deep, & + convproc_do_evaprain_atonce, convproc_pom_spechygro, convproc_wup_max - integer :: m, mm, l, ndx, astat - integer :: npass_calc_updraft - logical :: history_aerosol - character(len=32) :: name_a, name_c + ! Read namelist + if (masterproc) then + open( newunit=unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'aerosol_convproc_opts', status=ierr) + if (ierr == 0) then + read(unitn, aerosol_convproc_opts, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + end if - character(len=*), parameter :: prefix = 'aero_convproc_init: ' + ! Broadcast namelist variables + call mpi_bcast( deepconv_wetdep_history, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast( convproc_do_deep, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast( convproc_do_evaprain_atonce, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast( convproc_pom_spechygro, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast( convproc_wup_max, 1, mpi_real8, masterprocid, mpicom, ierr) + + if (masterproc) then + write(iulog,*) subname//': deepconv_wetdep_history = ',deepconv_wetdep_history + write(iulog,*) subname//': convproc_do_deep = ',convproc_do_deep + write(iulog,*) subname//': convproc_do_evaprain_atonce = ',convproc_do_evaprain_atonce + write(iulog,*) subname//': convproc_pom_spechygro = ',convproc_pom_spechygro + write(iulog,*) subname//': convproc_wup_max = ', convproc_wup_max + end if - nbins = aero_props%nbins() - ncnstaer = aero_props%ncnst_tot() + end subroutine aero_convproc_readnl - allocate(aer_cnst_ndx(ncnstaer),stat=astat) - if (astat/=0) then - call endrun(prefix//'aer_cnst_ndx allocation error') - end if - allocate(cnst_name_extd(2,ncnstaer),stat=astat) - if (astat/=0) then - call endrun(prefix//'cnst_name_extd allocation error') - end if +!========================================================================================= - aer_cnst_ndx(:) = -1 + subroutine aero_convproc_init(aero_props) - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - if (l==0) then - call aero_props%num_names(m, name_a, name_c) - else - call aero_props%mmr_names(m,l, name_a, name_c) - endif - cnst_name_extd(1,mm) = name_a - cnst_name_extd(2,mm) = name_c + class(aerosol_properties), intent(in) :: aero_props - call cnst_get_ind(trim(name_a), ndx, abort=.false.) - aer_cnst_ndx(mm) = ndx - end do - end do + integer :: m, mm, l, ndx, astat + integer :: npass_calc_updraft + logical :: history_aerosol + character(len=32) :: name_a, name_c - call phys_getopts( history_aerosol_out=history_aerosol, & - convproc_do_aer_out = convproc_do_aer ) + character(len=*), parameter :: prefix = 'aero_convproc_init: ' - call addfld('DP_MFUP_MAX', horiz_only, 'A', 'kg/m2', & - 'Deep conv. column-max updraft mass flux' ) - call addfld('DP_WCLDBASE', horiz_only, 'A', 'm/s', & - 'Deep conv. cloudbase vertical velocity' ) - call addfld('DP_KCLDBASE', horiz_only, 'A', '1', & - 'Deep conv. cloudbase level index' ) + nbins = aero_props%nbins() + ncnstaer = aero_props%ncnst_tot() - ! output wet deposition fields to history - ! I = in-cloud removal; E = precip-evap resuspension - ! C = convective (total); D = deep convective - ! note that the precip-evap resuspension includes that resulting from - ! below-cloud removal, calculated in mz_aero_wet_intr - if (convproc_do_aer .and. apply_convproc_tend_to_ptend ) then + allocate(aer_cnst_ndx(ncnstaer),stat=astat) + if (astat/=0) then + call endrun(prefix//'aer_cnst_ndx allocation error') + end if + allocate(cnst_name_extd(2,ncnstaer),stat=astat) + if (astat/=0) then + call endrun(prefix//'cnst_name_extd allocation error') + end if + + aer_cnst_ndx(:) = -1 do m = 1, aero_props%nbins() do l = 0, aero_props%nmasses(m) mm = aero_props%indexer(m,l) + if (l==0) then + call aero_props%num_names(m, name_a, name_c) + else + call aero_props%mmr_names(m,l, name_a, name_c) + endif + cnst_name_extd(1,mm) = name_a + cnst_name_extd(2,mm) = name_c + + call cnst_get_ind(trim(name_a), ndx, abort=.false.) + aer_cnst_ndx(mm) = ndx + end do + end do - ndx = aer_cnst_ndx(mm) + call phys_getopts( history_aerosol_out=history_aerosol, & + convproc_do_aer_out = convproc_do_aer ) + + call addfld('DP_MFUP_MAX', horiz_only, 'A', 'kg/m2', & + 'Deep conv. column-max updraft mass flux' ) + call addfld('DP_WCLDBASE', horiz_only, 'A', 'm/s', & + 'Deep conv. cloudbase vertical velocity' ) + call addfld('DP_KCLDBASE', horiz_only, 'A', '1', & + 'Deep conv. cloudbase level index' ) - if ( deepconv_wetdep_history ) then - call addfld (trim(cnst_name_extd(1,mm))//'SFSID', & - horiz_only, 'A','kg/m2/s','Wet deposition flux (incloud, deep convective) at surface') - call addfld (trim(cnst_name_extd(1,mm))//'SFSED', & - horiz_only, 'A','kg/m2/s','Wet deposition flux (precip evap, deep convective) at surface') - if (history_aerosol) then - call add_default(trim(cnst_name_extd(1,mm))//'SFSID', 1, ' ') - call add_default(trim(cnst_name_extd(1,mm))//'SFSED', 1, ' ') + ! output wet deposition fields to history + ! I = in-cloud removal; E = precip-evap resuspension + ! C = convective (total); D = deep convective + ! note that the precip-evap resuspension includes that resulting from + ! below-cloud removal, calculated in mz_aero_wet_intr + if (convproc_do_aer .and. apply_convproc_tend_to_ptend ) then + + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) + mm = aero_props%indexer(m,l) + + ndx = aer_cnst_ndx(mm) + + if ( deepconv_wetdep_history ) then + call addfld (trim(cnst_name_extd(1,mm))//'SFSID', & + horiz_only, 'A','kg/m2/s','Wet deposition flux (incloud, deep convective) at surface') + call addfld (trim(cnst_name_extd(1,mm))//'SFSED', & + horiz_only, 'A','kg/m2/s','Wet deposition flux (precip evap, deep convective) at surface') + if (history_aerosol) then + call add_default(trim(cnst_name_extd(1,mm))//'SFSID', 1, ' ') + call add_default(trim(cnst_name_extd(1,mm))//'SFSED', 1, ' ') + end if end if - end if + end do end do - end do - end if - - if ( history_aerosol .and. convproc_do_aer ) then - call add_default( 'DP_MFUP_MAX', 1, ' ' ) - call add_default( 'DP_WCLDBASE', 1, ' ' ) - call add_default( 'DP_KCLDBASE', 1, ' ' ) - end if - - fracis_idx = pbuf_get_index('FRACIS') - - rprddp_idx = pbuf_get_index('RPRDDP') - rprdsh_idx = pbuf_get_index('RPRDSH') - nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') - nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') - - icwmrdp_idx = pbuf_get_index('ICWMRDP') - icwmrsh_idx = pbuf_get_index('ICWMRSH') - dp_frac_idx = pbuf_get_index('DP_FRAC') - sh_frac_idx = pbuf_get_index('SH_FRAC') - - zm_eu_idx = pbuf_get_index('ZM_EU') - zm_du_idx = pbuf_get_index('ZM_DU') - zm_ed_idx = pbuf_get_index('ZM_ED') - zm_dp_idx = pbuf_get_index('ZM_DP') - zm_jt_idx = pbuf_get_index('ZM_JT') - zm_maxg_idx = pbuf_get_index('ZM_MAXG') - zm_ideep_idx = pbuf_get_index('ZM_IDEEP') - - cmfmc_sh_idx = pbuf_get_index('CMFMC_SH') - sh_e_ed_ratio_idx = pbuf_get_index('SH_E_ED_RATIO', istat) - - if (masterproc ) then - - write(iulog,'(a,l12)') 'aero_convproc_init - convproc_do_aer = ', & - convproc_do_aer - write(iulog,'(a,l12)') 'aero_convproc_init - use_cwaer_for_activate_maxsat = ', & - use_cwaer_for_activate_maxsat - write(iulog,'(a,l12)') 'aero_convproc_init - apply_convproc_tend_to_ptend = ', & - apply_convproc_tend_to_ptend - write(iulog,'(a,i12)') 'aero_convproc_init - convproc_method_activate = ', & - convproc_method_activate - write(iulog,'(a,i12)') 'aero_convproc_init - method1_activate_nlayers = ', & - method1_activate_nlayers - write(iulog,'(a,1pe12.4)') 'aero_convproc_init - method2_activate_smaxmax = ', & - method2_activate_smaxmax - write(iulog,'(a,i12)') 'aero_convproc_init - method_reduce_actfrac = ', & - method_reduce_actfrac - write(iulog,'(a,1pe12.4)') 'aero_convproc_init - factor_reduce_actfrac = ', & - factor_reduce_actfrac - - npass_calc_updraft = 1 - if ( (method_reduce_actfrac == 2) .and. & - (factor_reduce_actfrac >= 0.0_r8) .and. & - (factor_reduce_actfrac <= 1.0_r8) ) npass_calc_updraft = 2 - write(iulog,'(a,i12)') 'aero_convproc_init - npass_calc_updraft = ', & - npass_calc_updraft - - end if - -end subroutine aero_convproc_init + end if + + if ( history_aerosol .and. convproc_do_aer ) then + call add_default( 'DP_MFUP_MAX', 1, ' ' ) + call add_default( 'DP_WCLDBASE', 1, ' ' ) + call add_default( 'DP_KCLDBASE', 1, ' ' ) + end if + + fracis_idx = pbuf_get_index('FRACIS') + + rprddp_idx = pbuf_get_index('RPRDDP') + rprdsh_idx = pbuf_get_index('RPRDSH') + nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') + nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') + + icwmrdp_idx = pbuf_get_index('ICWMRDP') + icwmrsh_idx = pbuf_get_index('ICWMRSH') + dp_frac_idx = pbuf_get_index('DP_FRAC') + sh_frac_idx = pbuf_get_index('SH_FRAC') + + zm_eu_idx = pbuf_get_index('ZM_EU') + zm_du_idx = pbuf_get_index('ZM_DU') + zm_ed_idx = pbuf_get_index('ZM_ED') + zm_dp_idx = pbuf_get_index('ZM_DP') + zm_jt_idx = pbuf_get_index('ZM_JT') + zm_maxg_idx = pbuf_get_index('ZM_MAXG') + zm_ideep_idx = pbuf_get_index('ZM_IDEEP') + + cmfmc_sh_idx = pbuf_get_index('CMFMC_SH') + sh_e_ed_ratio_idx = pbuf_get_index('SH_E_ED_RATIO', istat) + + if (masterproc ) then + + write(iulog,'(a,l12)') 'aero_convproc_init - convproc_do_aer = ', & + convproc_do_aer + write(iulog,'(a,l12)') 'aero_convproc_init - use_cwaer_for_activate_maxsat = ', & + use_cwaer_for_activate_maxsat + write(iulog,'(a,l12)') 'aero_convproc_init - apply_convproc_tend_to_ptend = ', & + apply_convproc_tend_to_ptend + write(iulog,'(a,i12)') 'aero_convproc_init - convproc_method_activate = ', & + convproc_method_activate + write(iulog,'(a,i12)') 'aero_convproc_init - method1_activate_nlayers = ', & + method1_activate_nlayers + write(iulog,'(a,1pe12.4)') 'aero_convproc_init - method2_activate_smaxmax = ', & + method2_activate_smaxmax + write(iulog,'(a,i12)') 'aero_convproc_init - method_reduce_actfrac = ', & + method_reduce_actfrac + write(iulog,'(a,1pe12.4)') 'aero_convproc_init - factor_reduce_actfrac = ', & + factor_reduce_actfrac + + npass_calc_updraft = 1 + if ( (method_reduce_actfrac == 2) .and. & + (factor_reduce_actfrac >= 0.0_r8) .and. & + (factor_reduce_actfrac <= 1.0_r8) ) npass_calc_updraft = 2 + write(iulog,'(a,i12)') 'aero_convproc_init - npass_calc_updraft = ', & + npass_calc_updraft + + end if + + end subroutine aero_convproc_init !========================================================================================= -subroutine aero_convproc_intr( aero_props, aero_state, state, ptend, pbuf, ztodt, & - nsrflx_mzaer2cnvpr, qsrflx_mzaer2cnvpr, & - aerdepwetis, dcondt_resusp3d ) + subroutine aero_convproc_intr( aero_props, aero_state, state, ptend, pbuf, ztodt, & + nsrflx_mzaer2cnvpr, qsrflx_mzaer2cnvpr, & + aerdepwetis, dcondt_resusp3d ) !----------------------------------------------------------------------- ! ! Convective cloud processing (transport, activation/resuspension, @@ -300,164 +300,161 @@ subroutine aero_convproc_intr( aero_props, aero_state, state, ptend, pbuf, ztodt ! !----------------------------------------------------------------------- + ! Arguments + class(aerosol_properties), intent(in) :: aero_props + class(aerosol_state), intent(in) :: aero_state - ! Arguments - class(aerosol_properties), intent(in) :: aero_props - class(aerosol_state), intent(in) :: aero_state + type(physics_state),target,intent(in ) :: state ! Physics state variables + type(physics_ptend), intent(inout) :: ptend ! %lq set in aero_model_wetdep + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(in) :: ztodt ! model physics timestep [s] - type(physics_state),target,intent(in ) :: state ! Physics state variables - type(physics_ptend), intent(inout) :: ptend ! %lq set in aero_model_wetdep - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: ztodt ! model physics timestep [s] + integer, intent(in) :: nsrflx_mzaer2cnvpr + real(r8), intent(in) :: qsrflx_mzaer2cnvpr(pcols,ncnstaer,nsrflx_mzaer2cnvpr) + real(r8), intent(inout) :: aerdepwetis(pcols,pcnst) ! aerosol wet deposition (interstitial) + real(r8), intent(inout) :: dcondt_resusp3d(ncnstaer,pcols,pver) - integer, intent(in) :: nsrflx_mzaer2cnvpr - real(r8), intent(in) :: qsrflx_mzaer2cnvpr(pcols,ncnstaer,nsrflx_mzaer2cnvpr) - real(r8), intent(inout) :: aerdepwetis(pcols,pcnst) ! aerosol wet deposition (interstitial) - real(r8), intent(inout) :: dcondt_resusp3d(ncnstaer,pcols,pver) + ! Local variables + integer, parameter :: nsrflx = 5 ! last dimension of qsrflx + integer :: l, m, mm, ndx, lchnk + integer :: ncol - ! Local variables - integer, parameter :: nsrflx = 5 ! last dimension of qsrflx - integer :: l, m, mm, ndx, lchnk - integer :: ncol + real(r8) :: dqdt(pcols,pver,ncnstaer) + real(r8) :: dt - real(r8) :: dqdt(pcols,pver,ncnstaer) - real(r8) :: dt + real(r8) :: q(pcols,pver,ncnstaer) + real(r8) :: qsrflx(pcols,ncnstaer,nsrflx) + real(r8), pointer :: qptr(:,:) + real(r8) :: sflxic(pcols,ncnstaer) + real(r8) :: sflxid(pcols,ncnstaer) + real(r8) :: sflxec(pcols,ncnstaer) + real(r8) :: sflxed(pcols,ncnstaer) + type(ptr2d_t) :: raer(ncnstaer) ! aerosol mass, number mixing ratios + type(ptr2d_t) :: qqcw(ncnstaer) - real(r8) :: q(pcols,pver,ncnstaer) - real(r8) :: qsrflx(pcols,ncnstaer,nsrflx) - real(r8), pointer :: qptr(:,:) + logical :: dotend(pcnst) + logical :: applytend - real(r8) :: sflxic(pcols,ncnstaer) - real(r8) :: sflxid(pcols,ncnstaer) - real(r8) :: sflxec(pcols,ncnstaer) - real(r8) :: sflxed(pcols,ncnstaer) + !------------------------------------------------------------------------------------------------- - type(ptr2d_t) :: raer(ncnstaer) ! aerosol mass, number mixing ratios - type(ptr2d_t) :: qqcw(ncnstaer) + dotend = .false. - logical :: dotend(pcnst) - logical :: applytend + ! Initialize + lchnk = state%lchnk + ncol = state%ncol + dt = ztodt - !------------------------------------------------------------------------------------------------- + sflxic(:,:) = 0.0_r8 + sflxid(:,:) = 0.0_r8 + sflxec(:,:) = 0.0_r8 + sflxed(:,:) = 0.0_r8 - dotend = .false. + call aero_state%get_states( aero_props, raer, qqcw ) - ! Initialize - lchnk = state%lchnk - ncol = state%ncol - dt = ztodt - - sflxic(:,:) = 0.0_r8 - sflxid(:,:) = 0.0_r8 - sflxec(:,:) = 0.0_r8 - sflxed(:,:) = 0.0_r8 - - call aero_state%get_states( aero_props, raer, qqcw ) - - ! prepare for deep conv processing - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) + ! prepare for deep conv processing + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - ndx = aer_cnst_ndx(mm) + mm = aero_props%indexer(m,l) + ndx = aer_cnst_ndx(mm) - sflxec(1:ncol,mm) = qsrflx_mzaer2cnvpr(1:ncol,mm,1) - sflxed(1:ncol,mm) = qsrflx_mzaer2cnvpr(1:ncol,mm,2) + sflxec(1:ncol,mm) = qsrflx_mzaer2cnvpr(1:ncol,mm,1) + sflxed(1:ncol,mm) = qsrflx_mzaer2cnvpr(1:ncol,mm,2) - applytend = .false. - if ( ndx > 0 ) then - applytend = ptend%lq(ndx) - dotend(ndx) = applytend - endif + applytend = .false. + if ( ndx > 0 ) then + applytend = ptend%lq(ndx) + dotend(ndx) = applytend + endif - qptr => raer(mm)%fld + qptr => raer(mm)%fld - if ( applytend ) then - ! calc new q (after calcaersize and mz_aero_wet_intr) - q(1:ncol,:,mm) = max( 0.0_r8, qptr(1:ncol,:) + dt*ptend%q(1:ncol,:,ndx) ) - else - ! use old q - q(1:ncol,:,mm) = qptr(1:ncol,:) - end if + if ( applytend ) then + ! calc new q (after calcaersize and mz_aero_wet_intr) + q(1:ncol,:,mm) = max( 0.0_r8, qptr(1:ncol,:) + dt*ptend%q(1:ncol,:,ndx) ) + else + ! use old q + q(1:ncol,:,mm) = qptr(1:ncol,:) + end if + end do end do - end do - dqdt(:,:,:) = 0.0_r8 - qsrflx(:,:,:) = 0.0_r8 + dqdt(:,:,:) = 0.0_r8 + qsrflx(:,:,:) = 0.0_r8 - if (convproc_do_aer) then + if (convproc_do_aer) then - ! do deep conv processing - if (convproc_do_deep) then - call aero_convproc_dp_intr( aero_props, & - state, pbuf, dt, & - q, dqdt, nsrflx, qsrflx, dcondt_resusp3d ) + ! do deep conv processing + if (convproc_do_deep) then + call aero_convproc_dp_intr( aero_props, & + state, pbuf, dt, & + q, dqdt, nsrflx, qsrflx, dcondt_resusp3d ) - ! apply deep conv processing tendency + ! apply deep conv processing tendency - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - ndx = aer_cnst_ndx(mm) + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) + mm = aero_props%indexer(m,l) + ndx = aer_cnst_ndx(mm) - if ( apply_convproc_tend_to_ptend ) then - ! add dqdt onto ptend%q and set ptend%lq - if (ndx>0) then ! advected species - ptend%q(1:ncol,:,ndx) = ptend%q(1:ncol,:,ndx) + dqdt(1:ncol,:,mm) - else - raer(mm)%fld(1:ncol,:) = max( 0.0_r8, raer(mm)%fld(1:ncol,:) + dqdt(1:ncol,:,mm) * dt ) + if ( apply_convproc_tend_to_ptend ) then + ! add dqdt onto ptend%q and set ptend%lq + if (ndx>0) then ! advected species + ptend%q(1:ncol,:,ndx) = ptend%q(1:ncol,:,ndx) + dqdt(1:ncol,:,mm) + else + raer(mm)%fld(1:ncol,:) = max( 0.0_r8, raer(mm)%fld(1:ncol,:) + dqdt(1:ncol,:,mm) * dt ) + end if end if - end if - ! these used for history file wetdep diagnostics - sflxic(1:ncol,mm) = sflxic(1:ncol,mm) + qsrflx(1:ncol,mm,4) - sflxid(1:ncol,mm) = sflxid(1:ncol,mm) + qsrflx(1:ncol,mm,4) - sflxec(1:ncol,mm) = sflxec(1:ncol,mm) + qsrflx(1:ncol,mm,5) - sflxed(1:ncol,mm) = sflxed(1:ncol,mm) + qsrflx(1:ncol,mm,5) + ! these used for history file wetdep diagnostics + sflxic(1:ncol,mm) = sflxic(1:ncol,mm) + qsrflx(1:ncol,mm,4) + sflxid(1:ncol,mm) = sflxid(1:ncol,mm) + qsrflx(1:ncol,mm,4) + sflxec(1:ncol,mm) = sflxec(1:ncol,mm) + qsrflx(1:ncol,mm,5) + sflxed(1:ncol,mm) = sflxed(1:ncol,mm) + qsrflx(1:ncol,mm,5) - ! this used for surface coupling - if (ndx>0) then - aerdepwetis(1:ncol,ndx) = aerdepwetis(1:ncol,ndx) & - + qsrflx(1:ncol,mm,4) + qsrflx(1:ncol,mm,5) - end if + ! this used for surface coupling + if (ndx>0) then + aerdepwetis(1:ncol,ndx) = aerdepwetis(1:ncol,ndx) & + + qsrflx(1:ncol,mm,4) + qsrflx(1:ncol,mm,5) + end if + end do end do - end do - end if + end if - end if ! (convproc_do_aer) then + end if ! (convproc_do_aer) then - if (convproc_do_aer .and. apply_convproc_tend_to_ptend ) then + if (convproc_do_aer .and. apply_convproc_tend_to_ptend ) then - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) + mm = aero_props%indexer(m,l) - ndx = aer_cnst_ndx(mm) + ndx = aer_cnst_ndx(mm) - if (ndx>0) call outfld( trim(cnst_name_extd(1,mm))//'SFWETC', aerdepwetis(:,ndx), pcols, lchnk ) - call outfld( trim(cnst_name_extd(1,mm))//'SFSIC', sflxic(:,mm), pcols, lchnk ) - call outfld( trim(cnst_name_extd(1,mm))//'SFSEC', sflxec(:,mm), pcols, lchnk ) + if (ndx>0) call outfld( trim(cnst_name_extd(1,mm))//'SFWETC', aerdepwetis(:,ndx), pcols, lchnk ) + call outfld( trim(cnst_name_extd(1,mm))//'SFSIC', sflxic(:,mm), pcols, lchnk ) + call outfld( trim(cnst_name_extd(1,mm))//'SFSEC', sflxec(:,mm), pcols, lchnk ) - if ( deepconv_wetdep_history ) then - call outfld( trim(cnst_name_extd(1,mm))//'SFSID', sflxid(:,mm), pcols, lchnk ) - call outfld( trim(cnst_name_extd(1,mm))//'SFSED', sflxed(:,mm), pcols, lchnk ) - end if + if ( deepconv_wetdep_history ) then + call outfld( trim(cnst_name_extd(1,mm))//'SFSID', sflxid(:,mm), pcols, lchnk ) + call outfld( trim(cnst_name_extd(1,mm))//'SFSED', sflxed(:,mm), pcols, lchnk ) + end if + end do end do - end do - end if + end if -end subroutine aero_convproc_intr + end subroutine aero_convproc_intr !========================================================================================= -subroutine aero_convproc_dp_intr( aero_props, & - state, pbuf, dt, & - q, dqdt, nsrflx, qsrflx, dcondt_resusp3d) + subroutine aero_convproc_dp_intr( aero_props, & + state, pbuf, dt, & + q, dqdt, nsrflx, qsrflx, dcondt_resusp3d) !----------------------------------------------------------------------- ! ! Convective cloud processing (transport, activation/resuspension, @@ -473,117 +470,117 @@ subroutine aero_convproc_dp_intr( aero_props, & ! !----------------------------------------------------------------------- - ! Arguments - class(aerosol_properties), intent(in) :: aero_props - - type(physics_state), intent(in ) :: state ! Physics state variables - type(physics_buffer_desc), pointer :: pbuf(:) - - real(r8), intent(in) :: dt ! delta t (model time increment) - - real(r8), intent(in) :: q(pcols,pver,ncnstaer) - real(r8), intent(inout) :: dqdt(pcols,pver,ncnstaer) - integer, intent(in) :: nsrflx - real(r8), intent(inout) :: qsrflx(pcols,ncnstaer,nsrflx) - real(r8), intent(inout) :: dcondt_resusp3d(ncnstaer,pcols,pver) - - integer :: i, l, m, mm - integer :: lchnk - integer :: nstep - - real(r8) :: dpdry(pcols,pver) ! layer delta-p-dry (mb) - real(r8) :: fracice(pcols,pver) ! Ice fraction of cloud droplets - real(r8) :: xx_mfup_max(pcols), xx_wcldbase(pcols), xx_kcldbase(pcols) - - ! updraft interface TMR + wet-deposition TMR tendency diagnostics returned - ! from aero_convproc_run for the WETC/CONU history fields - real(r8) :: conu2(pcols,pver,2,ncnstaer) - real(r8) :: dcondt2(pcols,pver,2,ncnstaer) - - character(len=512) :: errmsg - integer :: errflg - - ! physics buffer fields - real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble - real(r8), pointer :: rprddp(:,:) ! Deep conv precip production (kg/kg/s - grid avg) - real(r8), pointer :: evapcdp(:,:) ! Deep conv precip evaporation (kg/kg/s - grid avg) - real(r8), pointer :: icwmrdp(:,:) ! Deep conv cloud condensate (kg/kg - in cloud) - real(r8), pointer :: dp_frac(:,:) ! Deep conv cloud frac (0-1) - - ! deep conv variables - real(r8), pointer :: du(:,:) ! Mass detrain rate from updraft (pcols,pver) - real(r8), pointer :: eu(:,:) ! Mass entrain rate into updraft (pcols,pver) - real(r8), pointer :: ed(:,:) ! Mass entrain rate into downdraft (pcols,pver) - ! eu, ed, du are "d(massflux)/dp" and are all positive - real(r8), pointer :: dp(:,:) ! Delta pressure between interfaces (pcols,pver) - integer, pointer :: jt(:) ! Index of cloud top for each column (pcols) - integer, pointer :: maxg(:) ! Index of cloud bottom for each column (pcols) - integer, pointer :: ideep(:) ! Gathering array (pcols) - integer :: lengath ! Gathered min lon indices over which to operate - - ! Initialize - - lchnk = state%lchnk - nstep = get_nstep() - - ! Associate pointers with physics buffer fields - call pbuf_get_field(pbuf, rprddp_idx, rprddp) - call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp) - call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp) - call pbuf_get_field(pbuf, dp_frac_idx, dp_frac) - call pbuf_get_field(pbuf, fracis_idx, fracis) - call pbuf_get_field(pbuf, zm_eu_idx, eu) - call pbuf_get_field(pbuf, zm_du_idx, du) - call pbuf_get_field(pbuf, zm_ed_idx, ed) - call pbuf_get_field(pbuf, zm_dp_idx, dp) - call pbuf_get_field(pbuf, zm_jt_idx, jt) - call pbuf_get_field(pbuf, zm_maxg_idx, maxg) - call pbuf_get_field(pbuf, zm_ideep_idx, ideep) - - lengath = count(ideep > 0) - - fracice(:,:) = 0.0_r8 - - ! initialize dpdry (units=mb), which is used for tracers of dry mixing ratio type - dpdry = 0._r8 - do i = 1, lengath - dpdry(i,:) = state%pdeldry(ideep(i),:)/100._r8 - end do - - call aero_convproc_run( aero_props, 'deep', lchnk, dt, & - state%t, state%pmid, q, du, eu, & - ed, dp, dpdry, jt, & - maxg, ideep, 1, lengath, & - dp_frac, icwmrdp, rprddp, evapcdp, & - fracice, dqdt, nsrflx, qsrflx, & - xx_mfup_max, xx_wcldbase, xx_kcldbase, & - dcondt_resusp3d, conu2, dcondt2, & - state%ncol, pver, ncnstaer, nbins, & - pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & - convproc_do_evaprain_atonce, & - convproc_pom_spechygro, & - errmsg, errflg ) - if (errflg /= 0) call endrun(trim(errmsg)) - - call outfld( 'DP_MFUP_MAX', xx_mfup_max, pcols, lchnk ) - call outfld( 'DP_WCLDBASE', xx_wcldbase, pcols, lchnk ) - call outfld( 'DP_KCLDBASE', xx_kcldbase, pcols, lchnk ) - - ! WETC = wet-deposition tendency, CONU = updraft mixing ratio (interstitial - ! and cloud-borne); computed in aero_convproc_run and returned as out-args - do m = 1, aero_props%nbins() - do l = 0, aero_props%nmasses(m) - mm = aero_props%indexer(m,l) - - call outfld( trim(cnst_name_extd(1,mm))//'WETC', dcondt2(:,:,1,mm), pcols, lchnk ) - call outfld( trim(cnst_name_extd(1,mm))//'CONU', conu2(:,:,1,mm), pcols, lchnk ) - call outfld( trim(cnst_name_extd(2,mm))//'WETC', dcondt2(:,:,2,mm), pcols, lchnk ) - call outfld( trim(cnst_name_extd(2,mm))//'CONU', conu2(:,:,2,mm), pcols, lchnk ) + ! Arguments + class(aerosol_properties), intent(in) :: aero_props + + type(physics_state), intent(in ) :: state ! Physics state variables + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: dt ! delta t (model time increment) + + real(r8), intent(in) :: q(pcols,pver,ncnstaer) + real(r8), intent(inout) :: dqdt(pcols,pver,ncnstaer) + integer, intent(in) :: nsrflx + real(r8), intent(inout) :: qsrflx(pcols,ncnstaer,nsrflx) + real(r8), intent(inout) :: dcondt_resusp3d(ncnstaer,pcols,pver) + + integer :: i, l, m, mm + integer :: lchnk + integer :: nstep + + real(r8) :: dpdry(pcols,pver) ! layer delta-p-dry (mb) + real(r8) :: fracice(pcols,pver) ! Ice fraction of cloud droplets + real(r8) :: xx_mfup_max(pcols), xx_wcldbase(pcols), xx_kcldbase(pcols) + + ! updraft interface TMR + wet-deposition TMR tendency diagnostics returned + ! from aero_convproc_run for the WETC/CONU history fields + real(r8) :: conu2(pcols,pver,2,ncnstaer) + real(r8) :: dcondt2(pcols,pver,2,ncnstaer) + + character(len=512) :: errmsg + integer :: errflg + + ! physics buffer fields + real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble + real(r8), pointer :: rprddp(:,:) ! Deep conv precip production (kg/kg/s - grid avg) + real(r8), pointer :: evapcdp(:,:) ! Deep conv precip evaporation (kg/kg/s - grid avg) + real(r8), pointer :: icwmrdp(:,:) ! Deep conv cloud condensate (kg/kg - in cloud) + real(r8), pointer :: dp_frac(:,:) ! Deep conv cloud frac (0-1) + + ! deep conv variables + real(r8), pointer :: du(:,:) ! Mass detrain rate from updraft (pcols,pver) + real(r8), pointer :: eu(:,:) ! Mass entrain rate into updraft (pcols,pver) + real(r8), pointer :: ed(:,:) ! Mass entrain rate into downdraft (pcols,pver) + ! eu, ed, du are "d(massflux)/dp" and are all positive + real(r8), pointer :: dp(:,:) ! Delta pressure between interfaces (pcols,pver) + integer, pointer :: jt(:) ! Index of cloud top for each column (pcols) + integer, pointer :: maxg(:) ! Index of cloud bottom for each column (pcols) + integer, pointer :: ideep(:) ! Gathering array (pcols) + integer :: lengath ! Gathered min lon indices over which to operate + + ! Initialize + + lchnk = state%lchnk + nstep = get_nstep() + + ! Associate pointers with physics buffer fields + call pbuf_get_field(pbuf, rprddp_idx, rprddp) + call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp) + call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp) + call pbuf_get_field(pbuf, dp_frac_idx, dp_frac) + call pbuf_get_field(pbuf, fracis_idx, fracis) + call pbuf_get_field(pbuf, zm_eu_idx, eu) + call pbuf_get_field(pbuf, zm_du_idx, du) + call pbuf_get_field(pbuf, zm_ed_idx, ed) + call pbuf_get_field(pbuf, zm_dp_idx, dp) + call pbuf_get_field(pbuf, zm_jt_idx, jt) + call pbuf_get_field(pbuf, zm_maxg_idx, maxg) + call pbuf_get_field(pbuf, zm_ideep_idx, ideep) + + lengath = count(ideep > 0) + + fracice(:,:) = 0.0_r8 + + ! initialize dpdry (units=mb), which is used for tracers of dry mixing ratio type + dpdry = 0._r8 + do i = 1, lengath + dpdry(i,:) = state%pdeldry(ideep(i),:)/100._r8 + end do + call aero_convproc_run( aero_props, 'deep', lchnk, dt, & + state%t, state%pmid, q, du, eu, & + ed, dp, dpdry, jt, & + maxg, ideep, 1, lengath, & + dp_frac, icwmrdp, rprddp, evapcdp, & + fracice, dqdt, nsrflx, qsrflx, & + xx_mfup_max, xx_wcldbase, xx_kcldbase, & + dcondt_resusp3d, conu2, dcondt2, & + state%ncol, pver, ncnstaer, nbins, & + pi, rhoh2o, rh2o, gravit, latvap, cpair, rair, & + convproc_do_evaprain_atonce, & + convproc_pom_spechygro, & + errmsg, errflg ) + if (errflg /= 0) call endrun(trim(errmsg)) + + call outfld( 'DP_MFUP_MAX', xx_mfup_max, pcols, lchnk ) + call outfld( 'DP_WCLDBASE', xx_wcldbase, pcols, lchnk ) + call outfld( 'DP_KCLDBASE', xx_kcldbase, pcols, lchnk ) + + ! WETC = wet-deposition tendency, CONU = updraft mixing ratio (interstitial + ! and cloud-borne); computed in aero_convproc_run and returned as out-args + do m = 1, aero_props%nbins() + do l = 0, aero_props%nmasses(m) + mm = aero_props%indexer(m,l) + + call outfld( trim(cnst_name_extd(1,mm))//'WETC', dcondt2(:,:,1,mm), pcols, lchnk ) + call outfld( trim(cnst_name_extd(1,mm))//'CONU', conu2(:,:,1,mm), pcols, lchnk ) + call outfld( trim(cnst_name_extd(2,mm))//'WETC', dcondt2(:,:,2,mm), pcols, lchnk ) + call outfld( trim(cnst_name_extd(2,mm))//'CONU', conu2(:,:,2,mm), pcols, lchnk ) + + end do end do - end do -end subroutine aero_convproc_dp_intr + end subroutine aero_convproc_dp_intr !========================================================================================= diff --git a/src/chemistry/aerosol/mo_setsox_cam.F90 b/src/chemistry/aerosol/mo_setsox_cam.F90 index 4a4bb0ee6a..3d6626f380 100644 --- a/src/chemistry/aerosol/mo_setsox_cam.F90 +++ b/src/chemistry/aerosol/mo_setsox_cam.F90 @@ -3,256 +3,256 @@ !----------------------------------------------------------------------- module mo_setsox_cam - use shr_kind_mod, only : r8 => shr_kind_r8 - use cam_logfile, only : iulog - use physics_types,only : physics_state - use aerosol_state_mod, only: aerosol_state + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_logfile, only : iulog + use physics_types,only : physics_state + use aerosol_state_mod, only: aerosol_state - implicit none + implicit none - private - public :: sox_inti, setsox - public :: has_sox + private + public :: sox_inti, setsox + public :: has_sox - logical :: has_sox = .true. + logical :: has_sox = .true. contains - subroutine sox_inti(aero_props) - !----------------------------------------------------------------------- - ! ... initialize the hetero sox routine - !----------------------------------------------------------------------- - - use mo_chem_utls, only : get_spc_ndx, get_inv_ndx - use spmd_utils, only : masterproc - use phys_control, only : phys_getopts, cam_chempkg_is - use carma_flags_mod, only : carma_do_cloudborne - use mo_setsox, only : setsox_init - use sox_cldaero_mod, only : sox_cldaero_init - use aerosol_properties_mod, only : aerosol_properties - use mo_constants, only : pi - use cam_abortutils, only : endrun - - class(aerosol_properties), target, intent(in) :: aero_props - - logical :: modal_aerosols - - logical :: cloud_borne - integer :: id_msa - integer :: id_so2, id_nh3, id_hno3, id_h2o2, id_o3, id_ho2 - integer :: id_so4, id_h2so4 - logical :: inv_so2, inv_nh3, inv_hno3, inv_h2o2, inv_ho2, inv_o3 - - ! Indices for species in the shared array of Henry's Law constant parameters - integer :: heff_id_hno3, heff_id_so2, heff_id_nh3, heff_id_co2, heff_id_h2o2, heff_id_o3 - - character(len=512) :: errmsg - integer :: errflg - - id_so4 = -1 - id_h2so4 = -1 - - call phys_getopts( prog_modal_aero_out=modal_aerosols ) - cloud_borne = modal_aerosols .or. carma_do_cloudborne - - !----------------------------------------------------------------- - ! ... get species indicies - !----------------------------------------------------------------- - - if (cloud_borne) then - id_h2so4 = get_spc_ndx( 'H2SO4' ) - else - id_so4 = get_spc_ndx( 'SO4' ) - endif - id_msa = get_spc_ndx( 'MSA' ) - - inv_so2 = .false. - id_so2 = get_inv_ndx( 'SO2' ) - inv_so2 = id_so2 > 0 - if ( .not. inv_so2 ) then - id_so2 = get_spc_ndx( 'SO2' ) - endif - - inv_NH3 = .false. - id_NH3 = get_inv_ndx( 'NH3' ) - inv_NH3 = id_NH3 > 0 - if ( .not. inv_NH3 ) then - id_NH3 = get_spc_ndx( 'NH3' ) - endif - - inv_HNO3 = .false. - id_HNO3 = get_inv_ndx( 'HNO3' ) - inv_HNO3 = id_hno3 > 0 - if ( .not. inv_HNO3 ) then - id_HNO3 = get_spc_ndx( 'HNO3' ) - endif - - inv_H2O2 = .false. - id_H2O2 = get_inv_ndx( 'H2O2' ) - inv_H2O2 = id_H2O2 > 0 - if ( .not. inv_H2O2 ) then - id_H2O2 = get_spc_ndx( 'H2O2' ) - endif - - inv_HO2 = .false. - id_HO2 = get_inv_ndx( 'HO2' ) - inv_HO2 = id_HO2 > 0 - if ( .not. inv_HO2 ) then - id_HO2 = get_spc_ndx( 'HO2' ) - endif - - inv_o3 = get_inv_ndx( 'O3' ) > 0 - if (inv_o3) then - id_o3 = get_inv_ndx( 'O3' ) - else - id_o3 = get_spc_ndx( 'O3' ) - endif - inv_ho2 = get_inv_ndx( 'HO2' ) > 0 - if (inv_ho2) then - id_ho2 = get_inv_ndx( 'HO2' ) - else - id_ho2 = get_spc_ndx( 'HO2' ) - endif - - has_sox = (id_so2>0) .and. (id_h2o2>0) .and. (id_o3>0) .and. (id_ho2>0) - if (cloud_borne) then - has_sox = has_sox .and. (id_h2so4>0) - else - has_sox = has_sox .and. (id_so4>0) .and. (id_nh3>0) - endif - - ! Lookup Effective Henry's Law Constant parameters from the common - ! data file read in the shared code. - heff_id_hno3 = get_heff_index( 'HNO3' ) - heff_id_so2 = get_heff_index( 'SO2' ) - heff_id_nh3 = get_heff_index( 'NH3' ) - heff_id_co2 = get_heff_index( 'CO2' ) - heff_id_h2o2 = get_heff_index( 'H2O2' ) - heff_id_o3 = get_heff_index( 'OX' ) - - has_sox = has_sox .and. (heff_id_hno3 > 0) .and. (heff_id_so2 > 0) & - .and. (heff_id_nh3 > 0) .and. (heff_id_co2 > 0) & - .and. (heff_id_h2o2 > 0) .and. (heff_id_o3 > 0) - - if (masterproc) then - write(iulog,*) 'sox_inti: has_sox = ',has_sox - endif - - if( has_sox ) then - if (masterproc) then - write(iulog,*) '-----------------------------------------' - write(iulog,*) ' mo_setsox will do sox aerosols' - write(iulog,*) '-----------------------------------------' - endif - else - if (masterproc) then - write(iulog,*) '-----------------------------------------' - write(iulog,*) ' mo_setsox will not do sox aerosols' - write(iulog,*) '-----------------------------------------' - endif - return - end if - - ! call the portable init subroutines: - call setsox_init( cloud_borne_in=cloud_borne, & - id_so2_in=id_so2, inv_so2_in=inv_so2, & - id_nh3_in=id_nh3, inv_nh3_in=inv_nh3, & - id_hno3_in=id_hno3, inv_hno3_in=inv_hno3, & - id_h2o2_in=id_h2o2, inv_h2o2_in=inv_h2o2, & - id_ho2_in=id_ho2, inv_ho2_in=inv_ho2, & - id_o3_in=id_o3, inv_o3_in=inv_o3, & - id_h2so4_in=id_h2so4, id_so4_in=id_so4, id_msa_in=id_msa, & - heff_id_hno3_in=heff_id_hno3, heff_id_so2_in=heff_id_so2, & - heff_id_nh3_in=heff_id_nh3, heff_id_co2_in=heff_id_co2, & - heff_id_h2o2_in=heff_id_h2o2, heff_id_o3_in=heff_id_o3 ) - - call sox_cldaero_init(aero_props, & - id_msa_in=id_msa, id_h2so4_in=id_h2so4, id_so2_in=id_so2, & - id_h2o2_in=id_h2o2, id_nh3_in=id_nh3, pi_in=pi, & - ! sulfur oxidation is performed internally to GEOS-Chem, so the aerosol - ! and gas updates are not applied here (avoids double counting) - do_aqueous_sulfur_chemistry_aerosol_update_in=.not. cam_chempkg_is('geoschem_mam4'), & - errmsg=errmsg, errflg=errflg) - if (errflg /= 0) then - call endrun(trim(errmsg)) - end if - - end subroutine sox_inti + subroutine sox_inti(aero_props) + !----------------------------------------------------------------------- + ! ... initialize the hetero sox routine + !----------------------------------------------------------------------- + + use mo_chem_utls, only : get_spc_ndx, get_inv_ndx + use spmd_utils, only : masterproc + use phys_control, only : phys_getopts, cam_chempkg_is + use carma_flags_mod, only : carma_do_cloudborne + use mo_setsox, only : setsox_init + use sox_cldaero_mod, only : sox_cldaero_init + use aerosol_properties_mod, only : aerosol_properties + use mo_constants, only : pi + use cam_abortutils, only : endrun + + class(aerosol_properties), target, intent(in) :: aero_props + + logical :: modal_aerosols + + logical :: cloud_borne + integer :: id_msa + integer :: id_so2, id_nh3, id_hno3, id_h2o2, id_o3, id_ho2 + integer :: id_so4, id_h2so4 + logical :: inv_so2, inv_nh3, inv_hno3, inv_h2o2, inv_ho2, inv_o3 + + ! Indices for species in the shared array of Henry's Law constant parameters + integer :: heff_id_hno3, heff_id_so2, heff_id_nh3, heff_id_co2, heff_id_h2o2, heff_id_o3 + + character(len=512) :: errmsg + integer :: errflg + + id_so4 = -1 + id_h2so4 = -1 + + call phys_getopts( prog_modal_aero_out=modal_aerosols ) + cloud_borne = modal_aerosols .or. carma_do_cloudborne + + !----------------------------------------------------------------- + ! ... get species indicies + !----------------------------------------------------------------- + + if (cloud_borne) then + id_h2so4 = get_spc_ndx( 'H2SO4' ) + else + id_so4 = get_spc_ndx( 'SO4' ) + endif + id_msa = get_spc_ndx( 'MSA' ) + + inv_so2 = .false. + id_so2 = get_inv_ndx( 'SO2' ) + inv_so2 = id_so2 > 0 + if ( .not. inv_so2 ) then + id_so2 = get_spc_ndx( 'SO2' ) + endif + + inv_NH3 = .false. + id_NH3 = get_inv_ndx( 'NH3' ) + inv_NH3 = id_NH3 > 0 + if ( .not. inv_NH3 ) then + id_NH3 = get_spc_ndx( 'NH3' ) + endif + + inv_HNO3 = .false. + id_HNO3 = get_inv_ndx( 'HNO3' ) + inv_HNO3 = id_hno3 > 0 + if ( .not. inv_HNO3 ) then + id_HNO3 = get_spc_ndx( 'HNO3' ) + endif + + inv_H2O2 = .false. + id_H2O2 = get_inv_ndx( 'H2O2' ) + inv_H2O2 = id_H2O2 > 0 + if ( .not. inv_H2O2 ) then + id_H2O2 = get_spc_ndx( 'H2O2' ) + endif + + inv_HO2 = .false. + id_HO2 = get_inv_ndx( 'HO2' ) + inv_HO2 = id_HO2 > 0 + if ( .not. inv_HO2 ) then + id_HO2 = get_spc_ndx( 'HO2' ) + endif + + inv_o3 = get_inv_ndx( 'O3' ) > 0 + if (inv_o3) then + id_o3 = get_inv_ndx( 'O3' ) + else + id_o3 = get_spc_ndx( 'O3' ) + endif + inv_ho2 = get_inv_ndx( 'HO2' ) > 0 + if (inv_ho2) then + id_ho2 = get_inv_ndx( 'HO2' ) + else + id_ho2 = get_spc_ndx( 'HO2' ) + endif + + has_sox = (id_so2>0) .and. (id_h2o2>0) .and. (id_o3>0) .and. (id_ho2>0) + if (cloud_borne) then + has_sox = has_sox .and. (id_h2so4>0) + else + has_sox = has_sox .and. (id_so4>0) .and. (id_nh3>0) + endif + + ! Lookup Effective Henry's Law Constant parameters from the common + ! data file read in the shared code. + heff_id_hno3 = get_heff_index( 'HNO3' ) + heff_id_so2 = get_heff_index( 'SO2' ) + heff_id_nh3 = get_heff_index( 'NH3' ) + heff_id_co2 = get_heff_index( 'CO2' ) + heff_id_h2o2 = get_heff_index( 'H2O2' ) + heff_id_o3 = get_heff_index( 'OX' ) + + has_sox = has_sox .and. (heff_id_hno3 > 0) .and. (heff_id_so2 > 0) & + .and. (heff_id_nh3 > 0) .and. (heff_id_co2 > 0) & + .and. (heff_id_h2o2 > 0) .and. (heff_id_o3 > 0) + + if (masterproc) then + write(iulog,*) 'sox_inti: has_sox = ',has_sox + endif + + if( has_sox ) then + if (masterproc) then + write(iulog,*) '-----------------------------------------' + write(iulog,*) ' mo_setsox will do sox aerosols' + write(iulog,*) '-----------------------------------------' + endif + else + if (masterproc) then + write(iulog,*) '-----------------------------------------' + write(iulog,*) ' mo_setsox will not do sox aerosols' + write(iulog,*) '-----------------------------------------' + endif + return + end if + + ! call the portable init subroutines: + call setsox_init( cloud_borne_in=cloud_borne, & + id_so2_in=id_so2, inv_so2_in=inv_so2, & + id_nh3_in=id_nh3, inv_nh3_in=inv_nh3, & + id_hno3_in=id_hno3, inv_hno3_in=inv_hno3, & + id_h2o2_in=id_h2o2, inv_h2o2_in=inv_h2o2, & + id_ho2_in=id_ho2, inv_ho2_in=inv_ho2, & + id_o3_in=id_o3, inv_o3_in=inv_o3, & + id_h2so4_in=id_h2so4, id_so4_in=id_so4, id_msa_in=id_msa, & + heff_id_hno3_in=heff_id_hno3, heff_id_so2_in=heff_id_so2, & + heff_id_nh3_in=heff_id_nh3, heff_id_co2_in=heff_id_co2, & + heff_id_h2o2_in=heff_id_h2o2, heff_id_o3_in=heff_id_o3 ) + + call sox_cldaero_init(aero_props, & + id_msa_in=id_msa, id_h2so4_in=id_h2so4, id_so2_in=id_so2, & + id_h2o2_in=id_h2o2, id_nh3_in=id_nh3, pi_in=pi, & + ! sulfur oxidation is performed internally to GEOS-Chem, so the aerosol + ! and gas updates are not applied here (avoids double counting) + do_aqueous_sulfur_chemistry_aerosol_update_in=.not. cam_chempkg_is('geoschem_mam4'), & + errmsg=errmsg, errflg=errflg) + if (errflg /= 0) then + call endrun(trim(errmsg)) + end if + + end subroutine sox_inti !----------------------------------------------------------------------- !----------------------------------------------------------------------- - subroutine setsox( aero_state, state, & - pbuf, & - ncol, & - dtime, & - press, & - pdel, & - tfld, & - mbar, & - lwc, & - cldfrc, & - cldnum, & - invariants, & - qcw, & - qin, & - xphlwc, & - aqso4, & - aqh2so4,& - aqso4_h2o2, & - aqso4_o3, & - yph_in, & - aqso4_h2o2_3d, & - aqso4_o3_3d & - ) - - use physconst, only : avogad, boltz, r_universal, mwco2, mwdry, gravit - use ppgrid, only : pver - use shr_drydep_mod, only : dheff - use physics_buffer, only : physics_buffer_desc - use rad_constituents, only : rad_cnst_get_gas - use mo_setsox, only : setsox_sub - use cam_abortutils, only : endrun - - !----------------------------------------------------------------------- - ! ... Dummy arguments - !----------------------------------------------------------------------- - class(aerosol_state), intent(in) :: aero_state - type(physics_state), intent(in) :: state ! Physics state variables - type(physics_buffer_desc), pointer, intent(inout) :: pbuf(:) ! Physics buffer - integer, intent(in) :: ncol ! num of columns in chunk - real(r8), intent(in) :: dtime ! time step (sec) - real(r8), intent(in) :: press(:,:) ! midpoint pressure ( Pa ) - real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: tfld(:,:) ! temperature - real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) - real(r8), target, intent(in) :: lwc(:,:) ! cloud liquid water content (kg/kg) - real(r8), target, intent(in) :: cldfrc(:,:) ! cloud fraction - real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) - real(r8), intent(in) :: invariants(:,:,:) - real(r8), target, intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) - real(r8), intent(inout) :: qin(:,:,:) ! transported species ( vmr ) - real(r8), intent(out) :: xphlwc(:,:) ! pH value multiplied by lwc - - real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) - real(r8), intent(in), optional :: yph_in ! ph value - real(r8), intent(out), optional :: aqso4_h2o2_3d(:, :) ! 3D SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out), optional :: aqso4_o3_3d(:, :) ! 3D SO4 aqueous phase chemistry due to O3 (kg/m2) - - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - real(r8), pointer :: co2_mass_mixing_ratio(:,:) ! kg kg-1 - - character(len=512) :: errmsg - integer :: errflg - - call rad_cnst_get_gas(0, 'CO2', state, pbuf, co2_mass_mixing_ratio) - - ! call the portable subroutine: - call setsox_sub( - aero_state = aero_state, & + subroutine setsox( aero_state, state, & + pbuf, & + ncol, & + dtime, & + press, & + pdel, & + tfld, & + mbar, & + lwc, & + cldfrc, & + cldnum, & + invariants, & + qcw, & + qin, & + xphlwc, & + aqso4, & + aqh2so4,& + aqso4_h2o2, & + aqso4_o3, & + yph_in, & + aqso4_h2o2_3d, & + aqso4_o3_3d & + ) + + use physconst, only : avogad, boltz, r_universal, mwco2, mwdry, gravit + use ppgrid, only : pver + use shr_drydep_mod, only : dheff + use physics_buffer, only : physics_buffer_desc + use rad_constituents, only : rad_cnst_get_gas + use mo_setsox, only : setsox_sub + use cam_abortutils, only : endrun + + !----------------------------------------------------------------------- + ! ... Dummy arguments + !----------------------------------------------------------------------- + class(aerosol_state), intent(in) :: aero_state + type(physics_state), intent(in) :: state ! Physics state variables + type(physics_buffer_desc), pointer, intent(inout) :: pbuf(:) ! Physics buffer + integer, intent(in) :: ncol ! num of columns in chunk + real(r8), intent(in) :: dtime ! time step (sec) + real(r8), intent(in) :: press(:,:) ! midpoint pressure ( Pa ) + real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) + real(r8), intent(in) :: tfld(:,:) ! temperature + real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) + real(r8), target, intent(in) :: lwc(:,:) ! cloud liquid water content (kg/kg) + real(r8), target, intent(in) :: cldfrc(:,:) ! cloud fraction + real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) + real(r8), intent(in) :: invariants(:,:,:) + real(r8), target, intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) + real(r8), intent(inout) :: qin(:,:,:) ! transported species ( vmr ) + real(r8), intent(out) :: xphlwc(:,:) ! pH value multiplied by lwc + + real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry + real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry + real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) + real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) + real(r8), intent(in), optional :: yph_in ! ph value + real(r8), intent(out), optional :: aqso4_h2o2_3d(:, :) ! 3D SO4 aqueous phase chemistry due to H2O2 (kg/m2) + real(r8), intent(out), optional :: aqso4_o3_3d(:, :) ! 3D SO4 aqueous phase chemistry due to O3 (kg/m2) + + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + real(r8), pointer :: co2_mass_mixing_ratio(:,:) ! kg kg-1 + + character(len=512) :: errmsg + integer :: errflg + + call rad_cnst_get_gas(0, 'CO2', state, pbuf, co2_mass_mixing_ratio) + + ! call the portable subroutine: + call setsox_sub( + aero_state = aero_state, & ncol = ncol, & pver = pver, & dtime = dtime, & @@ -285,11 +285,11 @@ subroutine setsox( aero_state, state, & aqso4_h2o2_3d = aqso4_h2o2_3d, & aqso4_o3_3d = aqso4_o3_3d ) - if (errflg /= 0) then - call endrun(trim(errmsg)) - end if + if (errflg /= 0) then + call endrun(trim(errmsg)) + end if - end subroutine setsox + end subroutine setsox !----------------------------------------------------------------- ! ... looks up Effective Henry's Law Constant parameters diff --git a/src/chemistry/aerosol/wetdep_cam.F90 b/src/chemistry/aerosol/wetdep_cam.F90 index 1eccd74bee..1512692721 100644 --- a/src/chemistry/aerosol/wetdep_cam.F90 +++ b/src/chemistry/aerosol/wetdep_cam.F90 @@ -8,158 +8,158 @@ module wetdep_cam ! !----------------------------------------------------------------------- -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pcols, pver -use physconst, only: gravit, rair, tmelt -use phys_control, only: cam_physpkg_is - -use wetdep, only: clddiag - -implicit none -private - -public :: wetdepg ! scavenging of gas phase constituents by henry's law -public :: wetdep_inputs_t -public :: wetdep_init -public :: wetdep_inputs_set - -real(r8), parameter :: cmftau = 3600._r8 -real(r8), parameter :: rhoh2o = 1000._r8 ! density of water -real(r8), parameter :: molwta = 28.97_r8 ! molecular weight dry air gm/mole -real(r8), parameter :: omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - -type wetdep_inputs_t - real(r8), pointer :: cldt(:,:) => null() ! cloud fraction - real(r8), pointer :: prain(:,:) => null() - real(r8), pointer :: bergso(:,:) => null() - real(r8), pointer :: evapr(:,:) => null() - real(r8) :: cldcu(pcols,pver) ! convective cloud fraction, currently empty - real(r8) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation - real(r8) :: cmfdqr(pcols,pver) ! convective production of rain - real(r8) :: conicw(pcols,pver) ! convective in-cloud water - real(r8) :: totcond(pcols, pver) ! total condensate - real(r8) :: cldv(pcols,pver) ! cloudy volume undergoing wet chem and scavenging - real(r8) :: cldvcu(pcols,pver) ! Convective precipitation area at the top interface of current layer - real(r8) :: cldvst(pcols,pver) ! Stratiform precipitation area at the top interface of current layer -end type wetdep_inputs_t - -integer :: cld_idx = 0 -integer :: prain_idx = 0 -integer :: bergso_idx = 0 -integer :: nevapr_idx = 0 - -integer :: icwmrdp_idx = 0 -integer :: icwmrsh_idx = 0 -integer :: rprddp_idx = 0 -integer :: rprdsh_idx = 0 -integer :: sh_frac_idx = 0 -integer :: dp_frac_idx = 0 -integer :: nevapr_shcu_idx = 0 -integer :: nevapr_dpcu_idx = 0 -integer :: ixcldice, ixcldliq + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols, pver + use physconst, only: gravit, rair, tmelt + use phys_control, only: cam_physpkg_is + + use wetdep, only: clddiag + + implicit none + private + + public :: wetdepg ! scavenging of gas phase constituents by henry's law + public :: wetdep_inputs_t + public :: wetdep_init + public :: wetdep_inputs_set + + real(r8), parameter :: cmftau = 3600._r8 + real(r8), parameter :: rhoh2o = 1000._r8 ! density of water + real(r8), parameter :: molwta = 28.97_r8 ! molecular weight dry air gm/mole + real(r8), parameter :: omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero + + type wetdep_inputs_t + real(r8), pointer :: cldt(:,:) => null() ! cloud fraction + real(r8), pointer :: prain(:,:) => null() + real(r8), pointer :: bergso(:,:) => null() + real(r8), pointer :: evapr(:,:) => null() + real(r8) :: cldcu(pcols,pver) ! convective cloud fraction, currently empty + real(r8) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation + real(r8) :: cmfdqr(pcols,pver) ! convective production of rain + real(r8) :: conicw(pcols,pver) ! convective in-cloud water + real(r8) :: totcond(pcols, pver) ! total condensate + real(r8) :: cldv(pcols,pver) ! cloudy volume undergoing wet chem and scavenging + real(r8) :: cldvcu(pcols,pver) ! Convective precipitation area at the top interface of current layer + real(r8) :: cldvst(pcols,pver) ! Stratiform precipitation area at the top interface of current layer + end type wetdep_inputs_t + + integer :: cld_idx = 0 + integer :: prain_idx = 0 + integer :: bergso_idx = 0 + integer :: nevapr_idx = 0 + + integer :: icwmrdp_idx = 0 + integer :: icwmrsh_idx = 0 + integer :: rprddp_idx = 0 + integer :: rprdsh_idx = 0 + integer :: sh_frac_idx = 0 + integer :: dp_frac_idx = 0 + integer :: nevapr_shcu_idx = 0 + integer :: nevapr_dpcu_idx = 0 + integer :: ixcldice, ixcldliq contains -subroutine wetdep_init() - use physics_buffer, only: pbuf_get_index - use constituents, only: cnst_get_ind + subroutine wetdep_init() + use physics_buffer, only: pbuf_get_index + use constituents, only: cnst_get_ind - integer :: ierr + integer :: ierr - cld_idx = pbuf_get_index('CLD') - prain_idx = pbuf_get_index('PRAIN') - bergso_idx = pbuf_get_index('BERGSO', errcode=ierr ) - nevapr_idx = pbuf_get_index('NEVAPR') + cld_idx = pbuf_get_index('CLD') + prain_idx = pbuf_get_index('PRAIN') + bergso_idx = pbuf_get_index('BERGSO', errcode=ierr ) + nevapr_idx = pbuf_get_index('NEVAPR') - icwmrdp_idx = pbuf_get_index('ICWMRDP') - rprddp_idx = pbuf_get_index('RPRDDP') - icwmrsh_idx = pbuf_get_index('ICWMRSH') - rprdsh_idx = pbuf_get_index('RPRDSH') - sh_frac_idx = pbuf_get_index('SH_FRAC' ) - dp_frac_idx = pbuf_get_index('DP_FRAC') - nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') - nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') + icwmrdp_idx = pbuf_get_index('ICWMRDP') + rprddp_idx = pbuf_get_index('RPRDDP') + icwmrsh_idx = pbuf_get_index('ICWMRSH') + rprdsh_idx = pbuf_get_index('RPRDSH') + sh_frac_idx = pbuf_get_index('SH_FRAC' ) + dp_frac_idx = pbuf_get_index('DP_FRAC') + nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') + nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') - call cnst_get_ind('CLDICE', ixcldice) - call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('CLDLIQ', ixcldliq) -end subroutine wetdep_init + end subroutine wetdep_init !============================================================================== ! gathers up the inputs needed for the wetdepa routines !============================================================================== -subroutine wetdep_inputs_set( state, pbuf, inputs ) - use physics_types, only: physics_state - use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx - - ! args - - type(physics_state), intent(in ) :: state !! physics state - type(physics_buffer_desc), pointer :: pbuf(:) !! physics buffer - type(wetdep_inputs_t), intent(out) :: inputs !! collection of wetdepa inputs - - ! local vars - - real(r8), pointer :: icwmrdp(:,:) ! in cloud water mixing ratio, deep convection - real(r8), pointer :: rprddp(:,:) ! rain production, deep convection - real(r8), pointer :: icwmrsh(:,:) ! in cloud water mixing ratio, deep convection - real(r8), pointer :: rprdsh(:,:) ! rain production, deep convection - real(r8), pointer :: sh_frac(:,:) ! Shallow convective cloud fraction - real(r8), pointer :: dp_frac(:,:) ! Deep convective cloud fraction - real(r8), pointer :: evapcsh(:,:) ! Evaporation rate of shallow convective precipitation >=0. - real(r8), pointer :: evapcdp(:,:) ! Evaporation rate of deep convective precipitation >=0. - - real(r8) :: rainmr(pcols,pver) ! mixing ratio of rain within cloud volume - real(r8) :: cldst(pcols,pver) ! Stratiform cloud fraction - - integer :: itim, ncol - - ncol = state%ncol - itim = pbuf_old_tim_idx() - - call pbuf_get_field(pbuf, cld_idx, inputs%cldt, start=(/1,1,itim/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, prain_idx, inputs%prain ) - call pbuf_get_field(pbuf, nevapr_idx, inputs%evapr ) - call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp ) - call pbuf_get_field(pbuf, icwmrsh_idx, icwmrsh ) - call pbuf_get_field(pbuf, rprddp_idx, rprddp ) - call pbuf_get_field(pbuf, rprdsh_idx, rprdsh ) - call pbuf_get_field(pbuf, sh_frac_idx, sh_frac ) - call pbuf_get_field(pbuf, dp_frac_idx, dp_frac ) - call pbuf_get_field(pbuf, nevapr_shcu_idx, evapcsh ) - call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) - - if (bergso_idx>0) then - call pbuf_get_field(pbuf, bergso_idx, inputs%bergso ) - else - if (.not. associated(inputs%bergso)) then - allocate(inputs%bergso(pcols,pver)) - inputs%bergso(:,:) = 0.0_r8 - endif - endif - - inputs%cldcu(:ncol,:) = dp_frac(:ncol,:) + sh_frac(:ncol,:) - cldst(:ncol,:) = inputs%cldt(:ncol,:) - inputs%cldcu(:ncol,:) ! Stratiform cloud fraction - inputs%evapc(:ncol,:) = evapcsh(:ncol,:) + evapcdp(:ncol,:) - inputs%cmfdqr(:ncol,:) = rprddp(:ncol,:) + rprdsh(:ncol,:) - - ! sum deep and shallow convection contributions - if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then - ! Dec.29.2009. Sungsu - inputs%conicw(:ncol,:) = (icwmrdp(:ncol,:)*dp_frac(:ncol,:) + icwmrsh(:ncol,:)*sh_frac(:ncol,:))/ & - max(0.01_r8, sh_frac(:ncol,:) + dp_frac(:ncol,:)) - else - inputs%conicw(:ncol,:) = icwmrdp(:ncol,:) + icwmrsh(:ncol,:) - end if - - inputs%totcond(:ncol,:) = state%q(:ncol,:,ixcldliq) + state%q(:ncol,:,ixcldice) - - call clddiag( state%t, state%pmid, state%pdel, inputs%cmfdqr, inputs%evapc, & - inputs%cldt, inputs%cldcu, cldst, inputs%evapr, & - inputs%prain, inputs%cldv, inputs%cldvcu, inputs%cldvst, rainmr, & - state%ncol, pver, gravit, tmelt, rair ) - -end subroutine wetdep_inputs_set + subroutine wetdep_inputs_set( state, pbuf, inputs ) + use physics_types, only: physics_state + use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx + + ! args + + type(physics_state), intent(in ) :: state !! physics state + type(physics_buffer_desc), pointer :: pbuf(:) !! physics buffer + type(wetdep_inputs_t), intent(out) :: inputs !! collection of wetdepa inputs + + ! local vars + + real(r8), pointer :: icwmrdp(:,:) ! in cloud water mixing ratio, deep convection + real(r8), pointer :: rprddp(:,:) ! rain production, deep convection + real(r8), pointer :: icwmrsh(:,:) ! in cloud water mixing ratio, deep convection + real(r8), pointer :: rprdsh(:,:) ! rain production, deep convection + real(r8), pointer :: sh_frac(:,:) ! Shallow convective cloud fraction + real(r8), pointer :: dp_frac(:,:) ! Deep convective cloud fraction + real(r8), pointer :: evapcsh(:,:) ! Evaporation rate of shallow convective precipitation >=0. + real(r8), pointer :: evapcdp(:,:) ! Evaporation rate of deep convective precipitation >=0. + + real(r8) :: rainmr(pcols,pver) ! mixing ratio of rain within cloud volume + real(r8) :: cldst(pcols,pver) ! Stratiform cloud fraction + + integer :: itim, ncol + + ncol = state%ncol + itim = pbuf_old_tim_idx() + + call pbuf_get_field(pbuf, cld_idx, inputs%cldt, start=(/1,1,itim/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, prain_idx, inputs%prain ) + call pbuf_get_field(pbuf, nevapr_idx, inputs%evapr ) + call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp ) + call pbuf_get_field(pbuf, icwmrsh_idx, icwmrsh ) + call pbuf_get_field(pbuf, rprddp_idx, rprddp ) + call pbuf_get_field(pbuf, rprdsh_idx, rprdsh ) + call pbuf_get_field(pbuf, sh_frac_idx, sh_frac ) + call pbuf_get_field(pbuf, dp_frac_idx, dp_frac ) + call pbuf_get_field(pbuf, nevapr_shcu_idx, evapcsh ) + call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) + + if (bergso_idx>0) then + call pbuf_get_field(pbuf, bergso_idx, inputs%bergso ) + else + if (.not. associated(inputs%bergso)) then + allocate(inputs%bergso(pcols,pver)) + inputs%bergso(:,:) = 0.0_r8 + endif + endif + + inputs%cldcu(:ncol,:) = dp_frac(:ncol,:) + sh_frac(:ncol,:) + cldst(:ncol,:) = inputs%cldt(:ncol,:) - inputs%cldcu(:ncol,:) ! Stratiform cloud fraction + inputs%evapc(:ncol,:) = evapcsh(:ncol,:) + evapcdp(:ncol,:) + inputs%cmfdqr(:ncol,:) = rprddp(:ncol,:) + rprdsh(:ncol,:) + + ! sum deep and shallow convection contributions + if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then + ! Dec.29.2009. Sungsu + inputs%conicw(:ncol,:) = (icwmrdp(:ncol,:)*dp_frac(:ncol,:) + icwmrsh(:ncol,:)*sh_frac(:ncol,:))/ & + max(0.01_r8, sh_frac(:ncol,:) + dp_frac(:ncol,:)) + else + inputs%conicw(:ncol,:) = icwmrdp(:ncol,:) + icwmrsh(:ncol,:) + end if + + inputs%totcond(:ncol,:) = state%q(:ncol,:,ixcldliq) + state%q(:ncol,:,ixcldice) + + call clddiag( state%t, state%pmid, state%pdel, inputs%cmfdqr, inputs%evapc, & + inputs%cldt, inputs%cldcu, cldst, inputs%evapr, & + inputs%prain, inputs%cldv, inputs%cldvcu, inputs%cldvst, rainmr, & + state%ncol, pver, gravit, tmelt, rair ) + + end subroutine wetdep_inputs_set !============================================================================== @@ -167,10 +167,10 @@ end subroutine wetdep_inputs_set ! cam_physpkg_is method. subroutine wetdepg( t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, precs, evaps, & - rain, cwat, tracer, deltat, molwt, & - solconst, scavt, iscavt, cldv, icwmr1, & - icwmr2, fracis, ncol ) + cldt, cldc, cmfdqr, evapc, precs, evaps, & + rain, cwat, tracer, deltat, molwt, & + solconst, scavt, iscavt, cldv, icwmr1, & + icwmr2, fracis, ncol ) !----------------------------------------------------------------------- ! Purpose: @@ -191,9 +191,9 @@ subroutine wetdepg( t, p, q, pdel, & cwat(pcols,pver), &! cloud water amount precs(pcols,pver), &! rate of production of stratiform precip evaps(pcols,pver), &! rate of evaporation of precip -! Sungsu + ! Sungsu evapc(pcols,pver), &! Rate of evaporation of convective precipitation -! Sungsu + ! Sungsu cldv(pcols,pver), &! estimate of local volume occupied by clouds icwmr1 (pcols,pver), &! in cloud water mixing ration for zhang scheme icwmr2 (pcols,pver), &! in cloud water mixing ration for hack scheme @@ -229,7 +229,7 @@ subroutine wetdepg( t, p, q, pdel, & real(r8) fracp ! fraction of cloud water converted to precip real(r8) gafrac ! fraction of tracer in gas phasea real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios + ! in terms of mixing ratios real(r8) mpla ! moles / liter H2O entering the layer from above real(r8) mplb ! moles / liter H2O leaving the layer below real(r8) part ! partial pressure of tracer in atmospheres @@ -312,7 +312,6 @@ subroutine wetdepg( t, p, q, pdel, & gafrac = 1/(1._r8+hconst) fracis(i,k) = gafrac - ! partial pressure of the tracer in the gridbox in atmospheres part = patm*gafrac*tracer(i,k)*molwta/molwt @@ -321,7 +320,6 @@ subroutine wetdepg( t, p, q, pdel, & ! then convert to kg tracer /liter of water (kg tracer / kg water) mplb = solconst(i,k)*part*molwt/1000._r8 - pdog = pdel(i,k)/gravit ! this part of precip will be carried downward but at a new molarity of mpl @@ -386,8 +384,6 @@ subroutine wetdepg( t, p, q, pdel, & scavab(i) = scavbl precab(i) = max(precxx + precic,1.e-36_r8) - - end do end do diff --git a/src/chemistry/modal_aero/modal_aero_coag_cam.F90 b/src/chemistry/modal_aero/modal_aero_coag_cam.F90 index 77ea90f839..3978a6f2a9 100644 --- a/src/chemistry/modal_aero/modal_aero_coag_cam.F90 +++ b/src/chemistry/modal_aero/modal_aero_coag_cam.F90 @@ -5,17 +5,17 @@ ! registers history fields, and calls portable subroutines !---------------------------------------------------------------------- module modal_aero_coag_cam - use shr_kind_mod, only: r8 => shr_kind_r8 + use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - private + implicit none + private - public :: modal_aero_coag_cam_init + public :: modal_aero_coag_cam_init #if ( defined MODAL_AERO_7MODE || defined MODAL_AERO_4MODE || defined MODAL_AERO_5MODE) - integer, parameter :: pair_option_acoag = 3 + integer, parameter :: pair_option_acoag = 3 #elif ( defined MODAL_AERO_3MODE ) - integer, parameter :: pair_option_acoag = 1 + integer, parameter :: pair_option_acoag = 1 #endif ! specifies pairs of modes for which coagulation is calculated ! 1 -- [aitken-->accum] @@ -26,170 +26,169 @@ module modal_aero_coag_cam !---------------------------------------------------------------------- contains - subroutine modal_aero_coag_cam_init + subroutine modal_aero_coag_cam_init ! ! computes pointers for species transfer during coagulation ! and hands them to the portable modal_aero_coag_init ! - use modal_aero_coag, only: modal_aero_coag_init, maxpair_acoag - use modal_aero_data - use modal_aero_gasaerexch, only: & - modefrm_pcage, nspecfrm_pcage, lspecfrm_pcage, lspectoo_pcage, & - soa_equivso4_factor - - use cam_abortutils, only: endrun - use cam_history, only: addfld, add_default, fieldname_len, horiz_only - use constituents, only: pcnst, cnst_name - use physconst, only: r_universal, pstd, tmelt, boltz - use spmd_utils, only: masterproc - use phys_control, only: phys_getopts - use cam_logfile, only: iulog + use modal_aero_coag, only: modal_aero_coag_init, maxpair_acoag + use modal_aero_data + use modal_aero_gasaerexch, only: & + modefrm_pcage, nspecfrm_pcage, lspecfrm_pcage, lspectoo_pcage, & + soa_equivso4_factor + + use cam_abortutils, only: endrun + use cam_history, only: addfld, add_default, fieldname_len, horiz_only + use constituents, only: pcnst, cnst_name + use physconst, only: r_universal, pstd, tmelt, boltz + use spmd_utils, only: masterproc + use phys_control, only: phys_getopts + use cam_logfile, only: iulog ! local variables - integer :: ipair, iq, iqfrm, iqfrm_aa, iqtoo, iqtoo_aa - integer :: jsoa - integer :: l, l1, l2, lsfrm, lstoo - integer :: m, mait, mpca, mfrm, mtoo, mtef - integer :: nchfrm, nchfrmskip, nchtoo, nchtooskip, nspec + integer :: ipair, iq, iqfrm, iqfrm_aa, iqtoo, iqtoo_aa + integer :: jsoa + integer :: l, l1, l2, lsfrm, lstoo + integer :: m, mait, mpca, mfrm, mtoo, mtef + integer :: nchfrm, nchfrmskip, nchtoo, nchtooskip, nspec ! resolved coagulation-pair tables (host constituent-index space) - integer :: maxspec_acoag - integer :: npair_acoag - integer :: modefrm_acoag(maxpair_acoag) - integer :: modetoo_acoag(maxpair_acoag) - integer :: modetooeff_acoag(maxpair_acoag) - integer :: nspecfrm_acoag(maxpair_acoag) - integer, allocatable :: lspecfrm_acoag(:,:) - integer, allocatable :: lspectoo_acoag(:,:) - integer :: ip_aitacc, ip_aitpca, ip_pcaacc - real(r8), allocatable :: fac_m2v_aitage(:), fac_m2v_pcarbon(:) + integer :: maxspec_acoag + integer :: npair_acoag + integer :: modefrm_acoag(maxpair_acoag) + integer :: modetoo_acoag(maxpair_acoag) + integer :: modetooeff_acoag(maxpair_acoag) + integer :: nspecfrm_acoag(maxpair_acoag) + integer, allocatable :: lspecfrm_acoag(:,:) + integer, allocatable :: lspectoo_acoag(:,:) + integer :: ip_aitacc, ip_aitpca, ip_pcaacc + real(r8), allocatable :: fac_m2v_aitage(:), fac_m2v_pcarbon(:) - character(len=fieldname_len) :: tmpname - character(len=fieldname_len+3) :: fieldname - character(128) :: long_name - character(8) :: unit + character(len=fieldname_len) :: tmpname + character(len=fieldname_len+3) :: fieldname + character(128) :: long_name + character(8) :: unit - logical :: dotend(pcnst) - logical :: history_aerosol ! Output the MAM aerosol tendencies + logical :: dotend(pcnst) + logical :: history_aerosol ! Output the MAM aerosol tendencies - character(len=200) :: msg + character(len=200) :: msg - character(len=512) :: errmsg - integer :: errflg + character(len=512) :: errmsg + integer :: errflg - call phys_getopts( history_aerosol_out = history_aerosol ) + call phys_getopts( history_aerosol_out = history_aerosol ) - maxspec_acoag = nspec_max - allocate( lspecfrm_acoag(maxspec_acoag,maxpair_acoag) ) - allocate( lspectoo_acoag(maxspec_acoag,maxpair_acoag) ) - allocate( fac_m2v_aitage(nspec_max), fac_m2v_pcarbon(nspec_max) ) + maxspec_acoag = nspec_max + allocate( lspecfrm_acoag(maxspec_acoag,maxpair_acoag) ) + allocate( lspectoo_acoag(maxspec_acoag,maxpair_acoag) ) + allocate( fac_m2v_aitage(nspec_max), fac_m2v_pcarbon(nspec_max) ) ! default-initialize the tables so the unused slots are well-defined when ! the whole arrays are handed to the portable modal_aero_coag_init - modefrm_acoag(:) = 0 - modetoo_acoag(:) = 0 - modetooeff_acoag(:) = 0 - nspecfrm_acoag(:) = 0 - lspecfrm_acoag(:,:) = 0 - lspectoo_acoag(:,:) = 0 + modefrm_acoag(:) = 0 + modetoo_acoag(:) = 0 + modetooeff_acoag(:) = 0 + nspecfrm_acoag(:) = 0 + lspecfrm_acoag(:,:) = 0 + lspectoo_acoag(:,:) = 0 ! ! define "from mode" and "to mode" for each coagulation pairing -! currently just a2-->a1 coagulation +! currently just a2-->a1 coagulation ! - if (pair_option_acoag == 1) then - npair_acoag = 1 - modefrm_acoag(1) = modeptr_aitken - modetoo_acoag(1) = modeptr_accum - modetooeff_acoag(1) = modeptr_accum - else if (pair_option_acoag == 2) then - npair_acoag = 2 - modefrm_acoag(1) = modeptr_aitken - modetoo_acoag(1) = modeptr_accum - modetooeff_acoag(1) = modeptr_accum - modefrm_acoag(2) = modeptr_pcarbon - modetoo_acoag(2) = modeptr_accum - modetooeff_acoag(2) = modeptr_accum - else if (pair_option_acoag == 3) then - npair_acoag = 3 - modefrm_acoag(1) = modeptr_aitken - modetoo_acoag(1) = modeptr_accum - modetooeff_acoag(1) = modeptr_accum - modefrm_acoag(2) = modeptr_pcarbon - modetoo_acoag(2) = modeptr_accum - modetooeff_acoag(2) = modeptr_accum - modefrm_acoag(3) = modeptr_aitken - 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 =', & - pair_option_acoag, modefrm_pcage - call endrun( 'modal_aero_coag_init error' ) - end if - else - npair_acoag = 0 - return - end if + if (pair_option_acoag == 1) then + npair_acoag = 1 + modefrm_acoag(1) = modeptr_aitken + modetoo_acoag(1) = modeptr_accum + modetooeff_acoag(1) = modeptr_accum + else if (pair_option_acoag == 2) then + npair_acoag = 2 + modefrm_acoag(1) = modeptr_aitken + modetoo_acoag(1) = modeptr_accum + modetooeff_acoag(1) = modeptr_accum + modefrm_acoag(2) = modeptr_pcarbon + modetoo_acoag(2) = modeptr_accum + modetooeff_acoag(2) = modeptr_accum + else if (pair_option_acoag == 3) then + npair_acoag = 3 + modefrm_acoag(1) = modeptr_aitken + modetoo_acoag(1) = modeptr_accum + modetooeff_acoag(1) = modeptr_accum + modefrm_acoag(2) = modeptr_pcarbon + modetoo_acoag(2) = modeptr_accum + modetooeff_acoag(2) = modeptr_accum + modefrm_acoag(3) = modeptr_aitken + 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 =', & + pair_option_acoag, modefrm_pcage + call endrun( 'modal_aero_coag_init error' ) + end if + else + npair_acoag = 0 + return + end if ! ! define species involved in each coagulation pairing -! (include aerosol water) +! (include aerosol water) ! -aa_ipair: do ipair = 1, npair_acoag - - mfrm = modefrm_acoag(ipair) - mtoo = modetoo_acoag(ipair) - mtef = modetooeff_acoag(ipair) - 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 - call endrun( 'modal_aero_coag_init error' ) - end if - - - mtoo = mtef ! effective modetoo - 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) - lsfrm = lmassptr_amode(iqfrm,mfrm) - if ((lsfrm .lt. 1) .or. (lsfrm .gt. pcnst)) cycle aa_iqfrm - nchfrm = len( trim( cnst_name(lsfrm) ) ) - nchfrmskip + aa_ipair: do ipair = 1, npair_acoag + + mfrm = modefrm_acoag(ipair) + mtoo = modetoo_acoag(ipair) + mtef = modetooeff_acoag(ipair) + 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 + call endrun( 'modal_aero_coag_init error' ) + end if + + mtoo = mtef ! effective modetoo + 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) + lsfrm = lmassptr_amode(iqfrm,mfrm) + if ((lsfrm .lt. 1) .or. (lsfrm .gt. pcnst)) cycle aa_iqfrm + nchfrm = len( trim( cnst_name(lsfrm) ) ) - nchfrmskip ! find "too" species having same lspectype_amode as the "frm" species ! AND same cnst_name (except for last 1/2/3 characters which are the mode index) - do iqtoo = 1, nspec_amode(mtoo) - lstoo = lmassptr_amode(iqtoo,mtoo) - nchtoo = len( trim( cnst_name(lstoo) ) ) - nchtooskip - if (cnst_name(lsfrm)(1:nchfrm) == cnst_name(lstoo)(1:nchtoo)) then - exit - else - lstoo = 0 - end if - end do - - if ((lstoo < 1) .or. (lstoo > pcnst)) lstoo = 0 - nspec = nspec + 1 - lspecfrm_acoag(nspec,ipair) = lsfrm - lspectoo_acoag(nspec,ipair) = lstoo - end do aa_iqfrm + do iqtoo = 1, nspec_amode(mtoo) + lstoo = lmassptr_amode(iqtoo,mtoo) + nchtoo = len( trim( cnst_name(lstoo) ) ) - nchtooskip + if (cnst_name(lsfrm)(1:nchfrm) == cnst_name(lstoo)(1:nchtoo)) then + exit + else + lstoo = 0 + end if + end do + + if ((lstoo < 1) .or. (lstoo > pcnst)) lstoo = 0 + nspec = nspec + 1 + lspecfrm_acoag(nspec,ipair) = lsfrm + lspectoo_acoag(nspec,ipair) = lstoo + end do aa_iqfrm ! lsfrm = lwaterptr_amode(mfrm) ! if ((lsfrm .ge. 1) .and. (lsfrm .le. pcnst)) then @@ -200,201 +199,201 @@ subroutine modal_aero_coag_cam_init ! lspectoo_acoag(nspec,ipair) = lstoo ! end if - nspecfrm_acoag(ipair) = nspec - end do aa_ipair + nspecfrm_acoag(ipair) = nspec + end do aa_ipair ! ! output results ! - if ( masterproc ) then - - write(iulog,9310) - - do ipair = 1, npair_acoag - mfrm = modefrm_acoag(ipair) - mtoo = modetoo_acoag(ipair) - mtef = modetooeff_acoag(ipair) - write(iulog,9320) ipair, mfrm, mtoo, mtef - - do iq = 1, nspecfrm_acoag(ipair) - lsfrm = lspecfrm_acoag(iq,ipair) - lstoo = lspectoo_acoag(iq,ipair) - if (lstoo .gt. 0) then - write(iulog,9330) lsfrm, cnst_name(lsfrm), & - lstoo, cnst_name(lstoo) - else - write(iulog,9340) lsfrm, cnst_name(lsfrm) - end if - end do - - end do ! ipair = ... - write(iulog,*) - - end if ! ( masterproc ) - -9310 format( / 'subr. modal_aero_coag_init' ) -9320 format( 'pair', i3, 5x, 'mode', i3, & - ' ---> mode', i3, ' eff', i3 ) -9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a ) -9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' ) + if ( masterproc ) then + + write(iulog,9310) + + do ipair = 1, npair_acoag + mfrm = modefrm_acoag(ipair) + mtoo = modetoo_acoag(ipair) + mtef = modetooeff_acoag(ipair) + write(iulog,9320) ipair, mfrm, mtoo, mtef + + do iq = 1, nspecfrm_acoag(ipair) + lsfrm = lspecfrm_acoag(iq,ipair) + lstoo = lspectoo_acoag(iq,ipair) + if (lstoo .gt. 0) then + write(iulog,9330) lsfrm, cnst_name(lsfrm), & + lstoo, cnst_name(lstoo) + else + write(iulog,9340) lsfrm, cnst_name(lsfrm) + end if + end do + + end do ! ipair = ... + write(iulog,*) + + end if ! ( masterproc ) + +9310 format( / 'subr. modal_aero_coag_init' ) +9320 format( 'pair', i3, 5x, 'mode', i3, & + ' ---> mode', i3, ' eff', i3 ) +9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a ) +9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' ) ! set following variables that are used in modal_aero_coag_subr ! - fac_m2v_aitage(:) = 0.0_r8 - fac_m2v_pcarbon(:) = 0.0_r8 - if (pair_option_acoag == 3) then + fac_m2v_aitage(:) = 0.0_r8 + fac_m2v_pcarbon(:) = 0.0_r8 + if (pair_option_acoag == 3) then ! following ipair definitions MUST BE CONSISTENT with ! the coding in modal_aero_coag_init for pair_option_acoag == 3 - ip_aitacc = 1 - ip_pcaacc = 2 - ip_aitpca = 3 - - mait = modeptr_aitken - mpca = modeptr_pcarbon - - ipair = ip_aitpca - do iq = 1, nspecfrm_acoag(ipair) - lsfrm = lspecfrm_acoag(iq,ipair) - l2 = -1 - do l1 = 1, nspec_amode(mait) - if (lmassptr_amode(l1,mait) == lsfrm) then - l2 = l1 - exit - end if - end do - if (l2 <= 0) then - write( msg, '(a,5(1x,i12))' ) & - 'modal_aero_coag_init error a001 for ipair, iq, lsfrm', & - ipair, iq, lsfrm - call endrun( msg ) - end if - if (lsfrm == lptr_so4_a_amode(mait)) then -! fac_m2v_aitage(iq) = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_aitage(iq) = specmw_amode(l1,mait) / specdens_amode(l1,mait) - else if (lsfrm == lptr_nh4_a_amode(mait)) then + ip_aitacc = 1 + ip_pcaacc = 2 + ip_aitpca = 3 + + mait = modeptr_aitken + mpca = modeptr_pcarbon + + ipair = ip_aitpca + do iq = 1, nspecfrm_acoag(ipair) + lsfrm = lspecfrm_acoag(iq,ipair) + l2 = -1 + do l1 = 1, nspec_amode(mait) + if (lmassptr_amode(l1,mait) == lsfrm) then + l2 = l1 + exit + end if + end do + if (l2 <= 0) then + write( msg, '(a,5(1x,i12))' ) & + 'modal_aero_coag_init error a001 for ipair, iq, lsfrm', & + ipair, iq, lsfrm + call endrun( msg ) + end if + if (lsfrm == lptr_so4_a_amode(mait)) then +! fac_m2v_aitage(iq) = specmw_amode(l2) / specdens_amode(l2) + fac_m2v_aitage(iq) = specmw_amode(l1,mait) / specdens_amode(l1,mait) + else if (lsfrm == lptr_nh4_a_amode(mait)) then ! fac_m2v_aitage(iq) = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_aitage(iq) = specmw_amode(l1,mait) / specdens_amode(l1,mait) - else - do jsoa = 1, nsoa - if (lsfrm == lptr2_soa_a_amode(mait,jsoa)) then - fac_m2v_aitage(iq) = soa_equivso4_factor(jsoa)* & - !(specmw_amode(l2) / specdens_amode(l2)) - (specmw_amode(l1,mait) / specdens_amode(l1,mait)) - end if + fac_m2v_aitage(iq) = specmw_amode(l1,mait) / specdens_amode(l1,mait) + else + do jsoa = 1, nsoa + if (lsfrm == lptr2_soa_a_amode(mait,jsoa)) then + fac_m2v_aitage(iq) = soa_equivso4_factor(jsoa)* & + !(specmw_amode(l2) / specdens_amode(l2)) + (specmw_amode(l1,mait) / specdens_amode(l1,mait)) + end if ! for soa, the soa_equivso4_factor converts the soa volume into an -! so4(+nh4) volume that has same hygroscopicity contribution as soa +! so4(+nh4) volume that has same hygroscopicity contribution as soa ! this allows aging calculations to be done in terms of the amount -! of (equivalent) so4(+nh4) in the shell +! of (equivalent) so4(+nh4) in the shell ! (see modal_aero_gasaerexch) - end do - end if - end do - - do l = 1, nspec_amode(mpca) -!B l2 = lspectype_amode(l,mpca) + end do + end if + end do + + do l = 1, nspec_amode(mpca) +!B l2 = lspectype_amode(l,mpca) ! fac_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air) -! [m3-AP/kmol-AP] = [kg-AP/kmol-AP] / [kg-AP/m3-AP] -! fac_m2v_pcarbon(l) = specmw_amode(l2) / specdens_amode(l2) - fac_m2v_pcarbon(l) = specmw_amode(l,mpca) / specdens_amode(l,mpca) - end do - - else - ip_aitacc = -999888777 - ip_pcaacc = -999888777 - ip_aitpca = -999888777 - end if - - ! call the portable subroutine: - call modal_aero_coag_init( & - pair_option_acoag_in = pair_option_acoag, & - npair_acoag_in = npair_acoag, & - modefrm_acoag_in = modefrm_acoag, & - modetoo_acoag_in = modetoo_acoag, & - modetooeff_acoag_in = modetooeff_acoag, & - nspecfrm_acoag_in = nspecfrm_acoag, & - lspecfrm_acoag_in = lspecfrm_acoag, & - lspectoo_acoag_in = lspectoo_acoag, & - ip_aitacc_in = ip_aitacc, & - ip_aitpca_in = ip_aitpca, & - ip_pcaacc_in = ip_pcaacc, & - fac_m2v_aitage_in = fac_m2v_aitage, & - fac_m2v_pcarbon_in = fac_m2v_pcarbon, & - nspec_max_in = nspec_max, & - ntot_amode_in = ntot_amode, & - modeptr_accum_in = modeptr_accum, & - modeptr_aitken_in = modeptr_aitken, & - modeptr_pcarbon_in = modeptr_pcarbon, & - numptr_amode_in = numptr_amode, & - mprognum_amode_in = mprognum_amode, & - nspec_amode_in = nspec_amode, & - lmassptr_amode_in = lmassptr_amode, & - alnsg_amode_in = alnsg_amode, & - sigmag_amode_in = sigmag_amode, & - r_universal_in = r_universal, & - pstd_in = pstd, & - tmelt_in = tmelt, & - boltz_in = boltz, & - errmsg = errmsg, & - errflg = errflg ) - - if (errflg /= 0) then - call endrun('modal_aero_coag_cam_init: '//trim(errmsg)) - end if +! [m3-AP/kmol-AP] = [kg-AP/kmol-AP] / [kg-AP/m3-AP] +! fac_m2v_pcarbon(l) = specmw_amode(l2) / specdens_amode(l2) + fac_m2v_pcarbon(l) = specmw_amode(l,mpca) / specdens_amode(l,mpca) + end do + + else + ip_aitacc = -999888777 + ip_pcaacc = -999888777 + ip_aitpca = -999888777 + end if + + ! call the portable subroutine: + call modal_aero_coag_init( & + pair_option_acoag_in = pair_option_acoag, & + npair_acoag_in = npair_acoag, & + modefrm_acoag_in = modefrm_acoag, & + modetoo_acoag_in = modetoo_acoag, & + modetooeff_acoag_in = modetooeff_acoag, & + nspecfrm_acoag_in = nspecfrm_acoag, & + lspecfrm_acoag_in = lspecfrm_acoag, & + lspectoo_acoag_in = lspectoo_acoag, & + ip_aitacc_in = ip_aitacc, & + ip_aitpca_in = ip_aitpca, & + ip_pcaacc_in = ip_pcaacc, & + fac_m2v_aitage_in = fac_m2v_aitage, & + fac_m2v_pcarbon_in = fac_m2v_pcarbon, & + nspec_max_in = nspec_max, & + ntot_amode_in = ntot_amode, & + modeptr_accum_in = modeptr_accum, & + modeptr_aitken_in = modeptr_aitken, & + modeptr_pcarbon_in = modeptr_pcarbon, & + numptr_amode_in = numptr_amode, & + mprognum_amode_in = mprognum_amode, & + nspec_amode_in = nspec_amode, & + lmassptr_amode_in = lmassptr_amode, & + alnsg_amode_in = alnsg_amode, & + sigmag_amode_in = sigmag_amode, & + r_universal_in = r_universal, & + pstd_in = pstd, & + tmelt_in = tmelt, & + boltz_in = boltz, & + errmsg = errmsg, & + errflg = errflg ) + + if (errflg /= 0) then + call endrun('modal_aero_coag_cam_init: '//trim(errmsg)) + end if ! ! create history file column-tendency fields ! - dotend(:) = .false. - do ipair = 1, npair_acoag - do iq = 1, nspecfrm_acoag(ipair) - l = lspecfrm_acoag(iq,ipair) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - l = lspectoo_acoag(iq,ipair) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end do - - m = modefrm_acoag(ipair) - if ((m > 0) .and. (m <= ntot_amode)) then - l = numptr_amode(m) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end if - m = modetoo_acoag(ipair) - if ((m > 0) .and. (m <= ntot_amode)) then - l = numptr_amode(m) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end if - end do ! ipair = ... - - if (pair_option_acoag == 3) then - do iq = 1, nspecfrm_pcage - lsfrm = lspecfrm_pcage(iq) - lstoo = lspectoo_pcage(iq) - if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then - dotend(lsfrm) = .true. - if ((lstoo > 0) .and. (lstoo <= pcnst)) then - dotend(lstoo) = .true. - end if - end if - end do - end if - - do l = 1, pcnst - if ( .not. dotend(l) ) cycle - tmpname = cnst_name(l) - unit = 'kg/m2/s' - do m = 1, ntot_amode - if (l == numptr_amode(m)) unit = '#/m2/s' - end do - fieldname = trim(tmpname) // '_sfcoag1' - long_name = trim(tmpname) // ' modal_aero coagulation column tendency' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,2x))') & - 'modal_aero_coag_init addfld', fieldname, unit - end do ! l = ... - - end subroutine modal_aero_coag_cam_init + dotend(:) = .false. + do ipair = 1, npair_acoag + do iq = 1, nspecfrm_acoag(ipair) + l = lspecfrm_acoag(iq,ipair) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + l = lspectoo_acoag(iq,ipair) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end do + + m = modefrm_acoag(ipair) + if ((m > 0) .and. (m <= ntot_amode)) then + l = numptr_amode(m) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end if + m = modetoo_acoag(ipair) + if ((m > 0) .and. (m <= ntot_amode)) then + l = numptr_amode(m) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end if + end do ! ipair = ... + + if (pair_option_acoag == 3) then + do iq = 1, nspecfrm_pcage + lsfrm = lspecfrm_pcage(iq) + lstoo = lspectoo_pcage(iq) + if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then + dotend(lsfrm) = .true. + if ((lstoo > 0) .and. (lstoo <= pcnst)) then + dotend(lstoo) = .true. + end if + end if + end do + end if + + do l = 1, pcnst + if ( .not. dotend(l) ) cycle + tmpname = cnst_name(l) + unit = 'kg/m2/s' + do m = 1, ntot_amode + if (l == numptr_amode(m)) unit = '#/m2/s' + end do + fieldname = trim(tmpname) // '_sfcoag1' + long_name = trim(tmpname) // ' modal_aero coagulation column tendency' + call addfld( fieldname, horiz_only, 'A', unit, long_name ) + if ( history_aerosol ) then + call add_default( fieldname, 1, ' ' ) + endif + if ( masterproc ) write(*,'(3(a,2x))') & + 'modal_aero_coag_init addfld', fieldname, unit + end do ! l = ... + + end subroutine modal_aero_coag_cam_init end module modal_aero_coag_cam diff --git a/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 b/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 index 8178f5f83b..46395a1c32 100644 --- a/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 +++ b/src/chemistry/modal_aero/modal_aero_gasaerexch_cam.F90 @@ -2,496 +2,496 @@ ! Resolves CAM-specific species indices (applying loffset) and mode metadata, ! calls the portable modal_aero_gasaerexch_init, and registers history fields. module modal_aero_gasaerexch_cam - use shr_kind_mod, only: r8 => shr_kind_r8 + use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - private + implicit none + private - public :: modal_aero_gasaerexch_cam_init + public :: modal_aero_gasaerexch_cam_init contains - ! Resolve species indices from CAM constituent arrays, - ! call portable modal_aero_gasaerexch_init, - ! and register history fields (addfld) for gas-aerosol exchange diagnostics. - subroutine modal_aero_gasaerexch_cam_init() - use modal_aero_gasaerexch, only: modal_aero_gasaerexch_init - use modal_aero_data, only: ntot_amode, nsoa, npoa, nspec_max, & - nspec_amode, modeptr_pcarbon, modeptr_accum, & - alnsg_amode, sigmag_amode, specmw_amode, specdens_amode, spechygro, & - lptr_so4_a_amode, lptr_nh4_a_amode, & - lptr2_soa_a_amode, lptr2_soa_g_amode, lptr2_pom_a_amode, & - numptr_amode, lmassptr_amode, cnst_name_cw - use modal_aero_rename_cam, only: npair_renamexf, nspecfrm_renamexf, & - lspecfrma_renamexf, lspectooa_renamexf, & - lspecfrmc_renamexf, lspectooc_renamexf - use radiative_aerosol, only: rad_aer_get_info - use constituents, only: pcnst, cnst_name, cnst_get_ind - use physconst, only: rair, mwdry, r_universal - use cam_history, only: addfld, add_default, fieldname_len, horiz_only - use cam_abortutils, only: endrun - use spmd_utils, only: masterproc - use phys_control, only: phys_getopts, cam_chempkg_is - use cam_logfile, only: iulog - - ! indices are in pcnst (q) space - ! run phase receives loffset for gas_pcnst (vmr) space - - ! local - integer :: ipair, iq, iqfrm, iqtoo - integer :: jac, jsoa, j - integer :: l, lsfrm, lstoo - integer :: mfrm, mtoo - integer :: n, nspec - integer :: nchfrm, nchfrmskip, nchtoo, nchtooskip - - logical :: dotend(pcnst), dotendqqcw(pcnst) - - character(len=fieldname_len) :: tmpnamea - character(len=fieldname_len + 3) :: fieldname - character(128) :: long_name - character(8) :: unit - - logical :: history_aerosol - - ! Resolved species indices (pcnst-space, for portable _init) - integer :: idx_h2so4, idx_nh3, idx_msa - integer :: idx_soag(nsoa) - integer :: idx_so4_a(ntot_amode), idx_nh4_a(ntot_amode) - integer :: idx_soa_a(ntot_amode, nsoa) - integer :: idx_pom_a(ntot_amode, npoa) - integer :: idx_num(ntot_amode) - integer :: idx_mass(nspec_max, ntot_amode) - - ! pcage resolved arrays (pcnst-space) - integer :: nspecfrm_pcage_resolved - integer :: lspecfrm_pcage_resolved(nspec_max) - integer :: lspectoo_pcage_resolved(nspec_max) - - ! SOA/POA molecular weights from host - real(r8) :: mw_soa_host_resolved(nsoa) - real(r8) :: mw_poa_host_resolved(npoa) - - character(len=32) :: spec_type - character(len=256) :: errmsg - integer :: errflg - - call phys_getopts(history_aerosol_out=history_aerosol) - - !----------------------------------------------------------------------- - ! Part A: Resolve arguments and call portable _init - !----------------------------------------------------------------------- - - ! --- Gas-phase species indices (pcnst-space) --- - call cnst_get_ind('H2SO4', idx_h2so4, .false.) - if ((idx_h2so4 <= 0) .or. (idx_h2so4 > pcnst)) then - write (*, '(/a/a,i7)') & - '*** modal_aero_gasaerexch_cam_init -- cannot find H2SO4 species', & - ' idx_h2so4=', idx_h2so4 - call endrun('modal_aero_gasaerexch_cam_init error: H2SO4 not found') - end if - - call cnst_get_ind('NH3', idx_nh3, .false.) - if (.not. ((idx_nh3 > 0) .and. (idx_nh3 <= pcnst))) idx_nh3 = 0 - - if (.not. cam_chempkg_is('geoschem_mam4')) then - call cnst_get_ind('MSA', idx_msa, .false.) - else - idx_msa = 0 - end if - if (.not. ((idx_msa > 0) .and. (idx_msa <= pcnst))) idx_msa = 0 - - ! --- SOA gas-phase species indices (pcnst-space) --- - do jsoa = 1, nsoa - l = lptr2_soa_g_amode(jsoa) - if ((l > 0) .and. (l <= pcnst)) then - idx_soag(jsoa) = l - else - idx_soag(jsoa) = 0 + ! Resolve species indices from CAM constituent arrays, + ! call portable modal_aero_gasaerexch_init, + ! and register history fields (addfld) for gas-aerosol exchange diagnostics. + subroutine modal_aero_gasaerexch_cam_init() + use modal_aero_gasaerexch, only: modal_aero_gasaerexch_init + use modal_aero_data, only: ntot_amode, nsoa, npoa, nspec_max, & + nspec_amode, modeptr_pcarbon, modeptr_accum, & + alnsg_amode, sigmag_amode, specmw_amode, specdens_amode, spechygro, & + lptr_so4_a_amode, lptr_nh4_a_amode, & + lptr2_soa_a_amode, lptr2_soa_g_amode, lptr2_pom_a_amode, & + numptr_amode, lmassptr_amode, cnst_name_cw + use modal_aero_rename_cam, only: npair_renamexf, nspecfrm_renamexf, & + lspecfrma_renamexf, lspectooa_renamexf, & + lspecfrmc_renamexf, lspectooc_renamexf + use radiative_aerosol, only: rad_aer_get_info + use constituents, only: pcnst, cnst_name, cnst_get_ind + use physconst, only: rair, mwdry, r_universal + use cam_history, only: addfld, add_default, fieldname_len, horiz_only + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc + use phys_control, only: phys_getopts, cam_chempkg_is + use cam_logfile, only: iulog + + ! indices are in pcnst (q) space + ! run phase receives loffset for gas_pcnst (vmr) space + + ! local + integer :: ipair, iq, iqfrm, iqtoo + integer :: jac, jsoa, j + integer :: l, lsfrm, lstoo + integer :: mfrm, mtoo + integer :: n, nspec + integer :: nchfrm, nchfrmskip, nchtoo, nchtooskip + + logical :: dotend(pcnst), dotendqqcw(pcnst) + + character(len=fieldname_len) :: tmpnamea + character(len=fieldname_len + 3) :: fieldname + character(128) :: long_name + character(8) :: unit + + logical :: history_aerosol + + ! Resolved species indices (pcnst-space, for portable _init) + integer :: idx_h2so4, idx_nh3, idx_msa + integer :: idx_soag(nsoa) + integer :: idx_so4_a(ntot_amode), idx_nh4_a(ntot_amode) + integer :: idx_soa_a(ntot_amode, nsoa) + integer :: idx_pom_a(ntot_amode, npoa) + integer :: idx_num(ntot_amode) + integer :: idx_mass(nspec_max, ntot_amode) + + ! pcage resolved arrays (pcnst-space) + integer :: nspecfrm_pcage_resolved + integer :: lspecfrm_pcage_resolved(nspec_max) + integer :: lspectoo_pcage_resolved(nspec_max) + + ! SOA/POA molecular weights from host + real(r8) :: mw_soa_host_resolved(nsoa) + real(r8) :: mw_poa_host_resolved(npoa) + + character(len=32) :: spec_type + character(len=256) :: errmsg + integer :: errflg + + call phys_getopts(history_aerosol_out=history_aerosol) + + !----------------------------------------------------------------------- + ! Part A: Resolve arguments and call portable _init + !----------------------------------------------------------------------- + + ! --- Gas-phase species indices (pcnst-space) --- + call cnst_get_ind('H2SO4', idx_h2so4, .false.) + if ((idx_h2so4 <= 0) .or. (idx_h2so4 > pcnst)) then + write (*, '(/a/a,i7)') & + '*** modal_aero_gasaerexch_cam_init -- cannot find H2SO4 species', & + ' idx_h2so4=', idx_h2so4 + call endrun('modal_aero_gasaerexch_cam_init error: H2SO4 not found') end if - end do - ! --- Aerosol species indices (per mode, pcnst-space) --- - do n = 1, ntot_amode - l = lptr_so4_a_amode(n) - if ((l > 0) .and. (l <= pcnst)) then - idx_so4_a(n) = l - else - idx_so4_a(n) = 0 - end if + call cnst_get_ind('NH3', idx_nh3, .false.) + if (.not. ((idx_nh3 > 0) .and. (idx_nh3 <= pcnst))) idx_nh3 = 0 - l = lptr_nh4_a_amode(n) - if ((l > 0) .and. (l <= pcnst)) then - idx_nh4_a(n) = l + if (.not. cam_chempkg_is('geoschem_mam4')) then + call cnst_get_ind('MSA', idx_msa, .false.) else - idx_nh4_a(n) = 0 + idx_msa = 0 end if + if (.not. ((idx_msa > 0) .and. (idx_msa <= pcnst))) idx_msa = 0 + ! --- SOA gas-phase species indices (pcnst-space) --- do jsoa = 1, nsoa - l = lptr2_soa_a_amode(n, jsoa) - if ((l > 0) .and. (l <= pcnst)) then - idx_soa_a(n, jsoa) = l - else - idx_soa_a(n, jsoa) = 0 - end if + l = lptr2_soa_g_amode(jsoa) + if ((l > 0) .and. (l <= pcnst)) then + idx_soag(jsoa) = l + else + idx_soag(jsoa) = 0 + end if end do - do j = 1, npoa - l = lptr2_pom_a_amode(n, j) - if ((l > 0) .and. (l <= pcnst)) then - idx_pom_a(n, j) = l - else - idx_pom_a(n, j) = 0 - end if + ! --- Aerosol species indices (per mode, pcnst-space) --- + do n = 1, ntot_amode + l = lptr_so4_a_amode(n) + if ((l > 0) .and. (l <= pcnst)) then + idx_so4_a(n) = l + else + idx_so4_a(n) = 0 + end if + + l = lptr_nh4_a_amode(n) + if ((l > 0) .and. (l <= pcnst)) then + idx_nh4_a(n) = l + else + idx_nh4_a(n) = 0 + end if + + do jsoa = 1, nsoa + l = lptr2_soa_a_amode(n, jsoa) + if ((l > 0) .and. (l <= pcnst)) then + idx_soa_a(n, jsoa) = l + else + idx_soa_a(n, jsoa) = 0 + end if + end do + + do j = 1, npoa + l = lptr2_pom_a_amode(n, j) + if ((l > 0) .and. (l <= pcnst)) then + idx_pom_a(n, j) = l + else + idx_pom_a(n, j) = 0 + end if + end do + + l = numptr_amode(n) + if ((l > 0) .and. (l <= pcnst)) then + idx_num(n) = l + else + idx_num(n) = 0 + end if + + do l = 1, nspec_amode(n) + idx_mass(l, n) = lmassptr_amode(l, n) + end do end do - l = numptr_amode(n) - if ((l > 0) .and. (l <= pcnst)) then - idx_num(n) = l - else - idx_num(n) = 0 - end if + ! --- Resolve pcage species matching --- + ! Copied from original modal_aero_gasaerexch_init + ! Indices stored in pcnst-space. + nspecfrm_pcage_resolved = 0 + lspecfrm_pcage_resolved(:) = 0 + lspectoo_pcage_resolved(:) = 0 - do l = 1, nspec_amode(n) - idx_mass(l, n) = lmassptr_amode(l, n) - end do - end do - - ! --- Resolve pcage species matching --- - ! Copied from original modal_aero_gasaerexch_init - ! Indices stored in pcnst-space. - nspecfrm_pcage_resolved = 0 - lspecfrm_pcage_resolved(:) = 0 - lspectoo_pcage_resolved(:) = 0 - - if ((modeptr_pcarbon > 0) .and. (modeptr_accum > 0)) then - l = lptr_so4_a_amode(modeptr_accum) - if ((l >= 1) .and. (l <= pcnst)) then - - mfrm = modeptr_pcarbon - mtoo = modeptr_accum - - 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 - lsfrm = numptr_amode(mfrm) - lstoo = numptr_amode(mtoo) - else if (iqfrm == 0) then - ! bypass transfer of aerosol water due to primary-carbon aging - cycle aa_iqfrm - else - lsfrm = lmassptr_amode(iqfrm, mfrm) - lstoo = 0 - end if - if ((lsfrm < 1) .or. (lsfrm > pcnst)) cycle aa_iqfrm - - if (lsfrm > 0 .and. iqfrm > 0) then - nchfrm = len(trim(cnst_name(lsfrm))) - nchfrmskip - - ! find "too" species having same cnst_name (except for last 1/2/3 characters which are the mode index) - do iqtoo = 1, nspec_amode(mtoo) - lstoo = lmassptr_amode(iqtoo, mtoo) - nchtoo = len(trim(cnst_name(lstoo))) - nchtooskip - if (cnst_name(lsfrm) (1:nchfrm) == cnst_name(lstoo) (1:nchtoo)) then - exit - else - lstoo = 0 - end if - end do - end if - - if ((lstoo < 1) .or. (lstoo > pcnst)) lstoo = 0 - nspec = nspec + 1 - lspecfrm_pcage_resolved(nspec) = lsfrm - lspectoo_pcage_resolved(nspec) = lstoo - end do aa_iqfrm - - nspecfrm_pcage_resolved = nspec - - ! output results - if (masterproc) then - write (iulog, 9310) - write (iulog, 9320) 1, mfrm, mtoo - - do iq = 1, nspecfrm_pcage_resolved - lsfrm = lspecfrm_pcage_resolved(iq) - lstoo = lspectoo_pcage_resolved(iq) - if (lstoo > 0) then - write (iulog, 9330) lsfrm, cnst_name(lsfrm), & - lstoo, cnst_name(lstoo) + if ((modeptr_pcarbon > 0) .and. (modeptr_accum > 0)) then + l = lptr_so4_a_amode(modeptr_accum) + if ((l >= 1) .and. (l <= pcnst)) then + + mfrm = modeptr_pcarbon + mtoo = modeptr_accum + + 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 - write (iulog, 9340) lsfrm, cnst_name(lsfrm) + nchtooskip = 3 end if - end do - - write (iulog, *) - end if ! ( masterproc ) - -9310 format(/'subr. modal_aero_gasaerexch_cam_init - primary carbon aging pointers') -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') - - end if ! lptr_so4_a_amode(modeptr_accum) valid - end if ! modeptr_pcarbon > 0 .and. modeptr_accum > 0 - - ! --- Resolve SOA/POA molecular weights using rad_aer_get_info --- - mw_soa_host_resolved(:) = 0.0_r8 - mw_poa_host_resolved(:) = 0.0_r8 - - do n = 1, ntot_amode - do l = 1, nspec_amode(n) - call rad_aer_get_info(0, n, l, spec_type=spec_type) - select case (spec_type) - case ('s-organic') - mw_soa_host_resolved(:) = specmw_amode(l, n) - case ('p-organic') - mw_poa_host_resolved(:) = specmw_amode(l, n) - end select + nspec = 0 + + aa_iqfrm: do iqfrm = -1, nspec_amode(mfrm) + + if (iqfrm == -1) then + lsfrm = numptr_amode(mfrm) + lstoo = numptr_amode(mtoo) + else if (iqfrm == 0) then + ! bypass transfer of aerosol water due to primary-carbon aging + cycle aa_iqfrm + else + lsfrm = lmassptr_amode(iqfrm, mfrm) + lstoo = 0 + end if + if ((lsfrm < 1) .or. (lsfrm > pcnst)) cycle aa_iqfrm + + if (lsfrm > 0 .and. iqfrm > 0) then + nchfrm = len(trim(cnst_name(lsfrm))) - nchfrmskip + + ! find "too" species having same cnst_name (except for last 1/2/3 characters which are the mode index) + do iqtoo = 1, nspec_amode(mtoo) + lstoo = lmassptr_amode(iqtoo, mtoo) + nchtoo = len(trim(cnst_name(lstoo))) - nchtooskip + if (cnst_name(lsfrm) (1:nchfrm) == cnst_name(lstoo) (1:nchtoo)) then + exit + else + lstoo = 0 + end if + end do + end if + + if ((lstoo < 1) .or. (lstoo > pcnst)) lstoo = 0 + nspec = nspec + 1 + lspecfrm_pcage_resolved(nspec) = lsfrm + lspectoo_pcage_resolved(nspec) = lstoo + end do aa_iqfrm + + nspecfrm_pcage_resolved = nspec + + ! output results + if (masterproc) then + write (iulog, 9310) + write (iulog, 9320) 1, mfrm, mtoo + + do iq = 1, nspecfrm_pcage_resolved + lsfrm = lspecfrm_pcage_resolved(iq) + lstoo = lspectoo_pcage_resolved(iq) + if (lstoo > 0) then + write (iulog, 9330) lsfrm, cnst_name(lsfrm), & + lstoo, cnst_name(lstoo) + else + write (iulog, 9340) lsfrm, cnst_name(lsfrm) + end if + end do + + write (iulog, *) + end if ! ( masterproc ) + +9310 format(/'subr. modal_aero_gasaerexch_cam_init - primary carbon aging pointers') +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') + + end if ! lptr_so4_a_amode(modeptr_accum) valid + end if ! modeptr_pcarbon > 0 .and. modeptr_accum > 0 + + ! --- Resolve SOA/POA molecular weights using rad_aer_get_info --- + mw_soa_host_resolved(:) = 0.0_r8 + mw_poa_host_resolved(:) = 0.0_r8 + + do n = 1, ntot_amode + do l = 1, nspec_amode(n) + call rad_aer_get_info(0, n, l, spec_type=spec_type) + select case (spec_type) + case ('s-organic') + mw_soa_host_resolved(:) = specmw_amode(l, n) + case ('p-organic') + mw_poa_host_resolved(:) = specmw_amode(l, n) + end select + end do end do - end do - - ! --- Call portable init --- - call modal_aero_gasaerexch_init( & - ntot_amode = ntot_amode, & - nsoa = nsoa, & - npoa = npoa, & - nspec_max = nspec_max, & - nspec_amode = nspec_amode, & - modeptr_pcarbon = modeptr_pcarbon, & - modeptr_accum = modeptr_accum, & - alnsg_amode = alnsg_amode, & - sigmag_amode = sigmag_amode, & - specmw_amode = specmw_amode, & - specdens_amode = specdens_amode, & - spechygro = spechygro, & - idx_h2so4 = idx_h2so4, & - idx_nh3 = idx_nh3, & - idx_msa = idx_msa, & - idx_soag = idx_soag, & - idx_so4_a = idx_so4_a, & - idx_nh4_a = idx_nh4_a, & - idx_soa_a = idx_soa_a, & - idx_pom_a = idx_pom_a, & - idx_num = idx_num, & - idx_mass = idx_mass, & - pcnst_in = pcnst, & - nspecfrm_pcage_in = nspecfrm_pcage_resolved, & - lspecfrm_pcage_in = lspecfrm_pcage_resolved, & - lspectoo_pcage_in = lspectoo_pcage_resolved, & - mw_soa_host = mw_soa_host_resolved, & - mw_poa_host = mw_poa_host_resolved, & - rair = rair, & - mwdry = mwdry, & - r_universal = r_universal, & - errmsg = errmsg, & - errflg = errflg) - - if (errflg /= 0) then - call endrun('modal_aero_gasaerexch_cam_init: '//trim(errmsg)) - end if - - !----------------------------------------------------------------------- - ! Part B: History field registration (addfld calls) - !----------------------------------------------------------------------- - - ! --- Tendency flags for _sfgaex1 fields --- - ! Determine which constituents get gas-aerosol exchange tendency output - dotend(:) = .false. - - ! H2SO4 (required). below indices are in pcnst indexing: - dotend(idx_h2so4) = .true. - - ! NH3 (optional) - if ((idx_nh3 > 0) .and. (idx_nh3 <= pcnst)) dotend(idx_nh3) = .true. - - ! MSA (optional) - if ((idx_msa > 0) .and. (idx_msa <= pcnst)) dotend(idx_msa) = .true. - - ! SOA gases - do jsoa = 1, nsoa - l = lptr2_soa_g_amode(jsoa) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end do - - ! Aerosol species in modes - do n = 1, ntot_amode - l = lptr_so4_a_amode(n) - if ((l > 0) .and. (l <= pcnst)) then - dotend(l) = .true. - if (idx_nh3 > 0) then - l = lptr_nh4_a_amode(n) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end if + + ! --- Call portable init --- + call modal_aero_gasaerexch_init( & + ntot_amode = ntot_amode, & + nsoa = nsoa, & + npoa = npoa, & + nspec_max = nspec_max, & + nspec_amode = nspec_amode, & + modeptr_pcarbon = modeptr_pcarbon, & + modeptr_accum = modeptr_accum, & + alnsg_amode = alnsg_amode, & + sigmag_amode = sigmag_amode, & + specmw_amode = specmw_amode, & + specdens_amode = specdens_amode, & + spechygro = spechygro, & + idx_h2so4 = idx_h2so4, & + idx_nh3 = idx_nh3, & + idx_msa = idx_msa, & + idx_soag = idx_soag, & + idx_so4_a = idx_so4_a, & + idx_nh4_a = idx_nh4_a, & + idx_soa_a = idx_soa_a, & + idx_pom_a = idx_pom_a, & + idx_num = idx_num, & + idx_mass = idx_mass, & + pcnst_in = pcnst, & + nspecfrm_pcage_in = nspecfrm_pcage_resolved, & + lspecfrm_pcage_in = lspecfrm_pcage_resolved, & + lspectoo_pcage_in = lspectoo_pcage_resolved, & + mw_soa_host = mw_soa_host_resolved, & + mw_poa_host = mw_poa_host_resolved, & + rair = rair, & + mwdry = mwdry, & + r_universal = r_universal, & + errmsg = errmsg, & + errflg = errflg) + + if (errflg /= 0) then + call endrun('modal_aero_gasaerexch_cam_init: '//trim(errmsg)) end if + + !----------------------------------------------------------------------- + ! Part B: History field registration (addfld calls) + !----------------------------------------------------------------------- + + ! --- Tendency flags for _sfgaex1 fields --- + ! Determine which constituents get gas-aerosol exchange tendency output + dotend(:) = .false. + + ! H2SO4 (required). below indices are in pcnst indexing: + dotend(idx_h2so4) = .true. + + ! NH3 (optional) + if ((idx_nh3 > 0) .and. (idx_nh3 <= pcnst)) dotend(idx_nh3) = .true. + + ! MSA (optional) + if ((idx_msa > 0) .and. (idx_msa <= pcnst)) dotend(idx_msa) = .true. + + ! SOA gases do jsoa = 1, nsoa - if (idx_soag(jsoa) > 0) then - l = lptr2_soa_a_amode(n, jsoa) - if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. - end if + l = lptr2_soa_g_amode(jsoa) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. end do - end do - - ! pcage species - if (nspecfrm_pcage_resolved > 0) then - do iq = 1, nspecfrm_pcage_resolved - ! lspec*_pcage_resolved are already pcnst-space (resolved above), so - ! they index dotend directly -- matching the original gasaerexch_init. - lsfrm = lspecfrm_pcage_resolved(iq) - lstoo = lspectoo_pcage_resolved(iq) - if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then - dotend(lsfrm) = .true. - if ((lstoo > 0) .and. (lstoo <= pcnst)) then - dotend(lstoo) = .true. - end if - end if + + ! Aerosol species in modes + do n = 1, ntot_amode + l = lptr_so4_a_amode(n) + if ((l > 0) .and. (l <= pcnst)) then + dotend(l) = .true. + if (idx_nh3 > 0) then + l = lptr_nh4_a_amode(n) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end if + end if + do jsoa = 1, nsoa + if (idx_soag(jsoa) > 0) then + l = lptr2_soa_a_amode(n, jsoa) + if ((l > 0) .and. (l <= pcnst)) dotend(l) = .true. + end if + end do end do - end if - - ! --- SOA condensation/evaporation diagnostics --- - fieldname = trim('qconff_gaex') - long_name = trim('3D fields for Fossil SOA condensation') - unit = 'kg/kg/s' - call addfld(fieldname, (/'lev'/), 'A', unit, long_name) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if (masterproc) write (*, '(3(a,3x))') 'qconff addfld', fieldname, unit - - fieldname = trim('qevapff_gaex') - long_name = trim('3D fields for Fossil SOA evaporation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if (masterproc) write (*, '(3(a,3x))') 'qevapff addfld', fieldname, unit - - fieldname = trim('qconbb_gaex') - long_name = trim('3D fields for Biomass SOA condensation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if (masterproc) write (*, '(3(a,3x))') 'qconbb addfld', fieldname, unit - - fieldname = trim('qevapbb_gaex') - long_name = trim('3D fields for Biomass SOA evaporation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if (masterproc) write (*, '(3(a,3x))') 'qevapbb addfld', fieldname, unit - - fieldname = trim('qconbg_gaex') - long_name = trim('3D fields for Biogenic SOA condensation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if (masterproc) write (*, '(3(a,3x))') 'qconbg addfld', fieldname, unit - - fieldname = trim('qevapbg_gaex') - long_name = trim('3D fields for Biogenic SOA evaporation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if (masterproc) write (*, '(3(a,3x))') 'qevapbg addfld', fieldname, unit - - fieldname = trim('qcon_gaex') - long_name = trim('3D fields for SOA condensation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if (masterproc) write (*, '(3(a,3x))') 'qcon addfld', fieldname, unit - - fieldname = trim('qevap_gaex') - long_name = trim('3D fields for Biogenic SOA evaporation') - call addfld(fieldname, (/'lev'/), 'A', unit, long_name) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if (masterproc) write (*, '(3(a,3x))') 'qevap addfld', fieldname, unit - - ! --- Per-species _sfgaex1 fields (gas-aerosol exchange primary tendency) --- - do l = 1, pcnst - if (.not. dotend(l)) cycle - - tmpnamea = cnst_name(l) - fieldname = trim(tmpnamea)//'_sfgaex1' - long_name = trim(tmpnamea)//' gas-aerosol-exchange primary column tendency' - unit = 'kg/m2/s' - call addfld(fieldname, horiz_only, 'A', unit, long_name) + + ! pcage species + if (nspecfrm_pcage_resolved > 0) then + do iq = 1, nspecfrm_pcage_resolved + ! lspec*_pcage_resolved are already pcnst-space (resolved above), so + ! they index dotend directly -- matching the original gasaerexch_init. + lsfrm = lspecfrm_pcage_resolved(iq) + lstoo = lspectoo_pcage_resolved(iq) + if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then + dotend(lsfrm) = .true. + if ((lstoo > 0) .and. (lstoo <= pcnst)) then + dotend(lstoo) = .true. + end if + end if + end do + end if + + ! --- SOA condensation/evaporation diagnostics --- + fieldname = trim('qconff_gaex') + long_name = trim('3D fields for Fossil SOA condensation') + unit = 'kg/kg/s' + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) if (history_aerosol) then - call add_default(fieldname, 1, ' ') + call add_default(fieldname, 1, ' ') end if - if (masterproc) write (*, '(3(a,3x))') 'gasaerexch addfld', fieldname, unit - - end do ! l = ... - - ! --- Per-species _sfgaex2 fields (renaming tendency) --- - dotend(:) = .false. - dotendqqcw(:) = .false. - do ipair = 1, npair_renamexf - do iq = 1, nspecfrm_renamexf(ipair) - lsfrm = lspecfrma_renamexf(iq, ipair) - lstoo = lspectooa_renamexf(iq, ipair) - if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then - dotend(lsfrm) = .true. - if ((lstoo > 0) .and. (lstoo <= pcnst)) then - dotend(lstoo) = .true. - end if - end if - - lsfrm = lspecfrmc_renamexf(iq, ipair) - lstoo = lspectooc_renamexf(iq, ipair) - if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then - dotendqqcw(lsfrm) = .true. - if ((lstoo > 0) .and. (lstoo <= pcnst)) then - dotendqqcw(lstoo) = .true. - end if - end if - end do ! iq = ... - end do ! ipair = ... - - do l = 1, pcnst - do jac = 1, 2 - if (jac == 1) then - if (.not. dotend(l)) cycle - tmpnamea = cnst_name(l) - else - if (.not. dotendqqcw(l)) cycle - tmpnamea = cnst_name_cw(l) + if (masterproc) write (*, '(3(a,3x))') 'qconff addfld', fieldname, unit + + fieldname = trim('qevapff_gaex') + long_name = trim('3D fields for Fossil SOA evaporation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qevapff addfld', fieldname, unit + + fieldname = trim('qconbb_gaex') + long_name = trim('3D fields for Biomass SOA condensation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qconbb addfld', fieldname, unit + + fieldname = trim('qevapbb_gaex') + long_name = trim('3D fields for Biomass SOA evaporation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') end if + if (masterproc) write (*, '(3(a,3x))') 'qevapbb addfld', fieldname, unit - fieldname = trim(tmpnamea)//'_sfgaex2' - long_name = trim(tmpnamea)//' gas-aerosol-exchange renaming column tendency' - unit = 'kg/m2/s' - if ((tmpnamea(1:3) == 'num') .or. & - (tmpnamea(1:3) == 'NUM')) unit = '#/m2/s' - call addfld(fieldname, horiz_only, 'A', unit, long_name) + fieldname = trim('qconbg_gaex') + long_name = trim('3D fields for Biogenic SOA condensation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) if (history_aerosol) then - call add_default(fieldname, 1, ' ') + call add_default(fieldname, 1, ' ') end if - if (masterproc) write (*, '(3(a,3x))') 'gasaerexch addfld', fieldname, unit - end do ! jac = ... - end do ! l = ... + if (masterproc) write (*, '(3(a,3x))') 'qconbg addfld', fieldname, unit - end subroutine modal_aero_gasaerexch_cam_init + fieldname = trim('qevapbg_gaex') + long_name = trim('3D fields for Biogenic SOA evaporation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qevapbg addfld', fieldname, unit + + fieldname = trim('qcon_gaex') + long_name = trim('3D fields for SOA condensation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qcon addfld', fieldname, unit + + fieldname = trim('qevap_gaex') + long_name = trim('3D fields for Biogenic SOA evaporation') + call addfld(fieldname, (/'lev'/), 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'qevap addfld', fieldname, unit + + ! --- Per-species _sfgaex1 fields (gas-aerosol exchange primary tendency) --- + do l = 1, pcnst + if (.not. dotend(l)) cycle + + tmpnamea = cnst_name(l) + fieldname = trim(tmpnamea)//'_sfgaex1' + long_name = trim(tmpnamea)//' gas-aerosol-exchange primary column tendency' + unit = 'kg/m2/s' + call addfld(fieldname, horiz_only, 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'gasaerexch addfld', fieldname, unit + + end do ! l = ... + + ! --- Per-species _sfgaex2 fields (renaming tendency) --- + dotend(:) = .false. + dotendqqcw(:) = .false. + do ipair = 1, npair_renamexf + do iq = 1, nspecfrm_renamexf(ipair) + lsfrm = lspecfrma_renamexf(iq, ipair) + lstoo = lspectooa_renamexf(iq, ipair) + if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then + dotend(lsfrm) = .true. + if ((lstoo > 0) .and. (lstoo <= pcnst)) then + dotend(lstoo) = .true. + end if + end if + + lsfrm = lspecfrmc_renamexf(iq, ipair) + lstoo = lspectooc_renamexf(iq, ipair) + if ((lsfrm > 0) .and. (lsfrm <= pcnst)) then + dotendqqcw(lsfrm) = .true. + if ((lstoo > 0) .and. (lstoo <= pcnst)) then + dotendqqcw(lstoo) = .true. + end if + end if + end do ! iq = ... + end do ! ipair = ... + + do l = 1, pcnst + do jac = 1, 2 + if (jac == 1) then + if (.not. dotend(l)) cycle + tmpnamea = cnst_name(l) + else + if (.not. dotendqqcw(l)) cycle + tmpnamea = cnst_name_cw(l) + end if + + fieldname = trim(tmpnamea)//'_sfgaex2' + long_name = trim(tmpnamea)//' gas-aerosol-exchange renaming column tendency' + unit = 'kg/m2/s' + if ((tmpnamea(1:3) == 'num') .or. & + (tmpnamea(1:3) == 'NUM')) unit = '#/m2/s' + call addfld(fieldname, horiz_only, 'A', unit, long_name) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if (masterproc) write (*, '(3(a,3x))') 'gasaerexch addfld', fieldname, unit + end do ! jac = ... + end do ! l = ... + + end subroutine modal_aero_gasaerexch_cam_init end module modal_aero_gasaerexch_cam diff --git a/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 b/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 index d324e92d23..7dfa5292f9 100644 --- a/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 +++ b/src/chemistry/modal_aero/modal_aero_newnuc_cam.F90 @@ -1,14 +1,14 @@ ! CAM wrapper for modal_aero_newnuc module modal_aero_newnuc_cam - use shr_kind_mod, only: r8 => shr_kind_r8 + use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - private + implicit none + private - public :: modal_aero_newnuc_cam_init + public :: modal_aero_newnuc_cam_init contains -subroutine modal_aero_newnuc_cam_init + subroutine modal_aero_newnuc_cam_init !----------------------------------------------------------------------- ! ! Purpose: @@ -22,157 +22,155 @@ subroutine modal_aero_newnuc_cam_init ! !----------------------------------------------------------------------- -use modal_aero_data -use modal_aero_newnuc, only: modal_aero_newnuc_init + use modal_aero_data + use modal_aero_newnuc, only: modal_aero_newnuc_init -use cam_abortutils, only: endrun -use cam_history, only: addfld, add_default, fieldname_len, horiz_only -use constituents, only: pcnst, cnst_get_ind, cnst_name -use mo_constants, only: pi, rgas, avogadro -use physconst, only: mwso4, mwnh4, r_universal -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, horiz_only + use constituents, only: pcnst, cnst_get_ind, cnst_name + use mo_constants, only: pi, rgas, avogadro + use physconst, only: mwso4, mwnh4, r_universal + use spmd_utils, only: masterproc + use phys_control, only: phys_getopts + integer :: l_h2so4, l_nh3 + integer :: lnumait, lnh4ait, lso4ait + integer :: l, l1, l2 + integer :: m, mait - integer :: l_h2so4, l_nh3 - integer :: lnumait, lnh4ait, lso4ait - integer :: l, l1, l2 - integer :: m, mait + real(r8) :: mw_so4a_host, mw_nh4a_host + real(r8) :: dens_so4a_host - real(r8) :: mw_so4a_host, mw_nh4a_host - real(r8) :: dens_so4a_host + character(len=fieldname_len) :: tmpname + character(len=fieldname_len+3) :: fieldname + character(128) :: long_name + character(8) :: unit - character(len=fieldname_len) :: tmpname - character(len=fieldname_len+3) :: fieldname - character(128) :: long_name - character(8) :: unit + logical :: dotend(pcnst) + logical :: history_aerosol ! Output the MAM aerosol tendencies - logical :: dotend(pcnst) - logical :: history_aerosol ! Output the MAM aerosol tendencies + character(len=512) :: errmsg + integer :: errflg - character(len=512) :: errmsg - integer :: errflg - - !----------------------------------------------------------------------- - - call phys_getopts( history_aerosol_out = history_aerosol ) + !----------------------------------------------------------------------- + call phys_getopts( history_aerosol_out = history_aerosol ) ! set these indices ! skip if no h2so4 species (the portable module keeps its bypass ! defaults when modal_aero_newnuc_init is not called) ! skip if no aitken mode so4 or num species - call cnst_get_ind( 'H2SO4', l_h2so4, .false. ) - call cnst_get_ind( 'NH3', l_nh3, .false. ) - - mait = modeptr_aitken - if (mait > 0) then - lnumait = numptr_amode(mait) - lso4ait = lptr_so4_a_amode(mait) - lnh4ait = lptr_nh4_a_amode(mait) - end if - if ((l_h2so4 <= 0) .or. (l_h2so4 > pcnst)) then - write(*,'(/a/)') & - '*** modal_aero_newnuc bypass -- l_h2so4 <= 0' - return - else if ((lso4ait <= 0) .or. (lso4ait > pcnst)) then - write(*,'(/a/)') & - '*** modal_aero_newnuc bypass -- lso4ait <= 0' - return - else if ((lnumait <= 0) .or. (lnumait > pcnst)) then - write(*,'(/a/)') & - '*** modal_aero_newnuc bypass -- lnumait <= 0' - return - else if ((mait <= 0) .or. (mait > ntot_amode)) then - write(*,'(/a/)') & - '*** modal_aero_newnuc bypass -- modeptr_aitken <= 0' - return - end if + call cnst_get_ind( 'H2SO4', l_h2so4, .false. ) + call cnst_get_ind( 'NH3', l_nh3, .false. ) + + mait = modeptr_aitken + if (mait > 0) then + lnumait = numptr_amode(mait) + lso4ait = lptr_so4_a_amode(mait) + lnh4ait = lptr_nh4_a_amode(mait) + end if + if ((l_h2so4 <= 0) .or. (l_h2so4 > pcnst)) then + write(*,'(/a/)') & + '*** modal_aero_newnuc bypass -- l_h2so4 <= 0' + return + else if ((lso4ait <= 0) .or. (lso4ait > pcnst)) then + write(*,'(/a/)') & + '*** modal_aero_newnuc bypass -- lso4ait <= 0' + return + else if ((lnumait <= 0) .or. (lnumait > pcnst)) then + write(*,'(/a/)') & + '*** modal_aero_newnuc bypass -- lnumait <= 0' + return + else if ((mait <= 0) .or. (mait > ntot_amode)) then + write(*,'(/a/)') & + '*** modal_aero_newnuc bypass -- modeptr_aitken <= 0' + return + end if ! set these constants ! mw_so4a_host is molec-wght of sulfate aerosol in host code ! 96 when nh3/nh4 are simulated ! something else when nh3/nh4 are not simulated - l = lptr_so4_a_amode(mait) ; l2 = -1 - if (l <= 0) call endrun( 'modal_aero_newnuch_init error a001 finding aitken so4' ) - do l1 = 1, nspec_amode(mait) - if (lmassptr_amode(l1,mait) == l) then - l2 = l1 - mw_so4a_host = specmw_amode(l1,mait) - dens_so4a_host = specdens_amode(l1,mait) - end if - end do - if (l2 <= 0) call endrun( 'modal_aero_newnuch_init error a002 finding aitken so4' ) - - l = lptr_nh4_a_amode(mait) ; l2 = -1 - if (l > 0) then - do l1 = 1, nspec_amode(mait) - if (lmassptr_amode(l1,mait) == l) then - l2 = l1 - mw_nh4a_host = specmw_amode(l1,mait) - end if - end do - if (l2 <= 0) call endrun( 'modal_aero_newnuch_init error a002 finding aitken nh4' ) - else - mw_nh4a_host = mw_so4a_host - end if - - ! call portable science subroutine: - call modal_aero_newnuc_init( & - l_h2so4_in = l_h2so4, & - l_nh3_in = l_nh3, & - lnumait_in = lnumait, & - lnh4ait_in = lnh4ait, & - lso4ait_in = lso4ait, & - mw_so4a_host_in = mw_so4a_host, & - mw_nh4a_host_in = mw_nh4a_host, & - dens_so4a_host_in = dens_so4a_host, & - dgnum_aitken_in = dgnum_amode(mait), & - dgnumhi_aitken_in = dgnumhi_amode(mait), & - dgnumlo_aitken_in = dgnumlo_amode(mait), & - pi_in = pi, & - rgas_in = rgas, & - avogad_in = avogadro, & - mw_so4a_in = mwso4, & - mw_nh4a_in = mwnh4, & - r_universal_in = r_universal, & - errmsg = errmsg, & - errflg = errflg ) - - if (errflg /= 0) then - call endrun('modal_aero_newnuc_cam_init: '//trim(errmsg)) - end if + l = lptr_so4_a_amode(mait) ; l2 = -1 + if (l <= 0) call endrun( 'modal_aero_newnuch_init error a001 finding aitken so4' ) + do l1 = 1, nspec_amode(mait) + if (lmassptr_amode(l1,mait) == l) then + l2 = l1 + mw_so4a_host = specmw_amode(l1,mait) + dens_so4a_host = specdens_amode(l1,mait) + end if + end do + if (l2 <= 0) call endrun( 'modal_aero_newnuch_init error a002 finding aitken so4' ) + + l = lptr_nh4_a_amode(mait) ; l2 = -1 + if (l > 0) then + do l1 = 1, nspec_amode(mait) + if (lmassptr_amode(l1,mait) == l) then + l2 = l1 + mw_nh4a_host = specmw_amode(l1,mait) + end if + end do + if (l2 <= 0) call endrun( 'modal_aero_newnuch_init error a002 finding aitken nh4' ) + else + mw_nh4a_host = mw_so4a_host + end if + + ! call portable science subroutine: + call modal_aero_newnuc_init( & + l_h2so4_in = l_h2so4, & + l_nh3_in = l_nh3, & + lnumait_in = lnumait, & + lnh4ait_in = lnh4ait, & + lso4ait_in = lso4ait, & + mw_so4a_host_in = mw_so4a_host, & + mw_nh4a_host_in = mw_nh4a_host, & + dens_so4a_host_in = dens_so4a_host, & + dgnum_aitken_in = dgnum_amode(mait), & + dgnumhi_aitken_in = dgnumhi_amode(mait), & + dgnumlo_aitken_in = dgnumlo_amode(mait), & + pi_in = pi, & + rgas_in = rgas, & + avogad_in = avogadro, & + mw_so4a_in = mwso4, & + mw_nh4a_in = mwnh4, & + r_universal_in = r_universal, & + errmsg = errmsg, & + errflg = errflg ) + + if (errflg /= 0) then + call endrun('modal_aero_newnuc_cam_init: '//trim(errmsg)) + end if ! ! create history file column-tendency fields ! - dotend(:) = .false. - dotend(lnumait) = .true. - dotend(lso4ait) = .true. - dotend(l_h2so4) = .true. - if ((l_nh3 > 0) .and. (l_nh3 <= pcnst) .and. & - (lnh4ait > 0) .and. (lnh4ait <= pcnst)) then - dotend(lnh4ait) = .true. - dotend(l_nh3) = .true. - end if - - do l = 1, pcnst - if ( .not. dotend(l) ) cycle - tmpname = cnst_name(l) - unit = 'kg/m2/s' - do m = 1, ntot_amode - if (l == numptr_amode(m)) unit = '#/m2/s' - end do - fieldname = trim(tmpname) // '_sfnnuc1' - long_name = trim(tmpname) // ' modal_aero new particle nucleation column tendency' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if ( history_aerosol ) then - call add_default( fieldname, 1, ' ' ) - endif - if ( masterproc ) write(*,'(3(a,2x))') & - 'modal_aero_newnuc_init addfld', fieldname, unit - end do ! l = ... - -end subroutine modal_aero_newnuc_cam_init + dotend(:) = .false. + dotend(lnumait) = .true. + dotend(lso4ait) = .true. + dotend(l_h2so4) = .true. + if ((l_nh3 > 0) .and. (l_nh3 <= pcnst) .and. & + (lnh4ait > 0) .and. (lnh4ait <= pcnst)) then + dotend(lnh4ait) = .true. + dotend(l_nh3) = .true. + end if + + do l = 1, pcnst + if ( .not. dotend(l) ) cycle + tmpname = cnst_name(l) + unit = 'kg/m2/s' + do m = 1, ntot_amode + if (l == numptr_amode(m)) unit = '#/m2/s' + end do + fieldname = trim(tmpname) // '_sfnnuc1' + long_name = trim(tmpname) // ' modal_aero new particle nucleation column tendency' + call addfld( fieldname, horiz_only, 'A', unit, long_name ) + if ( history_aerosol ) then + call add_default( fieldname, 1, ' ' ) + endif + if ( masterproc ) write(*,'(3(a,2x))') & + 'modal_aero_newnuc_init addfld', fieldname, unit + end do ! l = ... + + end subroutine modal_aero_newnuc_cam_init end module modal_aero_newnuc_cam diff --git a/src/chemistry/modal_aero/modal_aero_rename_cam.F90 b/src/chemistry/modal_aero/modal_aero_rename_cam.F90 index 8ded4cc79f..2cba007e7c 100644 --- a/src/chemistry/modal_aero/modal_aero_rename_cam.F90 +++ b/src/chemistry/modal_aero/modal_aero_rename_cam.F90 @@ -1,38 +1,38 @@ ! CAM wrapper for modal_aero_rename module modal_aero_rename_cam - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use mo_constants, only: pi - use constituents, only: pcnst, cnst_name - use spmd_utils, only: masterproc - use modal_aero_data, only: maxspec_renamexf=>nspec_max, ntot_amode - use modal_aero_data, only: alnsg_amode, voltonumblo_amode, voltonumbhi_amode, dgnum_amode, nspec_amode - use modal_aero_data, only: lmassptr_amode, lmassptrcw_amode - use modal_aero_data, only: numptr_amode, numptrcw_amode, modeptr_coarse, modeptr_accum - use modal_aero_data, only: modeptr_stracoar - use modal_aero_data, only: dgnumhi_amode, dgnumlo_amode, cnst_name_cw, modeptr_aitken - use radiative_aerosol,only: rad_aer_get_mode_idx - use modal_aero_rename, only: maxpair_renamexf - - implicit none - private - - public :: modal_aero_rename_cam_init + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use mo_constants, only: pi + use constituents, only: pcnst, cnst_name + use spmd_utils, only: masterproc + use modal_aero_data, only: maxspec_renamexf=>nspec_max, ntot_amode + use modal_aero_data, only: alnsg_amode, voltonumblo_amode, voltonumbhi_amode, dgnum_amode, nspec_amode + use modal_aero_data, only: lmassptr_amode, lmassptrcw_amode + use modal_aero_data, only: numptr_amode, numptrcw_amode, modeptr_coarse, modeptr_accum + use modal_aero_data, only: modeptr_stracoar + use modal_aero_data, only: dgnumhi_amode, dgnumlo_amode, cnst_name_cw, modeptr_aitken + use radiative_aerosol,only: rad_aer_get_mode_idx + use modal_aero_rename, only: maxpair_renamexf + + implicit none + private + + public :: modal_aero_rename_cam_init ! PUBLIC DATA MEMBERS: ! Resolved renaming-pair tables (host constituent-index space). These are ! consumed by modal_aero_calcsize_cam and modal_aero_gasaerexch_cam. - integer, public :: npair_renamexf = -123456789 - integer, protected, public :: modefrm_renamexf(maxpair_renamexf) - integer, protected, public :: modetoo_renamexf(maxpair_renamexf) - integer, protected, public :: nspecfrm_renamexf(maxpair_renamexf) + integer, public :: npair_renamexf = -123456789 + integer, protected, public :: modefrm_renamexf(maxpair_renamexf) + integer, protected, public :: modetoo_renamexf(maxpair_renamexf) + integer, protected, public :: nspecfrm_renamexf(maxpair_renamexf) - integer, allocatable, protected, public :: lspecfrma_renamexf(:,:) - integer, allocatable, protected, public :: lspecfrmc_renamexf(:,:) - integer, allocatable, protected, public :: lspectooa_renamexf(:,:) - integer, allocatable, protected, public :: lspectooc_renamexf(:,:) + integer, allocatable, protected, public :: lspecfrma_renamexf(:,:) + integer, allocatable, protected, public :: lspecfrmc_renamexf(:,:) + integer, allocatable, protected, public :: lspectooa_renamexf(:,:) + integer, allocatable, protected, public :: lspectooc_renamexf(:,:) ! ipair_select_renamexf defines the mode_from and mode_too for each renaming pair ! 2001 = aitken --> accum @@ -40,540 +40,538 @@ module modal_aero_rename_cam ! 3001 = coarse --> accum ! 1005 = accum --> stracoar ! 5001 = stracoar --> accum - integer :: ipair_select_renamexf(maxpair_renamexf) + integer :: ipair_select_renamexf(maxpair_renamexf) ! Renaming-pair flags resolved here and consumed by the portable science: ! passed to modal_aero_rename_init, ! and passed by aero_model to modal_aero_rename_run. - integer, protected, public :: igrow_shrink_renamexf(maxpair_renamexf) - integer, protected, public :: ixferable_all_renamexf(maxpair_renamexf) - integer :: ixferable_all_needed_renamexf(maxpair_renamexf) - integer, allocatable, protected, public :: ixferable_a_renamexf(:,:) - integer, allocatable, protected, public :: ixferable_c_renamexf(:,:) + integer, protected, public :: igrow_shrink_renamexf(maxpair_renamexf) + integer, protected, public :: ixferable_all_renamexf(maxpair_renamexf) + integer :: ixferable_all_needed_renamexf(maxpair_renamexf) + integer, allocatable, protected, public :: ixferable_a_renamexf(:,:) + integer, allocatable, protected, public :: ixferable_c_renamexf(:,:) - logical, protected, public :: strat_only_renamexf(maxpair_renamexf) + logical, protected, public :: strat_only_renamexf(maxpair_renamexf) ! strat_only_renamexf - when true for a particular renaming pair, renaming is only ! done in stratosphere (when k < troplev(icol) ) - logical :: modal_accum_coarse_exch = .false. + logical :: modal_accum_coarse_exch = .false. !---------------------------------------------------------------------- contains - subroutine modal_aero_rename_cam_init(modal_accum_coarse_exch_in) - use modal_aero_rename, only: modal_aero_rename_init - - logical, optional, intent(in) :: modal_accum_coarse_exch_in - - character(len=512) :: errmsg - integer :: errflg - - ! ipair_select_renamexf defines the mode_from and mode_too for each renaming pair - ! 2001 = aitken --> accum - ! 1003 = accum --> coarse - ! 3001 = coarse --> accum - ! 1005 = accum --> stracoar - ! 5001 = stracoar --> accum - if( rad_aer_get_mode_idx(0,'coarse_strat') > 0 ) then - ipair_select_renamexf(1:maxpair_renamexf) = (/ 2001, 1005, 5001 /) - else - ipair_select_renamexf(1:maxpair_renamexf) = (/ 2001, 1003, 3001 /) - endif - - allocate( lspecfrma_renamexf(maxspec_renamexf,maxpair_renamexf) ) - allocate( lspecfrmc_renamexf(maxspec_renamexf,maxpair_renamexf) ) - allocate( lspectooa_renamexf(maxspec_renamexf,maxpair_renamexf) ) - allocate( lspectooc_renamexf(maxspec_renamexf,maxpair_renamexf) ) - - allocate( ixferable_a_renamexf(maxspec_renamexf,maxpair_renamexf) ) - allocate( ixferable_c_renamexf(maxspec_renamexf,maxpair_renamexf) ) - - ! Default-initialize the accum-coarse-exchange flags: - ! unset in the no_acc_crs resolution path - igrow_shrink_renamexf(:) = 0 - ixferable_all_renamexf(:) = 0 - ixferable_a_renamexf(:,:) = 0 - ixferable_c_renamexf(:,:) = 0 - strat_only_renamexf(:) = .false. - - if (present(modal_accum_coarse_exch_in)) then - modal_accum_coarse_exch = modal_accum_coarse_exch_in - endif - - if (modal_accum_coarse_exch) then - call modal_aero_rename_acc_crs_init() - else - call modal_aero_rename_no_acc_crs_init() - endif - - ! Precompute rename's own accum-coarse-exchange physics coefficients: - call modal_aero_rename_init( & - modal_accum_coarse_exch = modal_accum_coarse_exch, & - ntot_amode = ntot_amode, & - alnsg_amode = alnsg_amode, & - dgnum_amode = dgnum_amode, & - dgnumhi_amode = dgnumhi_amode, & - dgnumlo_amode = dgnumlo_amode, & - voltonumblo_amode = voltonumblo_amode, & - voltonumbhi_amode = voltonumbhi_amode, & - modeptr_accum = modeptr_accum, & - modeptr_coarse = modeptr_coarse, & - modeptr_stracoar = modeptr_stracoar, & - npair_renamexf = npair_renamexf, & - modefrm_renamexf = modefrm_renamexf, & - modetoo_renamexf = modetoo_renamexf, & - nspecfrm_renamexf = nspecfrm_renamexf, & - lspecfrma_renamexf = lspecfrma_renamexf, & - lspecfrmc_renamexf = lspecfrmc_renamexf, & - lspectooa_renamexf = lspectooa_renamexf, & - lspectooc_renamexf = lspectooc_renamexf, & - igrow_shrink_renamexf = igrow_shrink_renamexf, & - ixferable_all_renamexf = ixferable_all_renamexf, & - cnst_name_in = cnst_name, & - cnst_name_cw_in = cnst_name_cw, & - pi = pi, & - amRoot = masterproc, & - iulog_in = iulog, & - errmsg = errmsg, & - errflg = errflg ) - - if (errflg /= 0) then - call endrun('modal_aero_rename_cam_init: '//trim(errmsg)) - end if - - end subroutine modal_aero_rename_cam_init + subroutine modal_aero_rename_cam_init(modal_accum_coarse_exch_in) + use modal_aero_rename, only: modal_aero_rename_init + + logical, optional, intent(in) :: modal_accum_coarse_exch_in + + character(len=512) :: errmsg + integer :: errflg + + ! ipair_select_renamexf defines the mode_from and mode_too for each renaming pair + ! 2001 = aitken --> accum + ! 1003 = accum --> coarse + ! 3001 = coarse --> accum + ! 1005 = accum --> stracoar + ! 5001 = stracoar --> accum + if( rad_aer_get_mode_idx(0,'coarse_strat') > 0 ) then + ipair_select_renamexf(1:maxpair_renamexf) = (/ 2001, 1005, 5001 /) + else + ipair_select_renamexf(1:maxpair_renamexf) = (/ 2001, 1003, 3001 /) + endif + + allocate( lspecfrma_renamexf(maxspec_renamexf,maxpair_renamexf) ) + allocate( lspecfrmc_renamexf(maxspec_renamexf,maxpair_renamexf) ) + allocate( lspectooa_renamexf(maxspec_renamexf,maxpair_renamexf) ) + allocate( lspectooc_renamexf(maxspec_renamexf,maxpair_renamexf) ) + + allocate( ixferable_a_renamexf(maxspec_renamexf,maxpair_renamexf) ) + allocate( ixferable_c_renamexf(maxspec_renamexf,maxpair_renamexf) ) + + ! Default-initialize the accum-coarse-exchange flags: + ! unset in the no_acc_crs resolution path + igrow_shrink_renamexf(:) = 0 + ixferable_all_renamexf(:) = 0 + ixferable_a_renamexf(:,:) = 0 + ixferable_c_renamexf(:,:) = 0 + strat_only_renamexf(:) = .false. + + if (present(modal_accum_coarse_exch_in)) then + modal_accum_coarse_exch = modal_accum_coarse_exch_in + endif + + if (modal_accum_coarse_exch) then + call modal_aero_rename_acc_crs_init() + else + call modal_aero_rename_no_acc_crs_init() + endif + + ! Precompute rename's own accum-coarse-exchange physics coefficients: + call modal_aero_rename_init( & + modal_accum_coarse_exch = modal_accum_coarse_exch, & + ntot_amode = ntot_amode, & + alnsg_amode = alnsg_amode, & + dgnum_amode = dgnum_amode, & + dgnumhi_amode = dgnumhi_amode, & + dgnumlo_amode = dgnumlo_amode, & + voltonumblo_amode = voltonumblo_amode, & + voltonumbhi_amode = voltonumbhi_amode, & + modeptr_accum = modeptr_accum, & + modeptr_coarse = modeptr_coarse, & + modeptr_stracoar = modeptr_stracoar, & + npair_renamexf = npair_renamexf, & + modefrm_renamexf = modefrm_renamexf, & + modetoo_renamexf = modetoo_renamexf, & + nspecfrm_renamexf = nspecfrm_renamexf, & + lspecfrma_renamexf = lspecfrma_renamexf, & + lspecfrmc_renamexf = lspecfrmc_renamexf, & + lspectooa_renamexf = lspectooa_renamexf, & + lspectooc_renamexf = lspectooc_renamexf, & + igrow_shrink_renamexf = igrow_shrink_renamexf, & + ixferable_all_renamexf = ixferable_all_renamexf, & + cnst_name_in = cnst_name, & + cnst_name_cw_in = cnst_name_cw, & + pi = pi, & + amRoot = masterproc, & + iulog_in = iulog, & + errmsg = errmsg, & + errflg = errflg ) + + if (errflg /= 0) then + call endrun('modal_aero_rename_cam_init: '//trim(errmsg)) + end if + + end subroutine modal_aero_rename_cam_init !---------------------------------------------------------------------- ! private methods -- renaming-pair resolution (verbatim from the original ! modal_aero_rename init routines; cnst_name matching is host-specific) !---------------------------------------------------------------------- - subroutine modal_aero_rename_no_acc_crs_init + subroutine modal_aero_rename_no_acc_crs_init ! ! computes pointers for species transfer during aerosol renaming -! (a2 --> a1 transfer) +! (a2 --> a1 transfer) ! transfers include number_a, number_c, mass_a, mass_c and -! water_a +! water_a ! ! local variables - integer :: ipair, iq, iqfrm, iqtoo - integer :: lsfrma, lsfrmc, lstooa, lstooc, lunout - integer :: mfrm, mtoo - integer :: n1, n2, nspec - integer :: nchfrma, nchfrmc, nchfrmskip, nchtooa, nchtooc, nchtooskip + integer :: ipair, iq, iqfrm, iqtoo + integer :: lsfrma, lsfrmc, lstooa, lstooc, lunout + integer :: mfrm, mtoo + integer :: n1, n2, nspec + integer :: nchfrma, nchfrmc, nchfrmskip, nchtooa, nchtooc, nchtooskip - lunout = iulog + lunout = iulog ! ! define "from mode" and "to mode" for each tail-xfer pairing -! currently just a2-->a1 +! currently just a2-->a1 ! - n1 = modeptr_accum - n2 = modeptr_aitken - if ((n1 .gt. 0) .and. (n2 .gt. 0)) then - npair_renamexf = 1 - modefrm_renamexf(1) = n2 - modetoo_renamexf(1) = n1 - else - npair_renamexf = 0 - return - end if + n1 = modeptr_accum + n2 = modeptr_aitken + if ((n1 .gt. 0) .and. (n2 .gt. 0)) then + npair_renamexf = 1 + modefrm_renamexf(1) = n2 + modetoo_renamexf(1) = n1 + else + npair_renamexf = 0 + return + end if ! ! define species involved in each tail-xfer pairing -! (include aerosol water) +! (include aerosol water) ! -aa_ipair: do ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(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 + aa_ipair: do ipair = 1, npair_renamexf + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(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 renaming - cycle aa_iqfrm + cycle aa_iqfrm ! lsfrma = lwaterptr_amode(mfrm) ! lsfrmc = 0 ! lstooa = lwaterptr_amode(mtoo) ! lstooc = 0 - 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(lunout,9100) mfrm, iqfrm, lsfrma - call endrun( 'modal_aero_rename_init error aa' ) - end if - if ((lsfrmc < 1) .or. (lsfrmc > pcnst)) then - write(lunout,9102) mfrm, iqfrm, lsfrmc - call endrun( 'modal_aero_rename_init error bb' ) - end if - - - if (iqfrm > 0) then - nchfrma = len( trim( cnst_name(lsfrma) ) ) - nchfrmskip + 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(lunout,9100) mfrm, iqfrm, lsfrma + call endrun( 'modal_aero_rename_init error aa' ) + end if + if ((lsfrmc < 1) .or. (lsfrmc > pcnst)) then + write(lunout,9102) mfrm, iqfrm, lsfrmc + call endrun( 'modal_aero_rename_init error bb' ) + end if + + if (iqfrm > 0) then + nchfrma = len( trim( cnst_name(lsfrma) ) ) - nchfrmskip ! find "too" species having same lspectype_amode as the "frm" species ! AND same cnst_name (except for last 1/2/3 characters which are the mode index) - do iqtoo = 1, nspec_amode(mtoo) -! if ( lspectype_amode(iqtoo,mtoo) .eq. & -! lspectype_amode(iqfrm,mfrm) ) then - 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 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(lunout,9104) mfrm, iqfrm, lsfrma, iqtoo, lstooa - call endrun( 'modal_aero_rename_init error cc' ) - end if - if ((lstooc == 0) .and. (iqfrm /= 0)) then - write(lunout,9104) mfrm, iqfrm, lsfrmc, iqtoo, lstooc - call endrun( 'modal_aero_rename_init error dd' ) - end if - - nspec = nspec + 1 - lspecfrma_renamexf(nspec,ipair) = lsfrma - lspectooa_renamexf(nspec,ipair) = lstooa - lspecfrmc_renamexf(nspec,ipair) = lsfrmc - lspectooc_renamexf(nspec,ipair) = lstooc - end do aa_iqfrm - - nspecfrm_renamexf(ipair) = nspec - end do aa_ipair - -9100 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & - 'lspecfrma out of range' / & - 'modefrm, ispecfrm, lspecfrma =', 3i6 / ) -9102 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & - 'lspecfrmc out of range' / & - 'modefrm, ispecfrm, lspecfrmc =', 3i6 / ) -9104 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & - 'lspectooa out of range' / & - 'modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 5i6 / ) -9106 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & - 'lspectooc out of range' / & - 'modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 5i6 / ) + do iqtoo = 1, nspec_amode(mtoo) +! if ( lspectype_amode(iqtoo,mtoo) .eq. & +! lspectype_amode(iqfrm,mfrm) ) then + 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 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(lunout,9104) mfrm, iqfrm, lsfrma, iqtoo, lstooa + call endrun( 'modal_aero_rename_init error cc' ) + end if + if ((lstooc == 0) .and. (iqfrm /= 0)) then + write(lunout,9104) mfrm, iqfrm, lsfrmc, iqtoo, lstooc + call endrun( 'modal_aero_rename_init error dd' ) + end if + + nspec = nspec + 1 + lspecfrma_renamexf(nspec,ipair) = lsfrma + lspectooa_renamexf(nspec,ipair) = lstooa + lspecfrmc_renamexf(nspec,ipair) = lsfrmc + lspectooc_renamexf(nspec,ipair) = lstooc + end do aa_iqfrm + + nspecfrm_renamexf(ipair) = nspec + end do aa_ipair + +9100 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & + 'lspecfrma out of range' / & + 'modefrm, ispecfrm, lspecfrma =', 3i6 / ) +9102 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & + 'lspecfrmc out of range' / & + 'modefrm, ispecfrm, lspecfrmc =', 3i6 / ) +9104 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & + 'lspectooa out of range' / & + 'modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 5i6 / ) +9106 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / & + 'lspectooc out of range' / & + 'modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 5i6 / ) ! ! output results ! - if ( masterproc ) then - - write(lunout,9310) - - do 2900 ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - write(lunout,9320) ipair, mfrm, mtoo - - do iq = 1, nspecfrm_renamexf(ipair) - lsfrma = lspecfrma_renamexf(iq,ipair) - lstooa = lspectooa_renamexf(iq,ipair) - lsfrmc = lspecfrmc_renamexf(iq,ipair) - lstooc = lspectooc_renamexf(iq,ipair) - if (lstooa .gt. 0) then - write(lunout,9330) lsfrma, cnst_name(lsfrma), & - lstooa, cnst_name(lstooa) - else - write(lunout,9340) lsfrma, cnst_name(lsfrma) - end if - if (lstooc .gt. 0) then - write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc), & - lstooc, cnst_name_cw(lstooc) - else if (lsfrmc .gt. 0) then - write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc) - else - write(lunout,9350) - end if - end do - -2900 continue - write(lunout,*) - - end if ! ( masterproc ) - -9310 format( / 'subr. modal_aero_rename_no_acc_crs_init' ) -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' ) - - end subroutine modal_aero_rename_no_acc_crs_init - - subroutine modal_aero_rename_acc_crs_init + if ( masterproc ) then + + write(lunout,9310) + + do 2900 ipair = 1, npair_renamexf + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(ipair) + write(lunout,9320) ipair, mfrm, mtoo + + do iq = 1, nspecfrm_renamexf(ipair) + lsfrma = lspecfrma_renamexf(iq,ipair) + lstooa = lspectooa_renamexf(iq,ipair) + lsfrmc = lspecfrmc_renamexf(iq,ipair) + lstooc = lspectooc_renamexf(iq,ipair) + if (lstooa .gt. 0) then + write(lunout,9330) lsfrma, cnst_name(lsfrma), & + lstooa, cnst_name(lstooa) + else + write(lunout,9340) lsfrma, cnst_name(lsfrma) + end if + if (lstooc .gt. 0) then + write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc), & + lstooc, cnst_name_cw(lstooc) + else if (lsfrmc .gt. 0) then + write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc) + else + write(lunout,9350) + end if + end do + +2900 continue + write(lunout,*) + + end if ! ( masterproc ) + +9310 format( / 'subr. modal_aero_rename_no_acc_crs_init' ) +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' ) + + end subroutine modal_aero_rename_no_acc_crs_init + + subroutine modal_aero_rename_acc_crs_init ! ! computes pointers for species transfer during aerosol renaming -! (a2 --> a1 transfer) +! (a2 --> a1 transfer) ! transfers include number_a, number_c, mass_a, mass_c and -! water_a +! water_a ! ! local variables - integer :: i, ipair, iq, iqfrm, iqtooa, iqtooc, itmpa - integer :: l, lsfrma, lsfrmc, lstooa, lstooc, lunout - integer :: mfrm, mtoo - integer :: n1, n2, nspec - integer :: nch_lfrm, nch_ltoo, nch_mfrmid, nch_mtooid + integer :: i, ipair, iq, iqfrm, iqtooa, iqtooc, itmpa + integer :: l, lsfrma, lsfrmc, lstooa, lstooc, lunout + integer :: mfrm, mtoo + integer :: n1, n2, nspec + integer :: nch_lfrm, nch_ltoo, nch_mfrmid, nch_mtooid - real (r8) :: frelax + real (r8) :: frelax - lunout = iulog + lunout = iulog ! ! define "from mode" and "to mode" for each tail-xfer pairing -! using the values in ipair_select_renamexf(:) +! using the values in ipair_select_renamexf(:) ! - npair_renamexf = 0 - do ipair = 1, maxpair_renamexf - itmpa = ipair_select_renamexf(ipair) - if (itmpa == 0) then - exit - else if (itmpa == 2001) then !both mam4 and mam5 - mfrm = modeptr_aitken - mtoo = modeptr_accum - igrow_shrink_renamexf(ipair) = 1 - ixferable_all_needed_renamexf(ipair) = 1 - strat_only_renamexf(ipair) = .false. - else if (itmpa == 1003) then - mfrm = modeptr_accum - mtoo = modeptr_coarse - igrow_shrink_renamexf(ipair) = 1 - ixferable_all_needed_renamexf(ipair) = 0 - strat_only_renamexf(ipair) = .true. - else if (itmpa == 1005) then - mfrm = modeptr_accum - mtoo = modeptr_stracoar - igrow_shrink_renamexf(ipair) = 1 - ixferable_all_needed_renamexf(ipair) = 0 - strat_only_renamexf(ipair) = .true. - else if (itmpa == 3001) then - mfrm = modeptr_coarse - mtoo = modeptr_accum - igrow_shrink_renamexf(ipair) = -1 - ixferable_all_needed_renamexf(ipair) = 0 - strat_only_renamexf(ipair) = .true. - else if (itmpa == 5001) then - mfrm = modeptr_stracoar - mtoo = modeptr_accum - igrow_shrink_renamexf(ipair) = -1 - ixferable_all_needed_renamexf(ipair) = 0 - strat_only_renamexf(ipair) = .true. - else - write(lunout,'(/2a,3(1x,i12))') & - '*** subr. modal_aero_rename_acc_crs_init', & - 'bad ipair_select_renamexf', ipair, itmpa - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - - do i = 1, ipair-1 - if (itmpa .eq. ipair_select_renamexf(i)) then - write(lunout,'(/2a/10(1x,i12))') & - '*** subr. modal_aero_rename_acc_crs_init', & - 'duplicates in ipair_select_renamexf', & - ipair_select_renamexf(1:ipair) - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - end do - - if ( (mfrm .ge. 1) .and. (mfrm .le. ntot_amode) .and. & - (mtoo .ge. 1) .and. (mtoo .le. ntot_amode) ) then - npair_renamexf = ipair - modefrm_renamexf(ipair) = mfrm - modetoo_renamexf(ipair) = mtoo - else - write(lunout,'(/2a,3(1x,i12))') & - '*** subr. modal_aero_rename_acc_crs_init', & - 'bad mfrm or mtoo', ipair, mfrm, mtoo - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - end do ! ipair - - if (npair_renamexf .le. 0) then - write(lunout,'(/a/a,3(1x,i12))') & - '*** subr. modal_aero_rename_acc_crs_init -- npair_renamexf = 0' - return - end if + npair_renamexf = 0 + do ipair = 1, maxpair_renamexf + itmpa = ipair_select_renamexf(ipair) + if (itmpa == 0) then + exit + else if (itmpa == 2001) then !both mam4 and mam5 + mfrm = modeptr_aitken + mtoo = modeptr_accum + igrow_shrink_renamexf(ipair) = 1 + ixferable_all_needed_renamexf(ipair) = 1 + strat_only_renamexf(ipair) = .false. + else if (itmpa == 1003) then + mfrm = modeptr_accum + mtoo = modeptr_coarse + igrow_shrink_renamexf(ipair) = 1 + ixferable_all_needed_renamexf(ipair) = 0 + strat_only_renamexf(ipair) = .true. + else if (itmpa == 1005) then + mfrm = modeptr_accum + mtoo = modeptr_stracoar + igrow_shrink_renamexf(ipair) = 1 + ixferable_all_needed_renamexf(ipair) = 0 + strat_only_renamexf(ipair) = .true. + else if (itmpa == 3001) then + mfrm = modeptr_coarse + mtoo = modeptr_accum + igrow_shrink_renamexf(ipair) = -1 + ixferable_all_needed_renamexf(ipair) = 0 + strat_only_renamexf(ipair) = .true. + else if (itmpa == 5001) then + mfrm = modeptr_stracoar + mtoo = modeptr_accum + igrow_shrink_renamexf(ipair) = -1 + ixferable_all_needed_renamexf(ipair) = 0 + strat_only_renamexf(ipair) = .true. + else + write(lunout,'(/2a,3(1x,i12))') & + '*** subr. modal_aero_rename_acc_crs_init', & + 'bad ipair_select_renamexf', ipair, itmpa + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + + do i = 1, ipair-1 + if (itmpa .eq. ipair_select_renamexf(i)) then + write(lunout,'(/2a/10(1x,i12))') & + '*** subr. modal_aero_rename_acc_crs_init', & + 'duplicates in ipair_select_renamexf', & + ipair_select_renamexf(1:ipair) + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + end do + + if ( (mfrm .ge. 1) .and. (mfrm .le. ntot_amode) .and. & + (mtoo .ge. 1) .and. (mtoo .le. ntot_amode) ) then + npair_renamexf = ipair + modefrm_renamexf(ipair) = mfrm + modetoo_renamexf(ipair) = mtoo + else + write(lunout,'(/2a,3(1x,i12))') & + '*** subr. modal_aero_rename_acc_crs_init', & + 'bad mfrm or mtoo', ipair, mfrm, mtoo + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + end do ! ipair + + if (npair_renamexf .le. 0) then + write(lunout,'(/a/a,3(1x,i12))') & + '*** subr. modal_aero_rename_acc_crs_init -- npair_renamexf = 0' + return + end if ! ! define species involved in each tail-xfer pairing -! (include aerosol water) +! (include aerosol water) ! - do 1900 ipair = 1, npair_renamexf - mfrm = modefrm_renamexf(ipair) - mtoo = modetoo_renamexf(ipair) - ixferable_all_renamexf(ipair) = 1 - - if (mfrm < 10) then - nch_mfrmid = 1 - else if (mfrm < 100) then - nch_mfrmid = 2 - else - nch_mfrmid = 3 - end if - if (mtoo < 10) then - nch_mtooid = 1 - else if (mtoo < 100) then - nch_mtooid = 2 - else - nch_mtooid = 3 - end if - - nspec = 0 - do 1490 iqfrm = -1, nspec_amode(mfrm) - if (iqfrm .eq. -1) then - lsfrma = numptr_amode(mfrm) - lstooa = numptr_amode(mtoo) - lsfrmc = numptrcw_amode(mfrm) - lstooc = numptrcw_amode(mtoo) - else if (iqfrm .eq. 0) then + do 1900 ipair = 1, npair_renamexf + mfrm = modefrm_renamexf(ipair) + mtoo = modetoo_renamexf(ipair) + ixferable_all_renamexf(ipair) = 1 + + if (mfrm < 10) then + nch_mfrmid = 1 + else if (mfrm < 100) then + nch_mfrmid = 2 + else + nch_mfrmid = 3 + end if + if (mtoo < 10) then + nch_mtooid = 1 + else if (mtoo < 100) then + nch_mtooid = 2 + else + nch_mtooid = 3 + end if + + nspec = 0 + do 1490 iqfrm = -1, nspec_amode(mfrm) + if (iqfrm .eq. -1) then + lsfrma = numptr_amode(mfrm) + lstooa = numptr_amode(mtoo) + lsfrmc = numptrcw_amode(mfrm) + lstooc = numptrcw_amode(mtoo) + else if (iqfrm .eq. 0) then ! bypass transfer of aerosol water due to renaming - goto 1490 + goto 1490 ! lsfrma = lwaterptr_amode(mfrm) ! lsfrmc = 0 ! lstooa = lwaterptr_amode(mtoo) ! lstooc = 0 - else - lsfrma = lmassptr_amode(iqfrm,mfrm) - lsfrmc = lmassptrcw_amode(iqfrm,mfrm) - lstooa = 0 - lstooc = 0 - end if - - if ((lsfrma .lt. 1) .or. (lsfrma .gt. pcnst)) then - write(lunout,9100) ipair, mfrm, iqfrm, lsfrma - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - if (iqfrm .le. 0) goto 1430 - - if ((lsfrmc .lt. 1) .or. (lsfrmc .gt. pcnst)) then - write(lunout,9102) ipair, mfrm, iqfrm, lsfrmc - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if + else + lsfrma = lmassptr_amode(iqfrm,mfrm) + lsfrmc = lmassptrcw_amode(iqfrm,mfrm) + lstooa = 0 + lstooc = 0 + end if + + if ((lsfrma .lt. 1) .or. (lsfrma .gt. pcnst)) then + write(lunout,9100) ipair, mfrm, iqfrm, lsfrma + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + if (iqfrm .le. 0) goto 1430 + + if ((lsfrmc .lt. 1) .or. (lsfrmc .gt. pcnst)) then + write(lunout,9102) ipair, mfrm, iqfrm, lsfrmc + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if ! find "too" species having same name (except for mode number) as the "frm" species - nch_lfrm = len(trim(cnst_name(lsfrma))) - nch_mfrmid - iqtooa = -99 - do iq = 1, nspec_amode(mtoo) - l = lmassptr_amode(iq,mtoo) - if ((l .lt. 1) .or. (l .gt. pcnst)) cycle - nch_ltoo = len(trim(cnst_name(l))) - nch_mtooid - if ( cnst_name(lsfrma)(1:nch_lfrm) == & - cnst_name(l )(1:nch_ltoo) ) then - lstooa = l - iqtooa = iq - exit - end if - end do - - nch_lfrm = len(trim(cnst_name_cw(lsfrmc))) - nch_mfrmid - iqtooc = -99 - do iq = 1, nspec_amode(mtoo) - l = lmassptrcw_amode(iq,mtoo) - if ((l .lt. 1) .or. (l .gt. pcnst)) cycle - nch_ltoo = len(trim(cnst_name_cw(l))) - nch_mtooid - if ( cnst_name_cw(lsfrmc)(1:nch_lfrm) == & - cnst_name_cw(l )(1:nch_ltoo) ) then - lstooc = l - iqtooc = iq - exit - end if - end do - -1430 if ((lstooc .lt. 1) .or. (lstooc .gt. pcnst)) lstooc = 0 - if ((lstooa .lt. 1) .or. (lstooa .gt. pcnst)) lstooa = 0 - - if ((lstooa .eq. 0) .or. (lstooc .eq. 0)) then - if ( ( masterproc ) .or. & - ( (lstooa .ne. 0) .or. (lstooc .ne. 0) ) .or. & - ( ixferable_all_needed_renamexf(ipair) .gt. 0 ) ) then - if (lstooa .eq. 0) & - write(lunout,9104) trim(cnst_name(lsfrma)), & - ipair, mfrm, iqfrm, lsfrma, iqtooa, lstooa - if (lstooc .eq. 0) & - write(lunout,9106) trim(cnst_name_cw(lsfrmc)), & - ipair, mfrm, iqfrm, lsfrmc, iqtooc, lstooc - end if - if ((lstooa .ne. 0) .or. (lstooc .ne. 0)) then - write(lunout,9108) - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - if (ixferable_all_needed_renamexf(ipair) .gt. 0) then - write(lunout,9109) - call endrun( 'modal_aero_rename_acc_crs_init error' ) - end if - ixferable_all_renamexf(ipair) = 0 - if (iqfrm .gt. 0) then - ixferable_a_renamexf(iqfrm,ipair) = 0 - ixferable_c_renamexf(iqfrm,ipair) = 0 - end if - else - nspec = nspec + 1 - lspecfrma_renamexf(nspec,ipair) = lsfrma - lspectooa_renamexf(nspec,ipair) = lstooa - lspecfrmc_renamexf(nspec,ipair) = lsfrmc - lspectooc_renamexf(nspec,ipair) = lstooc - if (iqfrm .gt. 0) then - ixferable_a_renamexf(iqfrm,ipair) = 1 - ixferable_c_renamexf(iqfrm,ipair) = 1 - end if - end if -1490 continue - - nspecfrm_renamexf(ipair) = nspec -1900 continue - -9100 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'lspecfrma out of range' / & - 'ipair, modefrm, ispecfrm, lspecfrma =', 4i6 ) -9102 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'lspecfrmc out of range' / & - 'ipair, modefrm, ispecfrm, lspecfrmc =', 4i6 ) -9104 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'lspectooa out of range for', 2x, a / & - 'ipair, modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 6i6 ) -9106 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'lspectooc out of range for', 2x, a / & - 'ipair, modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 6i6 ) -9108 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'only one of lspectooa and lspectooc is out of range' ) -9109 format( / '*** subr. modal_aero_rename_acc_crs_init' / & - 'all species must be xferable for this pair' ) - end subroutine modal_aero_rename_acc_crs_init - - end module modal_aero_rename_cam + nch_lfrm = len(trim(cnst_name(lsfrma))) - nch_mfrmid + iqtooa = -99 + do iq = 1, nspec_amode(mtoo) + l = lmassptr_amode(iq,mtoo) + if ((l .lt. 1) .or. (l .gt. pcnst)) cycle + nch_ltoo = len(trim(cnst_name(l))) - nch_mtooid + if ( cnst_name(lsfrma)(1:nch_lfrm) == & + cnst_name(l )(1:nch_ltoo) ) then + lstooa = l + iqtooa = iq + exit + end if + end do + + nch_lfrm = len(trim(cnst_name_cw(lsfrmc))) - nch_mfrmid + iqtooc = -99 + do iq = 1, nspec_amode(mtoo) + l = lmassptrcw_amode(iq,mtoo) + if ((l .lt. 1) .or. (l .gt. pcnst)) cycle + nch_ltoo = len(trim(cnst_name_cw(l))) - nch_mtooid + if ( cnst_name_cw(lsfrmc)(1:nch_lfrm) == & + cnst_name_cw(l )(1:nch_ltoo) ) then + lstooc = l + iqtooc = iq + exit + end if + end do + +1430 if ((lstooc .lt. 1) .or. (lstooc .gt. pcnst)) lstooc = 0 + if ((lstooa .lt. 1) .or. (lstooa .gt. pcnst)) lstooa = 0 + + if ((lstooa .eq. 0) .or. (lstooc .eq. 0)) then + if ( ( masterproc ) .or. & + ( (lstooa .ne. 0) .or. (lstooc .ne. 0) ) .or. & + ( ixferable_all_needed_renamexf(ipair) .gt. 0 ) ) then + if (lstooa .eq. 0) & + write(lunout,9104) trim(cnst_name(lsfrma)), & + ipair, mfrm, iqfrm, lsfrma, iqtooa, lstooa + if (lstooc .eq. 0) & + write(lunout,9106) trim(cnst_name_cw(lsfrmc)), & + ipair, mfrm, iqfrm, lsfrmc, iqtooc, lstooc + end if + if ((lstooa .ne. 0) .or. (lstooc .ne. 0)) then + write(lunout,9108) + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + if (ixferable_all_needed_renamexf(ipair) .gt. 0) then + write(lunout,9109) + call endrun( 'modal_aero_rename_acc_crs_init error' ) + end if + ixferable_all_renamexf(ipair) = 0 + if (iqfrm .gt. 0) then + ixferable_a_renamexf(iqfrm,ipair) = 0 + ixferable_c_renamexf(iqfrm,ipair) = 0 + end if + else + nspec = nspec + 1 + lspecfrma_renamexf(nspec,ipair) = lsfrma + lspectooa_renamexf(nspec,ipair) = lstooa + lspecfrmc_renamexf(nspec,ipair) = lsfrmc + lspectooc_renamexf(nspec,ipair) = lstooc + if (iqfrm .gt. 0) then + ixferable_a_renamexf(iqfrm,ipair) = 1 + ixferable_c_renamexf(iqfrm,ipair) = 1 + end if + end if +1490 continue + + nspecfrm_renamexf(ipair) = nspec +1900 continue + +9100 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'lspecfrma out of range' / & + 'ipair, modefrm, ispecfrm, lspecfrma =', 4i6 ) +9102 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'lspecfrmc out of range' / & + 'ipair, modefrm, ispecfrm, lspecfrmc =', 4i6 ) +9104 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'lspectooa out of range for', 2x, a / & + 'ipair, modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 6i6 ) +9106 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'lspectooc out of range for', 2x, a / & + 'ipair, modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 6i6 ) +9108 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'only one of lspectooa and lspectooc is out of range' ) +9109 format( / '*** subr. modal_aero_rename_acc_crs_init' / & + 'all species must be xferable for this pair' ) + end subroutine modal_aero_rename_acc_crs_init + +end module modal_aero_rename_cam diff --git a/src/chemistry/utils/modal_aero_calcsize_cam.F90 b/src/chemistry/utils/modal_aero_calcsize_cam.F90 index c5fde99dd0..7ca1a0cb14 100644 --- a/src/chemistry/utils/modal_aero_calcsize_cam.F90 +++ b/src/chemistry/utils/modal_aero_calcsize_cam.F90 @@ -1,686 +1,684 @@ module modal_aero_calcsize_cam ! CAM wrapper for modal_aero_calcsize. -use shr_kind_mod, only: r8 => shr_kind_r8 -use spmd_utils, only: masterproc -use physconst, only: pi, rhoh2o, gravit + use shr_kind_mod, only: r8 => shr_kind_r8 + use spmd_utils, only: masterproc + use physconst, only: pi, rhoh2o, gravit -use ppgrid, only: pcols, pver -use physics_types, only: physics_state, physics_ptend -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, & - pbuf_get_field, pbuf_add_field, pbuf_set_field, dtype_r8 + use ppgrid, only: pcols, pver + use physics_types, only: physics_state, physics_ptend + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, & + pbuf_get_field, pbuf_add_field, pbuf_set_field, dtype_r8 -use phys_control, only: phys_getopts -use aerosol_properties_mod, only: aerosol_properties -use aerosol_state_mod, only: aerosol_state + use phys_control, only: phys_getopts + use aerosol_properties_mod, only: aerosol_properties + use aerosol_state_mod, only: aerosol_state -use cam_logfile, only: iulog -use cam_abortutils, only: endrun -use cam_history, only: addfld, add_default, fieldname_len, horiz_only, outfld -use constituents, only: pcnst, cnst_name -use modal_aero_data, only: modal_strat_sulfate + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use cam_history, only: addfld, add_default, fieldname_len, horiz_only, outfld + use constituents, only: pcnst, cnst_name + use modal_aero_data, only: modal_strat_sulfate -use ref_pres, only: top_lev => clim_modal_aero_top_lev + use ref_pres, only: top_lev => clim_modal_aero_top_lev #ifdef MODAL_AERO -use modal_aero_data, only: ntot_amode, nspec_amode, nspec_max, & - numptr_amode, & - alnsg_amode, & - voltonumbhi_amode, voltonumblo_amode, & - dgnum_amode, dgnumhi_amode, dgnumlo_amode + use modal_aero_data, only: ntot_amode, nspec_amode, nspec_max, & + numptr_amode, & + alnsg_amode, & + voltonumbhi_amode, voltonumblo_amode, & + dgnum_amode, dgnumhi_amode, dgnumlo_amode -use modal_aero_data, only: numptrcw_amode, mprognum_amode, qqcw_get_field, lmassptrcw_amode, & - lmassptr_amode, modeptr_accum, modeptr_aitken, & - specmw_amode, specdens_amode, voltonumb_amode, & - cnst_name_cw + use modal_aero_data, only: numptrcw_amode, mprognum_amode, qqcw_get_field, lmassptrcw_amode, & + lmassptr_amode, modeptr_accum, modeptr_aitken, & + specmw_amode, specdens_amode, voltonumb_amode, & + cnst_name_cw -use modal_aero_rename_cam, only: lspectooa_renamexf, lspecfrma_renamexf, lspectooc_renamexf, lspecfrmc_renamexf, & - modetoo_renamexf, nspecfrm_renamexf, npair_renamexf, modefrm_renamexf + use modal_aero_rename_cam, only: lspectooa_renamexf, lspecfrma_renamexf, lspectooc_renamexf, lspecfrmc_renamexf, & + modetoo_renamexf, nspecfrm_renamexf, npair_renamexf, modefrm_renamexf #endif -use modal_aero_calcsize, only: modal_aero_calcsize_run, modal_aero_calcdry_run, calcsize_nsrflx + use modal_aero_calcsize, only: modal_aero_calcsize_run, modal_aero_calcdry_run, calcsize_nsrflx -implicit none -private -save + implicit none + private + save -public modal_aero_calcsize_init, modal_aero_calcsize_sub, modal_aero_calcsize_diag -public :: modal_aero_calcsize_reg + public modal_aero_calcsize_init, modal_aero_calcsize_sub, modal_aero_calcsize_diag + public :: modal_aero_calcsize_reg -logical :: do_adjust_default -logical :: do_aitacc_transfer_default - -integer :: dgnum_idx = -1 -integer :: hygro_idx = -1 -integer :: dryvol_idx = -1 -integer :: dryrad_idx = -1 -integer :: drymass_idx = -1 -integer :: so4dryvol_idx = -1 -integer :: naer_idx = -1 -integer :: sulfeq_idx = -1 + logical :: do_adjust_default + logical :: do_aitacc_transfer_default + integer :: dgnum_idx = -1 + integer :: hygro_idx = -1 + integer :: dryvol_idx = -1 + integer :: dryrad_idx = -1 + integer :: drymass_idx = -1 + integer :: so4dryvol_idx = -1 + integer :: naer_idx = -1 + integer :: sulfeq_idx = -1 !=============================================================================== contains !=============================================================================== -subroutine modal_aero_calcsize_reg() - use radiative_aerosol, only: rad_aer_get_info + subroutine modal_aero_calcsize_reg() + use radiative_aerosol, only: rad_aer_get_info - integer :: nmodes + integer :: nmodes - call rad_aer_get_info(0, nmodes=nmodes) + call rad_aer_get_info(0, nmodes=nmodes) - call pbuf_add_field('DGNUM', 'global', dtype_r8, (/pcols, pver, nmodes/), dgnum_idx) + call pbuf_add_field('DGNUM', 'global', dtype_r8, (/pcols, pver, nmodes/), dgnum_idx) - call pbuf_add_field('HYGRO', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), hygro_idx) - call pbuf_add_field('DRYVOL', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), dryvol_idx) - call pbuf_add_field('DRYRAD', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), dryrad_idx) - call pbuf_add_field('DRYMASS', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), drymass_idx) - call pbuf_add_field('SO4DRYVOL', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), so4dryvol_idx) - call pbuf_add_field('NAER', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), naer_idx) + call pbuf_add_field('HYGRO', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), hygro_idx) + call pbuf_add_field('DRYVOL', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), dryvol_idx) + call pbuf_add_field('DRYRAD', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), dryrad_idx) + call pbuf_add_field('DRYMASS', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), drymass_idx) + call pbuf_add_field('SO4DRYVOL', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), so4dryvol_idx) + call pbuf_add_field('NAER', 'phys_pkg', dtype_r8, (/pcols,pver,nmodes/), naer_idx) -end subroutine modal_aero_calcsize_reg + end subroutine modal_aero_calcsize_reg !=============================================================================== !=============================================================================== -subroutine modal_aero_calcsize_init(pbuf2d) - use time_manager, only: is_first_step - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! set do_adjust_default and do_aitacc_transfer_default flags - ! create history fields for column tendencies associated with - ! modal_aero_calcsize - ! - ! Author: R. Easter - ! - !----------------------------------------------------------------------- - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - ! local - integer :: ipair, iq - integer :: jac - integer :: lsfrm, lstoo - integer :: n, nacc, nait - logical :: history_aerosol - - character(len=fieldname_len) :: tmpnamea, tmpnameb - character(len=fieldname_len+3) :: fieldname - character(128) :: long_name - character(8) :: unit - !----------------------------------------------------------------------- - - call phys_getopts(history_aerosol_out=history_aerosol) - - if (is_first_step()) then - call pbuf_set_field(pbuf2d, dgnum_idx, 0.0_r8) - endif + subroutine modal_aero_calcsize_init(pbuf2d) + use time_manager, only: is_first_step + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! set do_adjust_default and do_aitacc_transfer_default flags + ! create history fields for column tendencies associated with + ! modal_aero_calcsize + ! + ! Author: R. Easter + ! + !----------------------------------------------------------------------- + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + ! local + integer :: ipair, iq + integer :: jac + integer :: lsfrm, lstoo + integer :: n, nacc, nait + logical :: history_aerosol + + character(len=fieldname_len) :: tmpnamea, tmpnameb + character(len=fieldname_len+3) :: fieldname + character(128) :: long_name + character(8) :: unit + !----------------------------------------------------------------------- + + call phys_getopts(history_aerosol_out=history_aerosol) + + if (is_first_step()) then + call pbuf_set_field(pbuf2d, dgnum_idx, 0.0_r8) + endif #ifndef MODAL_AERO - do_adjust_default = .false. - do_aitacc_transfer_default = .false. + do_adjust_default = .false. + do_aitacc_transfer_default = .false. #else - do_adjust_default = .true. - - nait = modeptr_aitken - nacc = modeptr_accum - do_aitacc_transfer_default = .false. - if ((modeptr_aitken > 0) .and. & - (modeptr_accum > 0) .and. & - (modeptr_aitken /= modeptr_accum)) then - do_aitacc_transfer_default = .true. - if (mprognum_amode(nait) <= 0) do_aitacc_transfer_default = .false. - if (mprognum_amode(nacc) <= 0) do_aitacc_transfer_default = .false. - end if - - if ( .not. do_adjust_default ) return - - ! define history fields for number-adjust source-sink for all modes - do n = 1, ntot_amode - if (mprognum_amode(n) <= 0) cycle - - do jac = 1, 2 - if (jac == 1) then - tmpnamea = cnst_name(numptr_amode(n)) - else - tmpnamea = cnst_name_cw(numptrcw_amode(n)) - end if - unit = '#/m2/s' - fieldname = trim(tmpnamea) // '_sfcsiz1' - long_name = trim(tmpnamea) // ' calcsize number-adjust column source' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + do_adjust_default = .true. + + nait = modeptr_aitken + nacc = modeptr_accum + do_aitacc_transfer_default = .false. + if ((modeptr_aitken > 0) .and. & + (modeptr_accum > 0) .and. & + (modeptr_aitken /= modeptr_accum)) then + do_aitacc_transfer_default = .true. + if (mprognum_amode(nait) <= 0) do_aitacc_transfer_default = .false. + if (mprognum_amode(nacc) <= 0) do_aitacc_transfer_default = .false. + end if - fieldname = trim(tmpnamea) // '_sfcsiz2' - long_name = trim(tmpnamea) // ' calcsize number-adjust column sink' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(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 iq = 1, nspecfrm_renamexf(ipair) - - ! jac=1 does interstitial ("_a"); jac=2 does activated ("_c"); - do jac = 1, 2 - - 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 - - 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 + if ( .not. do_adjust_default ) return - 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, horiz_only, 'A', unit, long_name ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + ! define history fields for number-adjust source-sink for all modes + do n = 1, ntot_amode + if (mprognum_amode(n) <= 0) cycle - fieldname = trim(tmpnameb) // '_sfcsiz3' - long_name = trim(tmpnameb) // ' calcsize aitken-to-accum adjust column tendency' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + do jac = 1, 2 + if (jac == 1) then + tmpnamea = cnst_name(numptr_amode(n)) + else + tmpnamea = cnst_name_cw(numptrcw_amode(n)) + end if + unit = '#/m2/s' + fieldname = trim(tmpnamea) // '_sfcsiz1' + long_name = trim(tmpnamea) // ' calcsize number-adjust column source' + call addfld( fieldname, horiz_only, 'A', unit, long_name ) + 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, horiz_only, 'A', unit, long_name ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + fieldname = trim(tmpnamea) // '_sfcsiz2' + long_name = trim(tmpnamea) // ' calcsize number-adjust column sink' + call addfld( fieldname, horiz_only, 'A', unit, long_name ) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + end do ! jac = ... + end do ! n = ... - fieldname = trim(tmpnameb) // '_sfcsiz4' - long_name = trim(tmpnameb) // ' calcsize accum-to-aitken adjust column tendency' - call addfld( fieldname, horiz_only, 'A', unit, long_name ) - if (history_aerosol) then - call add_default(fieldname, 1, ' ') - end if - if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + 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 - end do ! jac = ... - end do ! iq = ... + ! define history fields for aitken-accum transfer + do iq = 1, nspecfrm_renamexf(ipair) + + ! jac=1 does interstitial ("_a"); jac=2 does activated ("_c"); + do jac = 1, 2 + + 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 + + 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, horiz_only, 'A', unit, long_name ) + 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, horiz_only, 'A', unit, long_name ) + 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, horiz_only, 'A', unit, long_name ) + 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, horiz_only, 'A', unit, long_name ) + if (history_aerosol) then + call add_default(fieldname, 1, ' ') + end if + if ( masterproc ) write(*,'(2a)') 'calcsize addfld - ', fieldname + + end do ! jac = ... + end do ! iq = ... #endif -end subroutine modal_aero_calcsize_init + end subroutine modal_aero_calcsize_init !=============================================================================== -subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_state, & - do_adjust_in, do_aitacc_transfer_in) - ! arguments - type(physics_state), target, intent(in) :: state - type(physics_ptend), target, intent(inout) :: ptend - real(r8), intent(in) :: deltat - type(physics_buffer_desc), pointer :: pbuf(:) - class(aerosol_properties), intent(in), target :: aero_props - class(aerosol_state), intent(in) :: aero_state + subroutine modal_aero_calcsize_sub(state, ptend, deltat, pbuf, aero_props, aero_state, & + do_adjust_in, do_aitacc_transfer_in) + ! arguments + type(physics_state), target, intent(in) :: state + type(physics_ptend), target, intent(inout) :: ptend + real(r8), intent(in) :: deltat + type(physics_buffer_desc), pointer :: pbuf(:) + class(aerosol_properties), intent(in), target :: aero_props + class(aerosol_state), intent(in) :: aero_state - logical, optional :: do_adjust_in - logical, optional :: do_aitacc_transfer_in + logical, optional :: do_adjust_in + logical, optional :: do_aitacc_transfer_in #ifdef MODAL_AERO - ! local - logical :: do_adjust - logical :: do_aitacc_transfer - - integer :: lchnk, ncol - integer :: i, ipair, iq, jac, k, l, lc, lsfrm, lstoo, n - real(r8), pointer :: dgncur_a(:,:,:) - real(r8), pointer :: fldcw(:,:) - - character(len=fieldname_len) :: tmpnamea, tmpnameb - character(len=fieldname_len+3) :: fieldname - - ! Work arrays for portable routine interface - real(r8), allocatable :: q_local(:,:,:) ! interstitial species (ncol,pver,pcnst) - real(r8), allocatable :: q_cw_local(:,:,:) ! cloud-borne species (ncol,pver,pcnst) - real(r8), allocatable :: dqdt_local(:,:,:) ! interstitial tendencies (ncol,pver,pcnst) - real(r8), allocatable :: dqdt_cw_local(:,:,:) ! cloud-borne tendencies (ncol,pver,pcnst) - logical, allocatable :: dotend_local(:) ! interstitial tendency flags (pcnst) - logical, allocatable :: dotend_cw_local(:) ! cloud-borne tendency flags (pcnst) - real(r8), allocatable :: qsrflx(:,:,:,:) ! diagnostic flux (ncol,pcnst,calcsize_nsrflx,2) - real(r8) :: qsrflx_pcols(pcols) ! work array for outfld - - character(len=512) :: errmsg - integer :: errflg - - !----------------------------------------------------------------------- - - if (present(do_adjust_in)) then - do_adjust = do_adjust_in - else - do_adjust = do_adjust_default - end if - - if (present(do_aitacc_transfer_in)) then - do_aitacc_transfer = do_aitacc_transfer_in - else - do_aitacc_transfer = do_aitacc_transfer_default - end if - - lchnk = state%lchnk - ncol = state%ncol - - ! Get dgnum from pbuf - call pbuf_get_field(pbuf, dgnum_idx, dgncur_a) - - ! Allocate work arrays - allocate(q_local(ncol, pver, pcnst)) - allocate(q_cw_local(ncol, pver, pcnst)) - allocate(dqdt_local(ncol, pver, pcnst)) - allocate(dqdt_cw_local(ncol, pver, pcnst)) - allocate(dotend_local(pcnst)) - allocate(dotend_cw_local(pcnst)) - allocate(qsrflx(ncol, pcnst, calcsize_nsrflx, 2)) - - ! Copy interstitial species from state%q - q_local(:,:,:) = state%q(:ncol,:,:) - - ! Gather cloud-borne species from qqcw into flat array - q_cw_local(:,:,:) = 0.0_r8 - do n = 1, ntot_amode - do l = 1, nspec_amode(n) - lc = lmassptrcw_amode(l,n) + ! local + logical :: do_adjust + logical :: do_aitacc_transfer + + integer :: lchnk, ncol + integer :: i, ipair, iq, jac, k, l, lc, lsfrm, lstoo, n + real(r8), pointer :: dgncur_a(:,:,:) + real(r8), pointer :: fldcw(:,:) + + character(len=fieldname_len) :: tmpnamea, tmpnameb + character(len=fieldname_len+3) :: fieldname + + ! Work arrays for portable routine interface + real(r8), allocatable :: q_local(:,:,:) ! interstitial species (ncol,pver,pcnst) + real(r8), allocatable :: q_cw_local(:,:,:) ! cloud-borne species (ncol,pver,pcnst) + real(r8), allocatable :: dqdt_local(:,:,:) ! interstitial tendencies (ncol,pver,pcnst) + real(r8), allocatable :: dqdt_cw_local(:,:,:) ! cloud-borne tendencies (ncol,pver,pcnst) + logical, allocatable :: dotend_local(:) ! interstitial tendency flags (pcnst) + logical, allocatable :: dotend_cw_local(:) ! cloud-borne tendency flags (pcnst) + real(r8), allocatable :: qsrflx(:,:,:,:) ! diagnostic flux (ncol,pcnst,calcsize_nsrflx,2) + real(r8) :: qsrflx_pcols(pcols) ! work array for outfld + + character(len=512) :: errmsg + integer :: errflg + + !----------------------------------------------------------------------- + + if (present(do_adjust_in)) then + do_adjust = do_adjust_in + else + do_adjust = do_adjust_default + end if + + if (present(do_aitacc_transfer_in)) then + do_aitacc_transfer = do_aitacc_transfer_in + else + do_aitacc_transfer = do_aitacc_transfer_default + end if + + lchnk = state%lchnk + ncol = state%ncol + + ! Get dgnum from pbuf + call pbuf_get_field(pbuf, dgnum_idx, dgncur_a) + + ! Allocate work arrays + allocate(q_local(ncol, pver, pcnst)) + allocate(q_cw_local(ncol, pver, pcnst)) + allocate(dqdt_local(ncol, pver, pcnst)) + allocate(dqdt_cw_local(ncol, pver, pcnst)) + allocate(dotend_local(pcnst)) + allocate(dotend_cw_local(pcnst)) + allocate(qsrflx(ncol, pcnst, calcsize_nsrflx, 2)) + + ! Copy interstitial species from state%q + q_local(:,:,:) = state%q(:ncol,:,:) + + ! Gather cloud-borne species from qqcw into flat array + q_cw_local(:,:,:) = 0.0_r8 + do n = 1, ntot_amode + do l = 1, nspec_amode(n) + lc = lmassptrcw_amode(l,n) + if (lc > 0) then + fldcw => qqcw_get_field(pbuf, lc, lchnk) + if (associated(fldcw)) q_cw_local(:ncol,:,lc) = fldcw(:ncol,:) + end if + end do + lc = numptrcw_amode(n) if (lc > 0) then - fldcw => qqcw_get_field(pbuf, lc, lchnk) + fldcw => qqcw_get_field(pbuf, lc, lchnk, .true.) if (associated(fldcw)) q_cw_local(:ncol,:,lc) = fldcw(:ncol,:) end if end do - lc = numptrcw_amode(n) - if (lc > 0) then - fldcw => qqcw_get_field(pbuf, lc, lchnk, .true.) - if (associated(fldcw)) q_cw_local(:ncol,:,lc) = fldcw(:ncol,:) - end if - end do - - ! Call portable science routine - call modal_aero_calcsize_run( & - ncol = ncol, & - pver = pver, & - deltat = deltat, & - top_lev = top_lev, & - ntot_amode = ntot_amode, & - nspec_amode = nspec_amode, & - nspec_max = nspec_max, & - dgnum_amode = dgnum_amode, & - dgnumlo_amode = dgnumlo_amode, & - dgnumhi_amode = dgnumhi_amode, & - alnsg_amode = alnsg_amode, & - voltonumb_amode = voltonumb_amode, & - voltonumblo_amode = voltonumblo_amode, & - voltonumbhi_amode = voltonumbhi_amode, & - specdens_amode = specdens_amode, & - mprognum_amode = mprognum_amode, & - modeptr_aitken = modeptr_aitken, & - modeptr_accum = modeptr_accum, & - lmassptr_amode = lmassptr_amode, & - numptr_amode = numptr_amode, & - lmassptrcw_amode = lmassptrcw_amode, & - numptrcw_amode = numptrcw_amode, & - pdel = state%pdel(:ncol,:), & - gravit = gravit, & - pi = pi, & - num_q = pcnst, & - q = q_local, & - q_cw = q_cw_local, & - do_adjust = do_adjust, & - do_aitacc_transfer = do_aitacc_transfer, & - npair_renamexf = npair_renamexf, & - nspecfrm_renamexf = nspecfrm_renamexf, & - modefrm_renamexf = modefrm_renamexf, & - modetoo_renamexf = modetoo_renamexf, & - lspecfrma_renamexf = lspecfrma_renamexf, & - lspectooa_renamexf = lspectooa_renamexf, & - lspecfrmc_renamexf = lspecfrmc_renamexf, & - lspectooc_renamexf = lspectooc_renamexf, & - dgncur_a = dgncur_a(:ncol,:,:), & - dqdt = dqdt_local, & - dqdt_cw = dqdt_cw_local, & - dotend = dotend_local, & - dotend_cw = dotend_cw_local, & - qsrflx = qsrflx, & - errmsg = errmsg, & - errflg = errflg) - - if (errflg /= 0) then - call endrun('modal_aero_calcsize_sub: ' // trim(errmsg)) - end if - - ! Apply interstitial tendencies to ptend - do l = 1, pcnst - if (dotend_local(l)) then - ptend%lq(l) = .true. - ptend%q(:ncol,:,l) = dqdt_local(:,:,l) - end if - end do - - ! Apply cloud-borne tendencies to qqcw pbuf fields - do l = 1, pcnst - if (dotend_cw_local(l)) then - fldcw => qqcw_get_field(pbuf, l, lchnk) - if (associated(fldcw)) then - do k = top_lev, pver - do i = 1, ncol - fldcw(i,k) = max( 0.0_r8, & - (fldcw(i,k) + dqdt_cw_local(i,k,l)*deltat) ) - end do - end do - end if - end if - end do - ! History output - if (do_adjust) then + ! Call portable science routine + call modal_aero_calcsize_run( & + ncol = ncol, & + pver = pver, & + deltat = deltat, & + top_lev = top_lev, & + ntot_amode = ntot_amode, & + nspec_amode = nspec_amode, & + nspec_max = nspec_max, & + dgnum_amode = dgnum_amode, & + dgnumlo_amode = dgnumlo_amode, & + dgnumhi_amode = dgnumhi_amode, & + alnsg_amode = alnsg_amode, & + voltonumb_amode = voltonumb_amode, & + voltonumblo_amode = voltonumblo_amode, & + voltonumbhi_amode = voltonumbhi_amode, & + specdens_amode = specdens_amode, & + mprognum_amode = mprognum_amode, & + modeptr_aitken = modeptr_aitken, & + modeptr_accum = modeptr_accum, & + lmassptr_amode = lmassptr_amode, & + numptr_amode = numptr_amode, & + lmassptrcw_amode = lmassptrcw_amode, & + numptrcw_amode = numptrcw_amode, & + pdel = state%pdel(:ncol,:), & + gravit = gravit, & + pi = pi, & + num_q = pcnst, & + q = q_local, & + q_cw = q_cw_local, & + do_adjust = do_adjust, & + do_aitacc_transfer = do_aitacc_transfer, & + npair_renamexf = npair_renamexf, & + nspecfrm_renamexf = nspecfrm_renamexf, & + modefrm_renamexf = modefrm_renamexf, & + modetoo_renamexf = modetoo_renamexf, & + lspecfrma_renamexf = lspecfrma_renamexf, & + lspectooa_renamexf = lspectooa_renamexf, & + lspecfrmc_renamexf = lspecfrmc_renamexf, & + lspectooc_renamexf = lspectooc_renamexf, & + dgncur_a = dgncur_a(:ncol,:,:), & + dqdt = dqdt_local, & + dqdt_cw = dqdt_cw_local, & + dotend = dotend_local, & + dotend_cw = dotend_cw_local, & + qsrflx = qsrflx, & + errmsg = errmsg, & + errflg = errflg) + + if (errflg /= 0) then + call endrun('modal_aero_calcsize_sub: ' // trim(errmsg)) + end if - do n = 1, ntot_amode - if (mprognum_amode(n) <= 0) cycle + ! Apply interstitial tendencies to ptend + do l = 1, pcnst + if (dotend_local(l)) then + ptend%lq(l) = .true. + ptend%q(:ncol,:,l) = dqdt_local(:,:,l) + end if + end do - do jac = 1, 2 - if (jac == 1) then - l = numptr_amode(n) - tmpnamea = cnst_name(l) - else - l = numptrcw_amode(n) - tmpnamea = cnst_name_cw(l) + ! Apply cloud-borne tendencies to qqcw pbuf fields + do l = 1, pcnst + if (dotend_cw_local(l)) then + fldcw => qqcw_get_field(pbuf, l, lchnk) + if (associated(fldcw)) then + do k = top_lev, pver + do i = 1, ncol + fldcw(i,k) = max( 0.0_r8, & + (fldcw(i,k) + dqdt_cw_local(i,k,l)*deltat) ) + end do + end do end if + end if + end do - ! Expand ncol-sized qsrflx to pcols for outfld - qsrflx_pcols(:) = 0.0_r8 - qsrflx_pcols(:ncol) = qsrflx(:,l,1,jac) - fieldname = trim(tmpnamea) // '_sfcsiz1' - call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + ! History output + if (do_adjust) then - qsrflx_pcols(:) = 0.0_r8 - qsrflx_pcols(:ncol) = qsrflx(:,l,2,jac) - fieldname = trim(tmpnamea) // '_sfcsiz2' - call outfld( fieldname, qsrflx_pcols, pcols, lchnk) - end do ! jac = ... - end do ! n = ... + do n = 1, ntot_amode + if (mprognum_amode(n) <= 0) cycle - if (do_aitacc_transfer) then - - ipair = 1 - do iq = 1, nspecfrm_renamexf(ipair) do jac = 1, 2 - 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 - - if (jac .eq. 1) then - tmpnamea = cnst_name(lsfrm) - tmpnameb = cnst_name(lstoo) + if (jac == 1) then + l = numptr_amode(n) + tmpnamea = cnst_name(l) else - tmpnamea = cnst_name_cw(lsfrm) - tmpnameb = cnst_name_cw(lstoo) + l = numptrcw_amode(n) + tmpnamea = cnst_name_cw(l) end if - if ((lsfrm <= 0) .or. (lstoo <= 0)) cycle - - qsrflx_pcols(:) = 0.0_r8 - qsrflx_pcols(:ncol) = qsrflx(:,lsfrm,3,jac) - fieldname = trim(tmpnamea) // '_sfcsiz3' - call outfld( fieldname, qsrflx_pcols, pcols, lchnk) - - qsrflx_pcols(:) = 0.0_r8 - qsrflx_pcols(:ncol) = qsrflx(:,lstoo,3,jac) - fieldname = trim(tmpnameb) // '_sfcsiz3' - call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + ! Expand ncol-sized qsrflx to pcols for outfld qsrflx_pcols(:) = 0.0_r8 - qsrflx_pcols(:ncol) = qsrflx(:,lsfrm,4,jac) - fieldname = trim(tmpnamea) // '_sfcsiz4' + qsrflx_pcols(:ncol) = qsrflx(:,l,1,jac) + fieldname = trim(tmpnamea) // '_sfcsiz1' call outfld( fieldname, qsrflx_pcols, pcols, lchnk) qsrflx_pcols(:) = 0.0_r8 - qsrflx_pcols(:ncol) = qsrflx(:,lstoo,4,jac) - fieldname = trim(tmpnameb) // '_sfcsiz4' + qsrflx_pcols(:ncol) = qsrflx(:,l,2,jac) + fieldname = trim(tmpnamea) // '_sfcsiz2' call outfld( fieldname, qsrflx_pcols, pcols, lchnk) - end do ! jac = ... - end do ! iq = ... - - end if ! do_aitacc_transfer - - end if ! do_adjust - - call modal_aero_calcdry(state, pbuf, aero_props, aero_state) - - ! Deallocate work arrays - deallocate(q_local, q_cw_local, dqdt_local, dqdt_cw_local) - deallocate(dotend_local, dotend_cw_local, qsrflx) + end do ! n = ... + + if (do_aitacc_transfer) then + + ipair = 1 + do iq = 1, nspecfrm_renamexf(ipair) + do jac = 1, 2 + 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 + + 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 + if ((lsfrm <= 0) .or. (lstoo <= 0)) cycle + + qsrflx_pcols(:) = 0.0_r8 + qsrflx_pcols(:ncol) = qsrflx(:,lsfrm,3,jac) + fieldname = trim(tmpnamea) // '_sfcsiz3' + call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + + qsrflx_pcols(:) = 0.0_r8 + qsrflx_pcols(:ncol) = qsrflx(:,lstoo,3,jac) + fieldname = trim(tmpnameb) // '_sfcsiz3' + call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + + qsrflx_pcols(:) = 0.0_r8 + qsrflx_pcols(:ncol) = qsrflx(:,lsfrm,4,jac) + fieldname = trim(tmpnamea) // '_sfcsiz4' + call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + + qsrflx_pcols(:) = 0.0_r8 + qsrflx_pcols(:ncol) = qsrflx(:,lstoo,4,jac) + fieldname = trim(tmpnameb) // '_sfcsiz4' + call outfld( fieldname, qsrflx_pcols, pcols, lchnk) + + end do ! jac = ... + end do ! iq = ... + + end if ! do_aitacc_transfer + + end if ! do_adjust + + call modal_aero_calcdry(state, pbuf, aero_props, aero_state) + + ! Deallocate work arrays + deallocate(q_local, q_cw_local, dqdt_local, dqdt_cw_local) + deallocate(dotend_local, dotend_cw_local, qsrflx) #endif -end subroutine modal_aero_calcsize_sub + end subroutine modal_aero_calcsize_sub -subroutine modal_aero_calcsize_diag(state, pbuf, aero_props, aero_state) + subroutine modal_aero_calcsize_diag(state, pbuf, aero_props, aero_state) - !----------------------------------------------------------------------- - ! - ! Calculate aerosol size distribution parameters - ! - ! ***N.B.*** DGNUM for the modes in the climate list are put directly into - ! the physics buffer. - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! Calculate aerosol size distribution parameters + ! + ! ***N.B.*** DGNUM for the modes in the climate list are put directly into + ! the physics buffer. + !----------------------------------------------------------------------- - ! arguments - type(physics_state), intent(in), target :: state ! Physics state variables - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - class(aerosol_properties), intent(in), target :: aero_props - class(aerosol_state), intent(in), target :: aero_state + ! arguments + type(physics_state), intent(in), target :: state ! Physics state variables + type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer + class(aerosol_properties), intent(in), target :: aero_props + class(aerosol_state), intent(in), target :: aero_state - ! local - integer :: i, k, l1, n - integer :: lchnk, ncol - integer :: stat - integer :: nmodes - integer :: nspec + ! local + integer :: i, k, l1, n + integer :: lchnk, ncol + integer :: stat + integer :: nmodes + integer :: nspec - real(r8), pointer :: dgncur_a(:,:) ! (pcols,pver) + real(r8), pointer :: dgncur_a(:,:) ! (pcols,pver) + real(r8), parameter :: third = 1.0_r8/3.0_r8 - real(r8), parameter :: third = 1.0_r8/3.0_r8 + real(r8), pointer :: mode_num(:,:) ! mode number mixing ratio + real(r8), pointer :: specmmr(:,:) ! specie mmr + real(r8) :: specdens ! specie density - real(r8), pointer :: mode_num(:,:) ! mode number mixing ratio - real(r8), pointer :: specmmr(:,:) ! specie mmr - real(r8) :: specdens ! specie density + real(r8) :: dryvol_a(pcols,pver) ! interstital aerosol dry volume (cm^3/mol_air) - real(r8) :: dryvol_a(pcols,pver) ! interstital aerosol dry volume (cm^3/mol_air) + real(r8) :: dgnum, dgnumhi, dgnumlo + real(r8) :: dgnyy, dgnxx ! dgnumlo/hi of current mode + real(r8) :: drv_a ! dry volume (cm3/mol_air) + real(r8) :: dumfac, dummwdens ! work variables + real(r8) :: num_a0 ! initial number (#/mol_air) + real(r8) :: num_a ! final number (#/mol_air) + real(r8) :: voltonumbhi, voltonumblo + real(r8) :: v2nyy, v2nxx ! voltonumblo/hi of current mode + real(r8) :: sigmag, alnsg + !----------------------------------------------------------------------- - real(r8) :: dgnum, dgnumhi, dgnumlo - real(r8) :: dgnyy, dgnxx ! dgnumlo/hi of current mode - real(r8) :: drv_a ! dry volume (cm3/mol_air) - real(r8) :: dumfac, dummwdens ! work variables - real(r8) :: num_a0 ! initial number (#/mol_air) - real(r8) :: num_a ! final number (#/mol_air) - real(r8) :: voltonumbhi, voltonumblo - real(r8) :: v2nyy, v2nxx ! voltonumblo/hi of current mode - real(r8) :: sigmag, alnsg - !----------------------------------------------------------------------- + lchnk = state%lchnk + ncol = state%ncol - lchnk = state%lchnk - ncol = state%ncol + nmodes = aero_props%nbins() - nmodes = aero_props%nbins() + do n = 1, nmodes - do n = 1, nmodes + call pbuf_get_field(pbuf, dgnum_idx, dgncur_a, start=(/1,1,n/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, dgnum_idx, dgncur_a, start=(/1,1,n/), kount=(/pcols,pver,1/)) + ! get mode properties + dgnum = aero_props%dgnum(n) + dgnumhi = aero_props%dgnumhi(n) + dgnumlo = aero_props%dgnumlo(n) + sigmag = exp(aero_props%alogsig(n)) - ! get mode properties - dgnum = aero_props%dgnum(n) - dgnumhi = aero_props%dgnumhi(n) - dgnumlo = aero_props%dgnumlo(n) - sigmag = exp(aero_props%alogsig(n)) + ! get mode number mixing ratio + call aero_state%get_ambient_num(n, mode_num) - ! get mode number mixing ratio - call aero_state%get_ambient_num(n, mode_num) + dgncur_a(:,:) = dgnum + dryvol_a(:,:) = 0.0_r8 - dgncur_a(:,:) = dgnum - dryvol_a(:,:) = 0.0_r8 + ! compute dry volume mixrats = + ! sum_over_components{ component_mass mixrat / density } + nspec = aero_props%nspecies(n) + do l1 = 1, nspec - ! compute dry volume mixrats = - ! sum_over_components{ component_mass mixrat / density } - nspec = aero_props%nspecies(n) - do l1 = 1, nspec + call aero_state%get_ambient_mmr(species_ndx=l1, bin_ndx=n, mmr=specmmr) + call aero_props%get(n, l1, density=specdens) - call aero_state%get_ambient_mmr(species_ndx=l1, bin_ndx=n, mmr=specmmr) - call aero_props%get(n, l1, density=specdens) + ! need qmass*dummwdens = (kg/kg-air) * [1/(kg/m3)] = m3/kg-air + dummwdens = 1.0_r8 / specdens - ! need qmass*dummwdens = (kg/kg-air) * [1/(kg/m3)] = m3/kg-air - dummwdens = 1.0_r8 / specdens - - do k=top_lev,pver - do i=1,ncol - dryvol_a(i,k) = dryvol_a(i,k) & - + max(0.0_r8, specmmr(i,k))*dummwdens + do k=top_lev,pver + do i=1,ncol + dryvol_a(i,k) = dryvol_a(i,k) & + + max(0.0_r8, specmmr(i,k))*dummwdens + end do end do end do - end do - alnsg = log( sigmag ) - dumfac = exp(4.5_r8*alnsg**2)*pi/6.0_r8 - voltonumblo = 1._r8 / ( (pi/6._r8)*(dgnumlo**3)*exp(4.5_r8*alnsg**2) ) - voltonumbhi = 1._r8 / ( (pi/6._r8)*(dgnumhi**3)*exp(4.5_r8*alnsg**2) ) - v2nxx = voltonumbhi - v2nyy = voltonumblo - dgnxx = dgnumhi - dgnyy = dgnumlo - - do k = top_lev, pver - do i = 1, ncol - - drv_a = dryvol_a(i,k) - num_a0 = mode_num(i,k) - num_a = max( 0.0_r8, num_a0 ) - - if (drv_a > 0.0_r8) then - if (num_a <= drv_a*v2nxx) then - dgncur_a(i,k) = dgnxx - else if (num_a >= drv_a*v2nyy) then - dgncur_a(i,k) = dgnyy - else - dgncur_a(i,k) = (drv_a/(dumfac*num_a))**third + alnsg = log( sigmag ) + dumfac = exp(4.5_r8*alnsg**2)*pi/6.0_r8 + voltonumblo = 1._r8 / ( (pi/6._r8)*(dgnumlo**3)*exp(4.5_r8*alnsg**2) ) + voltonumbhi = 1._r8 / ( (pi/6._r8)*(dgnumhi**3)*exp(4.5_r8*alnsg**2) ) + v2nxx = voltonumbhi + v2nyy = voltonumblo + dgnxx = dgnumhi + dgnyy = dgnumlo + + do k = top_lev, pver + do i = 1, ncol + + drv_a = dryvol_a(i,k) + num_a0 = mode_num(i,k) + num_a = max( 0.0_r8, num_a0 ) + + if (drv_a > 0.0_r8) then + if (num_a <= drv_a*v2nxx) then + dgncur_a(i,k) = dgnxx + else if (num_a >= drv_a*v2nyy) then + dgncur_a(i,k) = dgnyy + else + dgncur_a(i,k) = (drv_a/(dumfac*num_a))**third + end if end if - end if + end do end do - end do - end do ! nmodes - - call modal_aero_calcdry(state, pbuf, aero_props, aero_state) - -end subroutine modal_aero_calcsize_diag - -subroutine modal_aero_calcdry(state, pbuf, aero_props, aero_state) - - type(physics_state), target, intent(in) :: state ! Physics state variables - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - class(aerosol_properties), intent(in), target :: aero_props - class(aerosol_state), intent(in), target :: aero_state - - real(r8), pointer :: hygro(:,:,:) - real(r8), pointer :: dryvol(:,:,:) - real(r8), pointer :: dryrad(:,:,:) - real(r8), pointer :: drymass(:,:,:) - real(r8), pointer :: so4dryvol(:,:,:) - real(r8), pointer :: naer(:,:,:) - real(r8), pointer :: dgncur_a(:,:,:) - - integer :: ncol - - character(len=512) :: errmsg_local - integer :: errflg_local - - ncol = state%ncol - - call pbuf_get_field(pbuf, dgnum_idx, dgncur_a) - call pbuf_get_field(pbuf, hygro_idx, hygro) - call pbuf_get_field(pbuf, dryvol_idx, dryvol) - call pbuf_get_field(pbuf, dryrad_idx, dryrad) - call pbuf_get_field(pbuf, drymass_idx, drymass) - call pbuf_get_field(pbuf, so4dryvol_idx, so4dryvol) - call pbuf_get_field(pbuf, naer_idx, naer) - - hygro(:,:,:) = 0._r8 - dryvol(:,:,:) = 0._r8 - dryrad(:,:,:) = 0._r8 - drymass(:,:,:) = 0._r8 - so4dryvol(:,:,:) = 0._r8 - naer(:,:,:) = 0._r8 - - ! call portable subroutine: - call modal_aero_calcdry_run( & - aero_props = aero_props, & - aero_state = aero_state, & - ncol = ncol, & - pver = pver, & - top_lev = top_lev, & - do_strat_sulfate = modal_strat_sulfate, & - pi = pi, & - dgncur_a = dgncur_a(:ncol,:,:), & - hygro = hygro(:ncol,:,:), & - dryvol = dryvol(:ncol,:,:), & - dryrad = dryrad(:ncol,:,:), & - drymass = drymass(:ncol,:,:), & - so4dryvol = so4dryvol(:ncol,:,:), & - naer = naer(:ncol,:,:), & - errmsg = errmsg_local, & - errflg = errflg_local) - if (errflg_local /= 0) then - call endrun('modal_aero_calcdry: ' // trim(errmsg_local)) - end if - -end subroutine modal_aero_calcdry + end do ! nmodes + + call modal_aero_calcdry(state, pbuf, aero_props, aero_state) + + end subroutine modal_aero_calcsize_diag + + subroutine modal_aero_calcdry(state, pbuf, aero_props, aero_state) + + type(physics_state), target, intent(in) :: state ! Physics state variables + type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer + class(aerosol_properties), intent(in), target :: aero_props + class(aerosol_state), intent(in), target :: aero_state + + real(r8), pointer :: hygro(:,:,:) + real(r8), pointer :: dryvol(:,:,:) + real(r8), pointer :: dryrad(:,:,:) + real(r8), pointer :: drymass(:,:,:) + real(r8), pointer :: so4dryvol(:,:,:) + real(r8), pointer :: naer(:,:,:) + real(r8), pointer :: dgncur_a(:,:,:) + + integer :: ncol + + character(len=512) :: errmsg_local + integer :: errflg_local + + ncol = state%ncol + + call pbuf_get_field(pbuf, dgnum_idx, dgncur_a) + call pbuf_get_field(pbuf, hygro_idx, hygro) + call pbuf_get_field(pbuf, dryvol_idx, dryvol) + call pbuf_get_field(pbuf, dryrad_idx, dryrad) + call pbuf_get_field(pbuf, drymass_idx, drymass) + call pbuf_get_field(pbuf, so4dryvol_idx, so4dryvol) + call pbuf_get_field(pbuf, naer_idx, naer) + + hygro(:,:,:) = 0._r8 + dryvol(:,:,:) = 0._r8 + dryrad(:,:,:) = 0._r8 + drymass(:,:,:) = 0._r8 + so4dryvol(:,:,:) = 0._r8 + naer(:,:,:) = 0._r8 + + ! call portable subroutine: + call modal_aero_calcdry_run( & + aero_props = aero_props, & + aero_state = aero_state, & + ncol = ncol, & + pver = pver, & + top_lev = top_lev, & + do_strat_sulfate = modal_strat_sulfate, & + pi = pi, & + dgncur_a = dgncur_a(:ncol,:,:), & + hygro = hygro(:ncol,:,:), & + dryvol = dryvol(:ncol,:,:), & + dryrad = dryrad(:ncol,:,:), & + drymass = drymass(:ncol,:,:), & + so4dryvol = so4dryvol(:ncol,:,:), & + naer = naer(:ncol,:,:), & + errmsg = errmsg_local, & + errflg = errflg_local) + if (errflg_local /= 0) then + call endrun('modal_aero_calcdry: ' // trim(errmsg_local)) + end if + + end subroutine modal_aero_calcdry end module modal_aero_calcsize_cam diff --git a/src/chemistry/utils/modal_aero_wateruptake_cam.F90 b/src/chemistry/utils/modal_aero_wateruptake_cam.F90 index fd4abd254d..08d8376633 100644 --- a/src/chemistry/utils/modal_aero_wateruptake_cam.F90 +++ b/src/chemistry/utils/modal_aero_wateruptake_cam.F90 @@ -1,444 +1,442 @@ module modal_aero_wateruptake_cam ! CAM wrapper for modal_aero_wateruptake. -use shr_kind_mod, only: r8 => shr_kind_r8 -use physconst, only: pi, rhoh2o, rair -use ppgrid, only: pcols, pver -use physics_types, only: physics_state -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field - -use aerosol_properties_mod, only: aerosol_properties -use aerosol_state_mod, only: aerosol_state -use cam_history, only: addfld, add_default, outfld, horiz_only -use cam_logfile, only: iulog -use ref_pres, only: top_lev => clim_modal_aero_top_lev -use phys_control, only: phys_getopts -use cam_abortutils, only: endrun - -use modal_aero_wateruptake, only: modal_aero_wateruptake_init, & - modal_aero_wateruptake_sub -use modal_aero_data, only: modal_strat_sulfate - -implicit none -private -save - -public :: & - modal_aero_wateruptake_cam_init, & - modal_aero_wateruptake_dr, & - modal_aero_wateruptake_reg + use shr_kind_mod, only: r8 => shr_kind_r8 + use physconst, only: pi, rhoh2o, rair + use ppgrid, only: pcols, pver + use physics_types, only: physics_state + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field + + use aerosol_properties_mod, only: aerosol_properties + use aerosol_state_mod, only: aerosol_state + use cam_history, only: addfld, add_default, outfld, horiz_only + use cam_logfile, only: iulog + use ref_pres, only: top_lev => clim_modal_aero_top_lev + use phys_control, only: phys_getopts + use cam_abortutils, only: endrun + + use modal_aero_wateruptake, only: modal_aero_wateruptake_init, & + modal_aero_wateruptake_sub + use modal_aero_data, only: modal_strat_sulfate + + implicit none + private + save + + public :: & + modal_aero_wateruptake_cam_init, & + modal_aero_wateruptake_dr, & + modal_aero_wateruptake_reg ! Physics buffer indices -integer :: cld_idx = 0 -integer :: dgnum_idx = 0 -integer :: dgnumwet_idx = 0 -integer :: sulfeq_idx = 0 -integer :: wetdens_ap_idx = 0 -integer :: qaerwat_idx = 0 -integer :: hygro_idx = 0 -integer :: dryvol_idx = 0 -integer :: dryrad_idx = 0 -integer :: drymass_idx = 0 -integer :: so4dryvol_idx = 0 -integer :: naer_idx = 0 + integer :: cld_idx = 0 + integer :: dgnum_idx = 0 + integer :: dgnumwet_idx = 0 + integer :: sulfeq_idx = 0 + integer :: wetdens_ap_idx = 0 + integer :: qaerwat_idx = 0 + integer :: hygro_idx = 0 + integer :: dryvol_idx = 0 + integer :: dryrad_idx = 0 + integer :: drymass_idx = 0 + integer :: so4dryvol_idx = 0 + integer :: naer_idx = 0 contains -subroutine modal_aero_wateruptake_reg() + subroutine modal_aero_wateruptake_reg() - use physics_buffer, only: pbuf_add_field, dtype_r8 - use radiative_aerosol, only: rad_aer_get_info + use physics_buffer, only: pbuf_add_field, dtype_r8 + use radiative_aerosol, only: rad_aer_get_info - integer :: nmodes + integer :: nmodes - call rad_aer_get_info(0, nmodes=nmodes) - call pbuf_add_field('DGNUMWET', 'global', dtype_r8, (/pcols, pver, nmodes/), dgnumwet_idx) - call pbuf_add_field('WETDENS_AP', 'physpkg', dtype_r8, (/pcols, pver, nmodes/), wetdens_ap_idx) + call rad_aer_get_info(0, nmodes=nmodes) + call pbuf_add_field('DGNUMWET', 'global', dtype_r8, (/pcols, pver, nmodes/), dgnumwet_idx) + call pbuf_add_field('WETDENS_AP', 'physpkg', dtype_r8, (/pcols, pver, nmodes/), wetdens_ap_idx) - ! 1st order rate for direct conversion of strat. cloud water to precip (1/s) - call pbuf_add_field('QAERWAT', 'physpkg', dtype_r8, (/pcols, pver, nmodes/), qaerwat_idx) - - if (modal_strat_sulfate) then - call pbuf_add_field('MAMH2SO4EQ', 'global', dtype_r8, (/pcols, pver, nmodes/), sulfeq_idx) - end if + ! 1st order rate for direct conversion of strat. cloud water to precip (1/s) + call pbuf_add_field('QAERWAT', 'physpkg', dtype_r8, (/pcols, pver, nmodes/), qaerwat_idx) + if (modal_strat_sulfate) then + call pbuf_add_field('MAMH2SO4EQ', 'global', dtype_r8, (/pcols, pver, nmodes/), sulfeq_idx) + end if -end subroutine modal_aero_wateruptake_reg + end subroutine modal_aero_wateruptake_reg !=============================================================================== !=============================================================================== -subroutine modal_aero_wateruptake_cam_init(pbuf2d) - use time_manager, only: is_first_step - use physics_buffer,only: pbuf_set_field - use infnan, only : nan, assignment(=) - use radiative_aerosol, only: rad_aer_get_info - use modal_aero_wateruptake, only: modal_aero_wateruptake_diag - use modal_aerosol_state_mod, only: modal_aerosol_state_register_water_uptake_diag + subroutine modal_aero_wateruptake_cam_init(pbuf2d) + use time_manager, only: is_first_step + use physics_buffer,only: pbuf_set_field + use infnan, only : nan, assignment(=) + use radiative_aerosol, only: rad_aer_get_info + use modal_aero_wateruptake, only: modal_aero_wateruptake_diag + use modal_aerosol_state_mod, only: modal_aerosol_state_register_water_uptake_diag - use shr_const_mod, only: shr_const_pi + use shr_const_mod, only: shr_const_pi - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - real(r8) :: real_nan + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + real(r8) :: real_nan - integer :: m, nmodes - logical :: history_aerosol ! Output the MAM aerosol variables and tendencies + integer :: m, nmodes + logical :: history_aerosol ! Output the MAM aerosol variables and tendencies - character(len=3) :: trnum ! used to hold mode number (as characters) + character(len=3) :: trnum ! used to hold mode number (as characters) - character(len=512) :: errmsg_local - integer :: errflg_local - !---------------------------------------------------------------------------- + character(len=512) :: errmsg_local + integer :: errflg_local + !---------------------------------------------------------------------------- - real_nan = nan + real_nan = nan - cld_idx = pbuf_get_index('CLD') - dgnum_idx = pbuf_get_index('DGNUM') + cld_idx = pbuf_get_index('CLD') + dgnum_idx = pbuf_get_index('DGNUM') - hygro_idx = pbuf_get_index('HYGRO') - dryvol_idx = pbuf_get_index('DRYVOL') - dryrad_idx = pbuf_get_index('DRYRAD') - drymass_idx = pbuf_get_index('DRYMASS') - so4dryvol_idx = pbuf_get_index('SO4DRYVOL') - naer_idx = pbuf_get_index('NAER') + hygro_idx = pbuf_get_index('HYGRO') + dryvol_idx = pbuf_get_index('DRYVOL') + dryrad_idx = pbuf_get_index('DRYRAD') + drymass_idx = pbuf_get_index('DRYMASS') + so4dryvol_idx = pbuf_get_index('SO4DRYVOL') + naer_idx = pbuf_get_index('NAER') - ! assume for now that will compute wateruptake for climate list modes only + ! assume for now that will compute wateruptake for climate list modes only - call rad_aer_get_info(0, nmodes=nmodes) + call rad_aer_get_info(0, nmodes=nmodes) - do m = 1, nmodes - write(trnum, '(i3.3)') m - call addfld('dgnd_a'//trnum(2:3), (/ 'lev' /), 'A', 'm', & - 'dry dgnum, interstitial, mode '//trnum(2:3)) - call addfld('dgnw_a'//trnum(2:3), (/ 'lev' /), 'A', 'm', & - 'wet dgnum, interstitial, mode '//trnum(2:3)) - call addfld('wat_a'//trnum(3:3), (/ 'lev' /), 'A', 'm', & - 'aerosol water, interstitial, mode '//trnum(2:3)) - - ! determine default variables - call phys_getopts(history_aerosol_out = history_aerosol) + do m = 1, nmodes + write(trnum, '(i3.3)') m + call addfld('dgnd_a'//trnum(2:3), (/ 'lev' /), 'A', 'm', & + 'dry dgnum, interstitial, mode '//trnum(2:3)) + call addfld('dgnw_a'//trnum(2:3), (/ 'lev' /), 'A', 'm', & + 'wet dgnum, interstitial, mode '//trnum(2:3)) + call addfld('wat_a'//trnum(3:3), (/ 'lev' /), 'A', 'm', & + 'aerosol water, interstitial, mode '//trnum(2:3)) + + ! determine default variables + call phys_getopts(history_aerosol_out = history_aerosol) + + if (history_aerosol) then + call add_default('dgnd_a'//trnum(2:3), 1, ' ') + call add_default('dgnw_a'//trnum(2:3), 1, ' ') + call add_default('wat_a'//trnum(3:3), 1, ' ') + endif - if (history_aerosol) then - call add_default('dgnd_a'//trnum(2:3), 1, ' ') - call add_default('dgnw_a'//trnum(2:3), 1, ' ') - call add_default('wat_a'//trnum(3:3), 1, ' ') - endif + end do - end do - - call addfld('PM25', (/ 'lev' /), 'A', 'kg/m3', 'PM2.5 mass concentration') - call addfld('PM25_SRF', horiz_only, 'A', 'kg/m3', 'surface PM2.5 mass concentration') - ! dmleung added a few more below, 20 Nov 2023 - call addfld('PM25_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM2.5 mass mixing ratio') - call addfld('PM1_SRF', horiz_only, 'A', 'kg/m3', 'surface PM1 mass concentration') - call addfld('PM1_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM1 mass mixing ratio') - call addfld('PM10_SRF', horiz_only, 'A', 'kg/m3', 'surface PM10 mass concentration') - call addfld('PM10_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM10 mass mixing ratio') - call addfld('PMTOT_MMR', (/ 'lev' /), 'A', 'kg/kg', 'total PM mass mixing ratio') - call addfld('RHO_AIR', (/ 'lev' /), 'A', 'kg/m3', 'air density') ! I know RHO_CLUBB exists. Does this exist? - - call add_default('RHO_AIR', 1, ' ') - call add_default('PM25_SRF', 1, ' ') - call add_default('PM25_MMR', 1, ' ') - call add_default('PM10_MMR', 1, ' ') - ! dmleung -- - - if (is_first_step()) then - ! initialize fields in physics buffer - call pbuf_set_field(pbuf2d, dgnumwet_idx, 0.0_r8) - if (modal_strat_sulfate) then - ! initialize fields in physics buffer to NaN (not a number) - ! so model will crash if used before initialization - call pbuf_set_field(pbuf2d, sulfeq_idx, real_nan) + call addfld('PM25', (/ 'lev' /), 'A', 'kg/m3', 'PM2.5 mass concentration') + call addfld('PM25_SRF', horiz_only, 'A', 'kg/m3', 'surface PM2.5 mass concentration') + ! dmleung added a few more below, 20 Nov 2023 + call addfld('PM25_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM2.5 mass mixing ratio') + call addfld('PM1_SRF', horiz_only, 'A', 'kg/m3', 'surface PM1 mass concentration') + call addfld('PM1_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM1 mass mixing ratio') + call addfld('PM10_SRF', horiz_only, 'A', 'kg/m3', 'surface PM10 mass concentration') + call addfld('PM10_MMR', (/ 'lev' /), 'A', 'kg/kg', 'PM10 mass mixing ratio') + call addfld('PMTOT_MMR', (/ 'lev' /), 'A', 'kg/kg', 'total PM mass mixing ratio') + call addfld('RHO_AIR', (/ 'lev' /), 'A', 'kg/m3', 'air density') ! I know RHO_CLUBB exists. Does this exist? + + call add_default('RHO_AIR', 1, ' ') + call add_default('PM25_SRF', 1, ' ') + call add_default('PM25_MMR', 1, ' ') + call add_default('PM10_MMR', 1, ' ') + ! dmleung -- + + if (is_first_step()) then + ! initialize fields in physics buffer + call pbuf_set_field(pbuf2d, dgnumwet_idx, 0.0_r8) + if (modal_strat_sulfate) then + ! initialize fields in physics buffer to NaN (not a number) + ! so model will crash if used before initialization + call pbuf_set_field(pbuf2d, sulfeq_idx, real_nan) + endif endif - endif - call modal_aero_wateruptake_init(shr_const_pi, errmsg_local, errflg_local) - if (errflg_local /= 0) then - call endrun('modal_aero_wateruptake_cam_init: ' // trim(errmsg_local)) - end if + call modal_aero_wateruptake_init(shr_const_pi, errmsg_local, errflg_local) + if (errflg_local /= 0) then + call endrun('modal_aero_wateruptake_cam_init: ' // trim(errmsg_local)) + end if - ! Register the diagnostic-list water uptake recompute with the aerosol - ! interface - ! - ! Pass a procedure pointer in since MAM is not always built in every config. - call modal_aerosol_state_register_water_uptake_diag(modal_aero_wateruptake_diag) + ! Register the diagnostic-list water uptake recompute with the aerosol + ! interface + ! + ! Pass a procedure pointer in since MAM is not always built in every config. + call modal_aerosol_state_register_water_uptake_diag(modal_aero_wateruptake_diag) -end subroutine modal_aero_wateruptake_cam_init + end subroutine modal_aero_wateruptake_cam_init !=============================================================================== - -subroutine modal_aero_wateruptake_dr(state, pbuf, aero_props, aero_state) + subroutine modal_aero_wateruptake_dr(state, pbuf, aero_props, aero_state) !----------------------------------------------------------------------- ! ! CAM specific driver for modal aerosol water uptake code. ! !----------------------------------------------------------------------- - use time_manager, only: is_first_step - use cam_history, only: fieldname_len - use tropopause, only: tropopause_find_cam, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE - - ! Arguments - type(physics_state), target, intent(in) :: state ! Physics state variables - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - class(aerosol_properties), intent(in), target :: aero_props - class(aerosol_state), intent(in), target :: aero_state - - ! local variables - - integer :: lchnk ! chunk index - integer :: ncol ! number of columns - - integer :: i, k, m - integer :: nmodes - integer :: tropLev(pcols) - - character(len=fieldname_len+3) :: fieldname - - real(r8), pointer :: h2ommr(:,:) ! specific humidity - real(r8), pointer :: t(:,:) ! temperatures (K) - real(r8), pointer :: pmid(:,:) ! layer pressure (Pa) - - real(r8), pointer :: cldn(:,:) ! layer cloud fraction (0-1) - real(r8), pointer :: dgncur_a(:,:,:) - real(r8), pointer :: dgncur_awet(:,:,:) - real(r8), pointer :: wetdens(:,:,:) - real(r8), pointer :: qaerwat(:,:,:) - - real(r8), pointer :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) - real(r8), pointer :: naer(:,:,:) ! aerosol number MR (bounded!) (#/kg-air) - real(r8), pointer :: dryvol(:,:,:) ! single-particle-mean dry volume (m3) - real(r8), pointer :: so4dryvol(:,:,:) ! single-particle-mean so4 dry volume (m3) - real(r8), pointer :: drymass(:,:,:) ! single-particle-mean dry mass (kg) - real(r8), pointer :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) - - real(r8), allocatable :: wetrad(:,:,:) ! wet radius of aerosol (m) - real(r8), allocatable :: wetvol(:,:,:) ! single-particle-mean wet volume (m3) - real(r8), allocatable :: wtrvol(:,:,:) ! single-particle-mean water volume in wet aerosol (m3) - - real(r8), allocatable :: specdens_1(:) - - real(r8), pointer :: sulfeq(:,:,:) ! H2SO4 equilibrium mixing ratios over particles (mol/mol) - real(r8), allocatable :: sulfeq_local(:,:,:) ! local work array for _sub output - real(r8), allocatable :: wtpct(:,:,:) ! sulfate aerosol composition, weight % H2SO4 - real(r8), allocatable :: sulden(:,:,:) ! sulfate aerosol mass density (g/cm3) - - real(r8), allocatable :: alnsg(:) - real(r8), pointer :: maer(:,:,:) ! accumulated aerosol mode MRs - - real(r8) :: pm25(pcols,pver) ! PM2.5 diagnostics - real(r8) :: rhoair(pcols,pver) - ! dmleung 20 Oct 2025 ++ - real(r8) :: pm25_mmr(pcols,pver) ! PM2.5 mass mixing ratio dmleung, 20 Nov 2023 - real(r8) :: pm1(pcols,pver) ! PM1 mass conc - real(r8) :: pm1_mmr(pcols,pver) ! PM1 mass mixing ratio dmleung, 20 Nov 2023 - real(r8) :: pm10(pcols,pver) ! PM10 mass conc - real(r8) :: pm10_mmr(pcols,pver) ! PM10 mass mixing ratio dmleung, 20 Nov 2023 - real(r8) :: pmtot_mmr(pcols,pver) ! total PM mass mixing ratio - ! dmleung -- - - character(len=3) :: trnum ! used to hold mode number (as characters) - - character(len=512) :: errmsg_local - integer :: errflg_local - - !----------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - - ! loop over all aerosol modes - nmodes = aero_props%nbins() - - allocate( & - wetrad(pcols,pver,nmodes), & - wetvol(pcols,pver,nmodes), & - wtrvol(pcols,pver,nmodes), & - wtpct(pcols,pver,nmodes), & - sulden(pcols,pver,nmodes), & - sulfeq_local(pcols,pver,nmodes), & - specdens_1(nmodes), & - alnsg(nmodes), & - maer(pcols,pver,nmodes) ) - - call pbuf_get_field(pbuf, dgnum_idx, dgncur_a ) - call pbuf_get_field(pbuf, dgnumwet_idx, dgncur_awet ) - call pbuf_get_field(pbuf, wetdens_ap_idx, wetdens) - call pbuf_get_field(pbuf, qaerwat_idx, qaerwat) - call pbuf_get_field(pbuf, hygro_idx, hygro) - call pbuf_get_field(pbuf, dryvol_idx, dryvol) - call pbuf_get_field(pbuf, dryrad_idx, dryrad) - call pbuf_get_field(pbuf, drymass_idx, drymass) - call pbuf_get_field(pbuf, so4dryvol_idx, so4dryvol) - call pbuf_get_field(pbuf, naer_idx, naer) - - if (is_first_step()) then - dgncur_awet(:,:,:) = dgncur_a(:,:,:) - end if - - if (modal_strat_sulfate) then - ! get tropopause level - !REMOVECAM - no longer need this when CAM is retired and pcols no longer exists - tropLev(:) = 0 - !REMOVECAM_END - call tropopause_find_cam(state, tropLev, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) - endif - - h2ommr => state%q(:,:,1) - t => state%t - pmid => state%pmid - - call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1/), kount=(/pcols,pver/) ) - - ! Zero output arrays (allocated at pcols, _sub only writes 1:ncol) - wetrad(:,:,:) = 0._r8 - wetvol(:,:,:) = 0._r8 - wtrvol(:,:,:) = 0._r8 - sulfeq_local(:,:,:) = 0._r8 - wtpct(:,:,:) = 0._r8 - sulden(:,:,:) = 0._r8 - maer(:,:,:) = 0._r8 - - call modal_aero_wateruptake_sub( & - aero_props = aero_props, & - aero_state = aero_state, & - ncol = ncol, & - pver = pver, & - top_lev = top_lev, & - do_strat_sulfate = modal_strat_sulfate, & - t = t(:ncol,:), & - pmid = pmid(:ncol,:), & - h2ommr = h2ommr(:ncol,:), & - cldn = cldn(:ncol,:), & - dryrad = dryrad(:ncol,:,:), & - hygro = hygro(:ncol,:,:), & - dryvol = dryvol(:ncol,:,:), & - so4dryvol = so4dryvol(:ncol,:,:), & - dgncur_awet = dgncur_awet(:ncol,:,:), & - troplev = tropLev(:ncol), & - wetrad = wetrad(:ncol,:,:), & - wetvol = wetvol(:ncol,:,:), & - wtrvol = wtrvol(:ncol,:,:), & - sulfeq = sulfeq_local(:ncol,:,:), & - wtpct = wtpct(:ncol,:,:), & - sulden = sulden(:ncol,:,:), & - specdens_1 = specdens_1, & - alnsg_out = alnsg, & - maer = maer(:ncol,:,:), & - errmsg = errmsg_local, & - errflg = errflg_local) - if (errflg_local /= 0) then - call endrun('modal_aero_wateruptake_dr: ' // trim(errmsg_local)) - end if - - ! Copy sulfeq to pbuf and output strat sulfate diagnostics - if (modal_strat_sulfate) then - call pbuf_get_field(pbuf, sulfeq_idx, sulfeq) - sulfeq(:,:,:) = sulfeq_local(:,:,:) + use time_manager, only: is_first_step + use cam_history, only: fieldname_len + use tropopause, only: tropopause_find_cam, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE + + ! Arguments + type(physics_state), target, intent(in) :: state ! Physics state variables + type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer + class(aerosol_properties), intent(in), target :: aero_props + class(aerosol_state), intent(in), target :: aero_state + + ! local variables + + integer :: lchnk ! chunk index + integer :: ncol ! number of columns + + integer :: i, k, m + integer :: nmodes + integer :: tropLev(pcols) + + character(len=fieldname_len+3) :: fieldname + + real(r8), pointer :: h2ommr(:,:) ! specific humidity + real(r8), pointer :: t(:,:) ! temperatures (K) + real(r8), pointer :: pmid(:,:) ! layer pressure (Pa) + + real(r8), pointer :: cldn(:,:) ! layer cloud fraction (0-1) + real(r8), pointer :: dgncur_a(:,:,:) + real(r8), pointer :: dgncur_awet(:,:,:) + real(r8), pointer :: wetdens(:,:,:) + real(r8), pointer :: qaerwat(:,:,:) + + real(r8), pointer :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) + real(r8), pointer :: naer(:,:,:) ! aerosol number MR (bounded!) (#/kg-air) + real(r8), pointer :: dryvol(:,:,:) ! single-particle-mean dry volume (m3) + real(r8), pointer :: so4dryvol(:,:,:) ! single-particle-mean so4 dry volume (m3) + real(r8), pointer :: drymass(:,:,:) ! single-particle-mean dry mass (kg) + real(r8), pointer :: dryrad(:,:,:) ! dry volume mean radius of aerosol (m) + + real(r8), allocatable :: wetrad(:,:,:) ! wet radius of aerosol (m) + real(r8), allocatable :: wetvol(:,:,:) ! single-particle-mean wet volume (m3) + real(r8), allocatable :: wtrvol(:,:,:) ! single-particle-mean water volume in wet aerosol (m3) + + real(r8), allocatable :: specdens_1(:) + + real(r8), pointer :: sulfeq(:,:,:) ! H2SO4 equilibrium mixing ratios over particles (mol/mol) + real(r8), allocatable :: sulfeq_local(:,:,:) ! local work array for _sub output + real(r8), allocatable :: wtpct(:,:,:) ! sulfate aerosol composition, weight % H2SO4 + real(r8), allocatable :: sulden(:,:,:) ! sulfate aerosol mass density (g/cm3) + + real(r8), allocatable :: alnsg(:) + real(r8), pointer :: maer(:,:,:) ! accumulated aerosol mode MRs + + real(r8) :: pm25(pcols,pver) ! PM2.5 diagnostics + real(r8) :: rhoair(pcols,pver) + ! dmleung 20 Oct 2025 ++ + real(r8) :: pm25_mmr(pcols,pver) ! PM2.5 mass mixing ratio dmleung, 20 Nov 2023 + real(r8) :: pm1(pcols,pver) ! PM1 mass conc + real(r8) :: pm1_mmr(pcols,pver) ! PM1 mass mixing ratio dmleung, 20 Nov 2023 + real(r8) :: pm10(pcols,pver) ! PM10 mass conc + real(r8) :: pm10_mmr(pcols,pver) ! PM10 mass mixing ratio dmleung, 20 Nov 2023 + real(r8) :: pmtot_mmr(pcols,pver) ! total PM mass mixing ratio + ! dmleung -- + + character(len=3) :: trnum ! used to hold mode number (as characters) + + character(len=512) :: errmsg_local + integer :: errflg_local + + !----------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + ! loop over all aerosol modes + nmodes = aero_props%nbins() + + allocate( & + wetrad(pcols,pver,nmodes), & + wetvol(pcols,pver,nmodes), & + wtrvol(pcols,pver,nmodes), & + wtpct(pcols,pver,nmodes), & + sulden(pcols,pver,nmodes), & + sulfeq_local(pcols,pver,nmodes), & + specdens_1(nmodes), & + alnsg(nmodes), & + maer(pcols,pver,nmodes) ) + + call pbuf_get_field(pbuf, dgnum_idx, dgncur_a ) + call pbuf_get_field(pbuf, dgnumwet_idx, dgncur_awet ) + call pbuf_get_field(pbuf, wetdens_ap_idx, wetdens) + call pbuf_get_field(pbuf, qaerwat_idx, qaerwat) + call pbuf_get_field(pbuf, hygro_idx, hygro) + call pbuf_get_field(pbuf, dryvol_idx, dryvol) + call pbuf_get_field(pbuf, dryrad_idx, dryrad) + call pbuf_get_field(pbuf, drymass_idx, drymass) + call pbuf_get_field(pbuf, so4dryvol_idx, so4dryvol) + call pbuf_get_field(pbuf, naer_idx, naer) + + if (is_first_step()) then + dgncur_awet(:,:,:) = dgncur_a(:,:,:) + end if + + if (modal_strat_sulfate) then + ! get tropopause level + !REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + tropLev(:) = 0 + !REMOVECAM_END + call tropopause_find_cam(state, tropLev, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) + endif + + h2ommr => state%q(:,:,1) + t => state%t + pmid => state%pmid + + call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1/), kount=(/pcols,pver/) ) + + ! Zero output arrays (allocated at pcols, _sub only writes 1:ncol) + wetrad(:,:,:) = 0._r8 + wetvol(:,:,:) = 0._r8 + wtrvol(:,:,:) = 0._r8 + sulfeq_local(:,:,:) = 0._r8 + wtpct(:,:,:) = 0._r8 + sulden(:,:,:) = 0._r8 + maer(:,:,:) = 0._r8 + + call modal_aero_wateruptake_sub( & + aero_props = aero_props, & + aero_state = aero_state, & + ncol = ncol, & + pver = pver, & + top_lev = top_lev, & + do_strat_sulfate = modal_strat_sulfate, & + t = t(:ncol,:), & + pmid = pmid(:ncol,:), & + h2ommr = h2ommr(:ncol,:), & + cldn = cldn(:ncol,:), & + dryrad = dryrad(:ncol,:,:), & + hygro = hygro(:ncol,:,:), & + dryvol = dryvol(:ncol,:,:), & + so4dryvol = so4dryvol(:ncol,:,:), & + dgncur_awet = dgncur_awet(:ncol,:,:), & + troplev = tropLev(:ncol), & + wetrad = wetrad(:ncol,:,:), & + wetvol = wetvol(:ncol,:,:), & + wtrvol = wtrvol(:ncol,:,:), & + sulfeq = sulfeq_local(:ncol,:,:), & + wtpct = wtpct(:ncol,:,:), & + sulden = sulden(:ncol,:,:), & + specdens_1 = specdens_1, & + alnsg_out = alnsg, & + maer = maer(:ncol,:,:), & + errmsg = errmsg_local, & + errflg = errflg_local) + if (errflg_local /= 0) then + call endrun('modal_aero_wateruptake_dr: ' // trim(errmsg_local)) + end if + + ! Copy sulfeq to pbuf and output strat sulfate diagnostics + if (modal_strat_sulfate) then + call pbuf_get_field(pbuf, sulfeq_idx, sulfeq) + sulfeq(:,:,:) = sulfeq_local(:,:,:) + + do m = 1, nmodes + fieldname = ' ' + write(fieldname,fmt='(a,i1)') 'wtpct_a',m + call outfld(fieldname,wtpct(1:ncol,1:pver,m), ncol, lchnk ) + + fieldname = ' ' + write(fieldname,fmt='(a,i1)') 'sulfeq_a',m + call outfld(fieldname,sulfeq_local(1:ncol,1:pver,m), ncol, lchnk ) + + fieldname = ' ' + write(fieldname,fmt='(a,i1)') 'sulden_a',m + call outfld(fieldname,sulden(1:ncol,1:pver,m), ncol, lchnk ) + end do + end if + + ! Post-processing: wet density, qaerwat, dgncur_awet update + qaerwat = 0.0_r8 do m = 1, nmodes - fieldname = ' ' - write(fieldname,fmt='(a,i1)') 'wtpct_a',m - call outfld(fieldname,wtpct(1:ncol,1:pver,m), ncol, lchnk ) - fieldname = ' ' - write(fieldname,fmt='(a,i1)') 'sulfeq_a',m - call outfld(fieldname,sulfeq_local(1:ncol,1:pver,m), ncol, lchnk ) + do k = top_lev, pver + do i = 1, ncol - fieldname = ' ' - write(fieldname,fmt='(a,i1)') 'sulden_a',m - call outfld(fieldname,sulden(1:ncol,1:pver,m), ncol, lchnk ) - end do - end if + dgncur_awet(i,k,m) = dgncur_a(i,k,m) * (wetrad(i,k,m)/dryrad(i,k,m)) + qaerwat(i,k,m) = rhoh2o*naer(i,k,m)*wtrvol(i,k,m) - ! Post-processing: wet density, qaerwat, dgncur_awet update - qaerwat = 0.0_r8 + ! compute aerosol wet density (kg/m3) + if (wetvol(i,k,m) > 1.0e-30_r8) then + wetdens(i,k,m) = (drymass(i,k,m) + rhoh2o*wtrvol(i,k,m))/wetvol(i,k,m) + else + wetdens(i,k,m) = specdens_1(m) + end if + end do + end do - do m = 1, nmodes + end do ! modes + ! Compute air density for PM diagnostics do k = top_lev, pver do i = 1, ncol - - dgncur_awet(i,k,m) = dgncur_a(i,k,m) * (wetrad(i,k,m)/dryrad(i,k,m)) - qaerwat(i,k,m) = rhoh2o*naer(i,k,m)*wtrvol(i,k,m) - - ! compute aerosol wet density (kg/m3) - if (wetvol(i,k,m) > 1.0e-30_r8) then - wetdens(i,k,m) = (drymass(i,k,m) + rhoh2o*wtrvol(i,k,m))/wetvol(i,k,m) - else - wetdens(i,k,m) = specdens_1(m) - end if + rhoair(i,k) = pmid(i,k)/(rair*t(i,k)) end do end do - end do ! modes + pm25(:,:)=0._r8 + ! dmleung 20 Oct 2025 ++ + pm25_mmr(:,:)=0._r8 + pm1(:,:)=0._r8 + pm1_mmr(:,:)=0._r8 + pm10(:,:)=0._r8 + pm10_mmr(:,:)=0._r8 + pmtot_mmr(:,:)=0._r8 + ! dmleung -- - ! Compute air density for PM diagnostics - do k = top_lev, pver - do i = 1, ncol - rhoair(i,k) = pmid(i,k)/(rair*t(i,k)) - end do - end do - - pm25(:,:)=0._r8 - ! dmleung 20 Oct 2025 ++ - pm25_mmr(:,:)=0._r8 - pm1(:,:)=0._r8 - pm1_mmr(:,:)=0._r8 - pm10(:,:)=0._r8 - pm10_mmr(:,:)=0._r8 - pmtot_mmr(:,:)=0._r8 - ! dmleung -- - - do m = 1, nmodes - ! output to history - write( trnum, '(i3.3)' ) m - call outfld( 'wat_a'//trnum(3:3), qaerwat(:,:,m), pcols, lchnk) - call outfld( 'dgnd_a'//trnum(2:3), dgncur_a(:,:,m), pcols, lchnk) - call outfld( 'dgnw_a'//trnum(2:3), dgncur_awet(:,:,m), pcols, lchnk) - - ! calculate PM2.5 diagnostics -- dgncur_a is zero above top_lev - do k = top_lev, pver - do i=1,ncol - pm25(i,k) = pm25(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(2.5e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) - ! dmleung 20 Oct 2025: calculate other PM diagnostics ++ - pm25_mmr(i,k) = pm25_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(2.5e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m))))) ! PM2.5 mass mixing ratio, dmleung - pm1(i,k) = pm1(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(1.0e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) - pm1_mmr(i,k) = pm1_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(1.0e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m))))) ! PM1 mass mixing ratio, dmleung - pm10(i,k) = pm10(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(10.0e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) - pm10_mmr(i,k) = pm10_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(10.0e-6_r8/dgncur_a(i,k,m))/ & - (2._r8**0.5_r8*alnsg(m))))) ! PM10 mass mixing ratio, dmleung - pmtot_mmr(i,k) = pmtot_mmr(i,k)+maer(i,k,m) ! toal PM mass mixing ratio, dmleung - ! dmleung -- + do m = 1, nmodes + ! output to history + write( trnum, '(i3.3)' ) m + call outfld( 'wat_a'//trnum(3:3), qaerwat(:,:,m), pcols, lchnk) + call outfld( 'dgnd_a'//trnum(2:3), dgncur_a(:,:,m), pcols, lchnk) + call outfld( 'dgnw_a'//trnum(2:3), dgncur_awet(:,:,m), pcols, lchnk) + + ! calculate PM2.5 diagnostics -- dgncur_a is zero above top_lev + do k = top_lev, pver + do i=1,ncol + pm25(i,k) = pm25(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(2.5e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) + ! dmleung 20 Oct 2025: calculate other PM diagnostics ++ + pm25_mmr(i,k) = pm25_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(2.5e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m))))) ! PM2.5 mass mixing ratio, dmleung + pm1(i,k) = pm1(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(1.0e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) + pm1_mmr(i,k) = pm1_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(1.0e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m))))) ! PM1 mass mixing ratio, dmleung + pm10(i,k) = pm10(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(10.0e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m)))))*rhoair(i,k) + pm10_mmr(i,k) = pm10_mmr(i,k)+maer(i,k,m)*(1._r8-(0.5_r8 - 0.5_r8*erf(log(10.0e-6_r8/dgncur_a(i,k,m))/ & + (2._r8**0.5_r8*alnsg(m))))) ! PM10 mass mixing ratio, dmleung + pmtot_mmr(i,k) = pmtot_mmr(i,k)+maer(i,k,m) ! toal PM mass mixing ratio, dmleung + ! dmleung -- + end do end do end do - end do - - call outfld('PM25', pm25(:,:), pcols, lchnk) - call outfld('PM25_SRF', pm25(:,pver), pcols, lchnk) - ! dmleung 20 Oct 2025 added history fields below ++ - call outfld('PM25_MMR', pm25_mmr(:,:), pcols, lchnk) - call outfld('PM1_SRF', pm1(:,pver), pcols, lchnk) - call outfld('PM1_MMR', pm1_mmr(:,:), pcols, lchnk) - call outfld('PM10_SRF', pm10(:,pver), pcols, lchnk) - call outfld('PM10_MMR', pm10_mmr(:,:), pcols, lchnk) - call outfld('PMTOT_MMR',pmtot_mmr(:,:),pcols, lchnk) - call outfld('RHO_AIR', rhoair(:,:), pcols, lchnk) - ! dmleung -- - - deallocate(maer, alnsg) - deallocate( & - wetrad, wetvol, wtrvol, wtpct, sulden, sulfeq_local, specdens_1 ) - -end subroutine modal_aero_wateruptake_dr + + call outfld('PM25', pm25(:,:), pcols, lchnk) + call outfld('PM25_SRF', pm25(:,pver), pcols, lchnk) + ! dmleung 20 Oct 2025 added history fields below ++ + call outfld('PM25_MMR', pm25_mmr(:,:), pcols, lchnk) + call outfld('PM1_SRF', pm1(:,pver), pcols, lchnk) + call outfld('PM1_MMR', pm1_mmr(:,:), pcols, lchnk) + call outfld('PM10_SRF', pm10(:,pver), pcols, lchnk) + call outfld('PM10_MMR', pm10_mmr(:,:), pcols, lchnk) + call outfld('PMTOT_MMR',pmtot_mmr(:,:),pcols, lchnk) + call outfld('RHO_AIR', rhoair(:,:), pcols, lchnk) + ! dmleung -- + + deallocate(maer, alnsg) + deallocate( & + wetrad, wetvol, wtrvol, wtpct, sulden, sulfeq_local, specdens_1 ) + + end subroutine modal_aero_wateruptake_dr !---------------------------------------------------------------------- - end module modal_aero_wateruptake_cam +end module modal_aero_wateruptake_cam From cc703a9358a660f238b61abc42c94b402131fb12 Mon Sep 17 00:00:00 2001 From: Haipeng Lin Date: Mon, 10 Aug 2026 14:09:53 -0400 Subject: [PATCH 5/6] Remove obsolescent rename loop labels --- src/chemistry/modal_aero/modal_aero_rename_cam.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/chemistry/modal_aero/modal_aero_rename_cam.F90 b/src/chemistry/modal_aero/modal_aero_rename_cam.F90 index 2cba007e7c..0b3149b171 100644 --- a/src/chemistry/modal_aero/modal_aero_rename_cam.F90 +++ b/src/chemistry/modal_aero/modal_aero_rename_cam.F90 @@ -295,7 +295,7 @@ subroutine modal_aero_rename_no_acc_crs_init write(lunout,9310) - do 2900 ipair = 1, npair_renamexf + do ipair = 1, npair_renamexf mfrm = modefrm_renamexf(ipair) mtoo = modetoo_renamexf(ipair) write(lunout,9320) ipair, mfrm, mtoo @@ -321,7 +321,7 @@ subroutine modal_aero_rename_no_acc_crs_init end if end do -2900 continue + end do write(lunout,*) end if ! ( masterproc ) @@ -432,7 +432,7 @@ subroutine modal_aero_rename_acc_crs_init ! define species involved in each tail-xfer pairing ! (include aerosol water) ! - do 1900 ipair = 1, npair_renamexf + do ipair = 1, npair_renamexf mfrm = modefrm_renamexf(ipair) mtoo = modetoo_renamexf(ipair) ixferable_all_renamexf(ipair) = 1 @@ -453,7 +453,7 @@ subroutine modal_aero_rename_acc_crs_init end if nspec = 0 - do 1490 iqfrm = -1, nspec_amode(mfrm) + do iqfrm = -1, nspec_amode(mfrm) if (iqfrm .eq. -1) then lsfrma = numptr_amode(mfrm) lstooa = numptr_amode(mtoo) @@ -461,7 +461,7 @@ subroutine modal_aero_rename_acc_crs_init lstooc = numptrcw_amode(mtoo) else if (iqfrm .eq. 0) then ! bypass transfer of aerosol water due to renaming - goto 1490 + cycle ! lsfrma = lwaterptr_amode(mfrm) ! lsfrmc = 0 ! lstooa = lwaterptr_amode(mtoo) @@ -551,10 +551,10 @@ subroutine modal_aero_rename_acc_crs_init ixferable_c_renamexf(iqfrm,ipair) = 1 end if end if -1490 continue + end do nspecfrm_renamexf(ipair) = nspec -1900 continue + end do 9100 format( / '*** subr. modal_aero_rename_acc_crs_init' / & 'lspecfrma out of range' / & From ea2a533431d4885a497f870adb925ab43b2db8c0 Mon Sep 17 00:00:00 2001 From: Haipeng Lin Date: Mon, 10 Aug 2026 15:30:02 -0400 Subject: [PATCH 6/6] Fix missing trailing & --- src/chemistry/aerosol/mo_setsox_cam.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/chemistry/aerosol/mo_setsox_cam.F90 b/src/chemistry/aerosol/mo_setsox_cam.F90 index 3d6626f380..dee536b404 100644 --- a/src/chemistry/aerosol/mo_setsox_cam.F90 +++ b/src/chemistry/aerosol/mo_setsox_cam.F90 @@ -251,8 +251,8 @@ subroutine setsox( aero_state, state, & call rad_cnst_get_gas(0, 'CO2', state, pbuf, co2_mass_mixing_ratio) ! call the portable subroutine: - call setsox_sub( - aero_state = aero_state, & + call setsox_sub( & + aero_state = aero_state, & ncol = ncol, & pver = pver, & dtime = dtime, &